diff --git a/CodeCompletion/CodeFormatter.cs b/CodeCompletion/CodeFormatter.cs index 607a06429..bb05671be 100644 --- a/CodeCompletion/CodeFormatter.cs +++ b/CodeCompletion/CodeFormatter.cs @@ -3464,6 +3464,18 @@ namespace CodeFormatters visit(new uint64_const(bi.val, bi.source_context)); //sb.Append("bi"); } + + public override void visit(property_ident _property_ident) + { + if (_property_ident.ln != null) + { + foreach (ident id in _property_ident.ln) + visit_node(id); + } + WriteAmpersandIfNeed(_property_ident); + sb.Append(prepare_ident(_property_ident.name)); + } + public override void visit(foreach_stmt_formatting fe) { WriteKeyword("foreach"); @@ -3485,4 +3497,6 @@ namespace CodeFormatters } #endregion } + + } \ No newline at end of file diff --git a/ParserTools/SyntaxTreeVisitors/SyntaxTreeComparer.cs b/ParserTools/SyntaxTreeVisitors/SyntaxTreeComparer.cs index f2ffee03c..b939bd322 100644 --- a/ParserTools/SyntaxTreeVisitors/SyntaxTreeComparer.cs +++ b/ParserTools/SyntaxTreeVisitors/SyntaxTreeComparer.cs @@ -143,7 +143,7 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left.expr, right.expr); } } - + public void CompareInternal(assign_var_tuple left, assign_var_tuple right) { if (left == null && right != null || left != null && right == null) @@ -154,7 +154,7 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left.expr, right.expr); } } - + public void CompareInternal(loop_stmt left, loop_stmt right) { if (left == null && right != null || left != null && right == null) @@ -452,7 +452,7 @@ namespace PascalABCCompiler.SyntaxTree throw_not_equal(left, right); if (left != null && right != null) { - + } } @@ -544,7 +544,7 @@ namespace PascalABCCompiler.SyntaxTree throw_not_equal(left, right); if (left != null && right != null) { - + } } @@ -716,6 +716,10 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left as dot_question_node, right as dot_question_node); else if (left is double_question_node) CompareInternal(left as double_question_node, right as double_question_node); + else if (left is bigint_const) + CompareInternal(left as bigint_const, right as bigint_const); + else if (left is array_const_new) + CompareInternal(left as array_const_new, right as array_const_new); else throw new NotImplementedException(left.GetType().ToString()); @@ -1022,7 +1026,7 @@ namespace PascalABCCompiler.SyntaxTree throw_not_equal(left, right); if (left != null && right != null) { - + } } @@ -1435,7 +1439,7 @@ namespace PascalABCCompiler.SyntaxTree throw_not_equal(left, right); if (left != null && right != null) { - + } } @@ -1711,6 +1715,8 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left as assign_tuple, right as assign_tuple); else if (left is assign_var_tuple) CompareInternal(left as assign_var_tuple, right as assign_var_tuple); + else if (left is match_with) + CompareInternal(left as match_with, right as match_with); //else if (left is expression) // SSM 12/06/15 // CompareInternal(left as expression, right as expression); @@ -1951,7 +1957,7 @@ namespace PascalABCCompiler.SyntaxTree throw_not_equal(left, right); if (left != null && right != null) { - + } } @@ -2366,7 +2372,7 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left.if_false, right.if_false); } } - + public void CompareInternal(dot_question_node left, dot_question_node right) { if (left == null && right != null || left != null && right == null) @@ -2377,7 +2383,7 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left.right, right.right); } } - + public void CompareInternal(double_question_node left, double_question_node right) { if (left == null && right != null || left != null && right == null) @@ -2388,5 +2394,89 @@ namespace PascalABCCompiler.SyntaxTree CompareInternal(left.right, right.right); } } + + public void CompareInternal(property_ident left, property_ident right) + { + if (left == null && right != null || left != null && right == null) + throw_not_equal(left, right); + if (left != null && right != null) + { + if (left.ln != null && right.ln == null) + throw_not_equal(left, right); + if (left.ln == null && right.ln != null) + throw_not_equal(left, right); + if (left.ln != null && right.ln != null) + { + if (left.ln.Count != right.ln.Count) + throw_not_equal(left, right); + for (int i = 0; i < left.ln.Count; i++) + { + CompareInternal(left.ln[i], right.ln[i]); + } + } + if (string.Compare(left.name, right.name, true) != 0) + throw_not_equal(left, right); + } + } + + public void CompareInternal(bigint_const left, bigint_const right) + { + if (left == null && right != null || left != null && right == null) + throw_not_equal(left, right); + if (left != null && right != null) + { + if (left.val != right.val) + throw_not_equal(left, right); + } + } + + public void CompareInternal(match_with left, match_with right) + { + if (left == null && right != null || left != null && right == null) + throw_not_equal(left, right); + if (left != null && right != null) + { + CompareInternal(left.expr, right.expr); + CompareInternal(left.defaultAction, right.defaultAction); + CompareInternal(left.case_list, right.case_list); + } + } + + public void CompareInternal(pattern_cases left, pattern_cases right) + { + if (left == null && right != null || left != null && right == null) + throw_not_equal(left, right); + if (left != null && right != null) + { + if (left.Count != right.Count) + throw_not_equal(left, right); + for (int i = 0; i < left.Count; i++) + CompareInternal(left.elements[i], right.elements[i]); + } + } + + public void CompareInternal(pattern_case left, pattern_case right) + { + if (left == null && right != null || left != null && right == null) + throw_not_equal(left, right); + if (left != null && right != null) + { + CompareInternal(left.case_action, right.case_action); + CompareInternal(left.condition, right.condition); + } + } + + public void CompareInternal(array_const_new left, array_const_new right) + { + if (left == null && right != null || left != null && right == null) + throw_not_equal(left, right); + if (left != null && right != null) + { + if (left.elements.Count != right.elements.Count) + throw_not_equal(left, right); + for (int i = 0; i < left.elements.Count; i++) + CompareInternal(left.elements.expressions[i], right.elements.expressions[i]); + } + } } } \ No newline at end of file diff --git a/Parsers/PascalABCParserNewSaushkin/ABCPascal.cs b/Parsers/PascalABCParserNewSaushkin/ABCPascal.cs index 8c5860a05..bdb734187 100644 --- a/Parsers/PascalABCParserNewSaushkin/ABCPascal.cs +++ b/Parsers/PascalABCParserNewSaushkin/ABCPascal.cs @@ -1,9 +1,9 @@ // // This CSharp output file generated by Gardens Point LEX // Version: 1.1.3.301 -// Machine: DESKTOP-G8V08V4 -// DateTime: 14.03.2021 20:13:22 -// UserName: ????????? +// Machine: DESKTOP-2BJCJ7I +// DateTime: 28.03.2021 12:12:58 +// UserName: ibond // GPLEX input file // GPLEX frame file // diff --git a/Parsers/PascalABCParserNewSaushkin/ABCPascal.y b/Parsers/PascalABCParserNewSaushkin/ABCPascal.y index 0d8f4ef11..00caab9cf 100644 --- a/Parsers/PascalABCParserNewSaushkin/ABCPascal.y +++ b/Parsers/PascalABCParserNewSaushkin/ABCPascal.y @@ -2040,11 +2040,11 @@ property_definition ; simple_property_definition - : tkProperty qualified_identifier property_interface property_specifiers tkSemiColon array_defaultproperty + : tkProperty func_name property_interface property_specifiers tkSemiColon array_defaultproperty { $$ = NewSimplePropertyDefinition($2 as method_name, $3 as property_interface, $4 as property_accessors, proc_attribute.attr_none, $6 as property_array_default, @$); } - | tkProperty qualified_identifier property_interface property_specifiers tkSemiColon property_modificator tkSemiColon array_defaultproperty + | tkProperty func_name property_interface property_specifiers tkSemiColon property_modificator tkSemiColon array_defaultproperty { proc_attribute pa = proc_attribute.attr_none; if ($6.name.ToLower() == "virtual") @@ -2055,22 +2055,22 @@ simple_property_definition pa = proc_attribute.attr_abstract; $$ = NewSimplePropertyDefinition($2 as method_name, $3 as property_interface, $4 as property_accessors, pa, $8 as property_array_default, @$); } - | class_or_static tkProperty qualified_identifier property_interface property_specifiers tkSemiColon array_defaultproperty + | class_or_static tkProperty func_name property_interface property_specifiers tkSemiColon array_defaultproperty { $$ = NewSimplePropertyDefinition($3 as method_name, $4 as property_interface, $5 as property_accessors, proc_attribute.attr_none, $7 as property_array_default, @$); ($$ as simple_property).attr = definition_attribute.Static; } - | class_or_static tkProperty qualified_identifier property_interface property_specifiers tkSemiColon property_modificator tkSemiColon array_defaultproperty + | class_or_static tkProperty func_name property_interface property_specifiers tkSemiColon property_modificator tkSemiColon array_defaultproperty { parsertools.AddErrorFromResource("STATIC_PROPERTIES_CANNOT_HAVE_ATTRBUTE_{0}",@7,$7.name); } - | tkAuto tkProperty qualified_identifier property_interface optional_property_initialization tkSemiColon + | tkAuto tkProperty func_name property_interface optional_property_initialization tkSemiColon { $$ = NewSimplePropertyDefinition($3 as method_name, $4 as property_interface, null, proc_attribute.attr_none, null, @$); ($$ as simple_property).is_auto = true; ($$ as simple_property).initial_value = $5; } - | class_or_static tkAuto tkProperty qualified_identifier property_interface optional_property_initialization tkSemiColon + | class_or_static tkAuto tkProperty func_name property_interface optional_property_initialization tkSemiColon { $$ = NewSimplePropertyDefinition($4 as method_name, $5 as property_interface, null, proc_attribute.attr_none, null, @$); ($$ as simple_property).is_auto = true; diff --git a/Parsers/PascalABCParserNewSaushkin/ABCPascalYacc.cs b/Parsers/PascalABCParserNewSaushkin/ABCPascalYacc.cs index 4337f8955..9a259e7f9 100644 --- a/Parsers/PascalABCParserNewSaushkin/ABCPascalYacc.cs +++ b/Parsers/PascalABCParserNewSaushkin/ABCPascalYacc.cs @@ -1,10 +1,10 @@ // (see accompanying GPPGcopyright.rtf) // GPPG version 1.3.6 -// Machine: DESKTOP-G8V08V4 -// DateTime: 14.03.2021 20:13:22 -// UserName: ????????? -// Input file +// Machine: DESKTOP-2BJCJ7I +// DateTime: 28.03.2021 12:12:59 +// UserName: ibond +// Input file // options: no-lines gplex @@ -59,7 +59,7 @@ public abstract class ScanBase : AbstractScanner { - // Verbatim content from D:\PABC_Git\Parsers\PascalABCParserNewSaushkin\ABCPascal.y + // Verbatim content from ABCPascal.y // ��� ���������� ����������� � ����� GPPGParser, �������������� ����� ������, ������������ �������� gppg public syntax_tree_node root; // �������� ���� ��������������� ������ @@ -71,13 +71,13 @@ public partial class GPPGParser: ShiftReduceParser scanner) : base(scanner) { } - // End verbatim content from D:\PABC_Git\Parsers\PascalABCParserNewSaushkin\ABCPascal.y + // End verbatim content from ABCPascal.y #pragma warning disable 649 private static Dictionary aliasses; #pragma warning restore 649 private static Rule[] rules = new Rule[1001]; - private static State[] states = new State[1655]; + private static State[] states = new State[1650]; private static string[] nonTerms = new string[] { "parse_goal", "unit_key_word", "class_or_static", "assignment", "optional_array_initializer", "attribute_declarations", "ot_visibility_specifier", "one_attribute", "attribute_variable", @@ -171,13 +171,13 @@ public partial class GPPGParser: ShiftReduceParser tkProperty, qualified_identifier, - // property_interface, property_specifiers, - // tkSemiColon, array_defaultproperty + case 383: // simple_property_definition -> tkProperty, func_name, property_interface, + // property_specifiers, tkSemiColon, + // array_defaultproperty { CurrentSemanticValue.stn = NewSimplePropertyDefinition(ValueStack[ValueStack.Depth-5].stn as method_name, ValueStack[ValueStack.Depth-4].stn as property_interface, ValueStack[ValueStack.Depth-3].stn as property_accessors, proc_attribute.attr_none, ValueStack[ValueStack.Depth-1].stn as property_array_default, CurrentLocationSpan); } break; - case 384: // simple_property_definition -> tkProperty, qualified_identifier, - // property_interface, property_specifiers, - // tkSemiColon, property_modificator, tkSemiColon, + case 384: // simple_property_definition -> tkProperty, func_name, property_interface, + // property_specifiers, tkSemiColon, + // property_modificator, tkSemiColon, // array_defaultproperty { proc_attribute pa = proc_attribute.attr_none; @@ -4597,7 +4592,7 @@ public partial class GPPGParser: ShiftReduceParser class_or_static, tkProperty, qualified_identifier, + case 385: // simple_property_definition -> class_or_static, tkProperty, func_name, // property_interface, property_specifiers, // tkSemiColon, array_defaultproperty { @@ -4605,7 +4600,7 @@ public partial class GPPGParser: ShiftReduceParser class_or_static, tkProperty, qualified_identifier, + case 386: // simple_property_definition -> class_or_static, tkProperty, func_name, // property_interface, property_specifiers, // tkSemiColon, property_modificator, tkSemiColon, // array_defaultproperty @@ -4613,8 +4608,7 @@ public partial class GPPGParser: ShiftReduceParser tkAuto, tkProperty, qualified_identifier, - // property_interface, + case 387: // simple_property_definition -> tkAuto, tkProperty, func_name, property_interface, // optional_property_initialization, tkSemiColon { CurrentSemanticValue.stn = NewSimplePropertyDefinition(ValueStack[ValueStack.Depth-4].stn as method_name, ValueStack[ValueStack.Depth-3].stn as property_interface, null, proc_attribute.attr_none, null, CurrentLocationSpan); @@ -4622,8 +4616,8 @@ public partial class GPPGParser: ShiftReduceParser class_or_static, tkAuto, tkProperty, - // qualified_identifier, property_interface, + case 388: // simple_property_definition -> class_or_static, tkAuto, tkProperty, func_name, + // property_interface, // optional_property_initialization, tkSemiColon { CurrentSemanticValue.stn = NewSimplePropertyDefinition(ValueStack[ValueStack.Depth-4].stn as method_name, ValueStack[ValueStack.Depth-3].stn as property_interface, null, proc_attribute.attr_none, null, CurrentLocationSpan); diff --git a/Parsers/PascalABCParserNewSaushkin/SemanticRules.cs b/Parsers/PascalABCParserNewSaushkin/SemanticRules.cs index 78bf9855b..19440a9e3 100644 --- a/Parsers/PascalABCParserNewSaushkin/SemanticRules.cs +++ b/Parsers/PascalABCParserNewSaushkin/SemanticRules.cs @@ -174,7 +174,7 @@ namespace GPPGParserScanner public method_name NewQualifiedIdentifier(method_name qualified_identifier, ident identifier, LexLocation loc) { var nqi = qualified_identifier; - nqi.class_name = nqi.meth_name; + nqi.class_name = nqi.meth_name; nqi.meth_name = identifier; nqi.source_context = loc; return nqi; @@ -200,8 +200,15 @@ namespace GPPGParserScanner { var nnspd = new simple_property(); nnspd.virt_over_none_attr = virt_over_none_attr; - - nnspd.property_name = qualified_identifier.meth_name; + List ln = null; + if (qualified_identifier.ln != null) + ln = qualified_identifier.ln; + else if (qualified_identifier.class_name != null) + { + ln = new List(); + ln.Add(qualified_identifier.class_name); + } + nnspd.property_name = new property_ident(qualified_identifier.meth_name.name, ln, qualified_identifier.source_context); if (property_interface != null) { nnspd.parameter_list = property_interface.parameter_list; diff --git a/SyntaxTree/tree/AbstractVisitor.cs b/SyntaxTree/tree/AbstractVisitor.cs index afb88d362..9b3de33fa 100644 --- a/SyntaxTree/tree/AbstractVisitor.cs +++ b/SyntaxTree/tree/AbstractVisitor.cs @@ -1292,6 +1292,11 @@ namespace PascalABCCompiler.SyntaxTree { DefaultVisit(_foreach_stmt_formatting); } + + public virtual void visit(property_ident _property_ident) + { + DefaultVisit(_property_ident); + } } diff --git a/SyntaxTree/tree/HierarchyVisitor.cs b/SyntaxTree/tree/HierarchyVisitor.cs index 8dd361b35..151658719 100644 --- a/SyntaxTree/tree/HierarchyVisitor.cs +++ b/SyntaxTree/tree/HierarchyVisitor.cs @@ -2061,6 +2061,14 @@ namespace PascalABCCompiler.SyntaxTree { } + public virtual void pre_do_visit(property_ident _property_ident) + { + } + + public virtual void post_do_visit(property_ident _property_ident) + { + } + public override void visit(expression _expression) { DefaultVisit(_expression); @@ -4256,6 +4264,15 @@ namespace PascalABCCompiler.SyntaxTree visit(foreach_stmt_formatting.stmt); post_do_visit(_foreach_stmt_formatting); } + + public override void visit(property_ident _property_ident) + { + DefaultVisit(_property_ident); + pre_do_visit(_property_ident); + for (int i = 0; i < ln.Count; i++) + visit(property_ident.ln[i]); + post_do_visit(_property_ident); + } } diff --git a/SyntaxTree/tree/NodesBuilder.cs b/SyntaxTree/tree/NodesBuilder.cs index 416ec4d6f..5641756c7 100644 --- a/SyntaxTree/tree/NodesBuilder.cs +++ b/SyntaxTree/tree/NodesBuilder.cs @@ -112,7 +112,7 @@ namespace PascalABCCompiler.SyntaxTree public static simple_property BuildSimpleReadWriteProperty(ident name, ident field, type_definition type) { - return new simple_property(name, type, new property_accessors(new read_accessor_name(field,null,null), new write_accessor_name(field, null, null))); + return new simple_property(new property_ident(name.name, null, name.source_context), type, new property_accessors(new read_accessor_name(field,null,null), new write_accessor_name(field, null, null))); } public static class_members BuildSimpleReadPropertiesSection(List names, List fields, List types) diff --git a/SyntaxTree/tree/SyntaxTreeStreamReader.cs b/SyntaxTree/tree/SyntaxTreeStreamReader.cs index f9b90ba3a..66244297b 100644 --- a/SyntaxTree/tree/SyntaxTreeStreamReader.cs +++ b/SyntaxTree/tree/SyntaxTreeStreamReader.cs @@ -534,6 +534,8 @@ namespace PascalABCCompiler.SyntaxTree return new bigint_const(); case 256: return new foreach_stmt_formatting(); + case 257: + return new property_ident(); } return null; } @@ -1724,7 +1726,7 @@ namespace PascalABCCompiler.SyntaxTree public void read_simple_property(simple_property _simple_property) { read_declaration(_simple_property); - _simple_property.property_name = _read_node() as ident; + _simple_property.property_name = _read_node() as property_ident; _simple_property.property_type = _read_node() as type_definition; _simple_property.index_expression = _read_node() as expression; _simple_property.accessors = _read_node() as property_accessors; @@ -4475,6 +4477,30 @@ namespace PascalABCCompiler.SyntaxTree _foreach_stmt_formatting.stmt = _read_node() as statement; } + + public void visit(property_ident _property_ident) + { + read_property_ident(_property_ident); + } + + public void read_property_ident(property_ident _property_ident) + { + read_ident(_property_ident); + if (br.ReadByte() == 0) + { + _property_ident.ln = null; + } + else + { + _property_ident.ln = new List(); + Int32 ssyy_count = br.ReadInt32(); + for(Int32 ssyy_i = 0; ssyy_i < ssyy_count; ssyy_i++) + { + _property_ident.ln.Add(_read_node() as ident); + } + } + } + } diff --git a/SyntaxTree/tree/SyntaxTreeStreamWriter.cs b/SyntaxTree/tree/SyntaxTreeStreamWriter.cs index d735fca87..f5302a663 100644 --- a/SyntaxTree/tree/SyntaxTreeStreamWriter.cs +++ b/SyntaxTree/tree/SyntaxTreeStreamWriter.cs @@ -7011,6 +7011,39 @@ namespace PascalABCCompiler.SyntaxTree } } + + public void visit(property_ident _property_ident) + { + bw.Write((Int16)257); + write_property_ident(_property_ident); + } + + public void write_property_ident(property_ident _property_ident) + { + write_ident(_property_ident); + if (_property_ident.ln == null) + { + bw.Write((byte)0); + } + else + { + bw.Write((byte)1); + bw.Write(_property_ident.ln.Count); + for(Int32 ssyy_i = 0; ssyy_i < _property_ident.ln.Count; ssyy_i++) + { + if (_property_ident.ln[ssyy_i] == null) + { + bw.Write((byte)0); + } + else + { + bw.Write((byte)1); + _property_ident.ln[ssyy_i].visit(this); + } + } + } + } + } diff --git a/SyntaxTree/tree/Tree.cs b/SyntaxTree/tree/Tree.cs index ac64ccd3f..472957b4b 100644 --- a/SyntaxTree/tree/Tree.cs +++ b/SyntaxTree/tree/Tree.cs @@ -16294,7 +16294,7 @@ namespace PascalABCCompiler.SyntaxTree /// ///Конструктор с параметрами. /// - public simple_property(ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value) + public simple_property(property_ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value) { this._property_name=_property_name; this._property_type=_property_type; @@ -16312,7 +16312,7 @@ namespace PascalABCCompiler.SyntaxTree /// ///Конструктор с параметрами. /// - public simple_property(ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value,SourceContext sc) + public simple_property(property_ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value,SourceContext sc) { this._property_name=_property_name; this._property_type=_property_type; @@ -16327,7 +16327,7 @@ namespace PascalABCCompiler.SyntaxTree source_context = sc; FillParentsInDirectChilds(); } - protected ident _property_name; + protected property_ident _property_name; protected type_definition _property_type; protected expression _index_expression; protected property_accessors _accessors; @@ -16341,7 +16341,7 @@ namespace PascalABCCompiler.SyntaxTree /// /// /// - public ident property_name + public property_ident property_name { get { @@ -16517,7 +16517,7 @@ namespace PascalABCCompiler.SyntaxTree } if (property_name != null) { - copy.property_name = (ident)property_name.Clone(); + copy.property_name = (property_ident)property_name.Clone(); copy.property_name.Parent = copy; } if (property_type != null) @@ -16652,7 +16652,7 @@ namespace PascalABCCompiler.SyntaxTree switch(ind) { case 0: - property_name = (ident)value; + property_name = (property_ident)value; break; case 1: property_type = (type_definition)value; @@ -16727,7 +16727,7 @@ namespace PascalABCCompiler.SyntaxTree /// ///Конструктор с параметрами. /// - public index_property(ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value,formal_parameters _property_parametres,default_indexer_property_node _is_default) + public index_property(property_ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value,formal_parameters _property_parametres,default_indexer_property_node _is_default) { this._property_name=_property_name; this._property_type=_property_type; @@ -16747,7 +16747,7 @@ namespace PascalABCCompiler.SyntaxTree /// ///Конструктор с параметрами. /// - public index_property(ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value,formal_parameters _property_parametres,default_indexer_property_node _is_default,SourceContext sc) + public index_property(property_ident _property_name,type_definition _property_type,expression _index_expression,property_accessors _accessors,property_array_default _array_default,property_parameter_list _parameter_list,definition_attribute _attr,proc_attribute _virt_over_none_attr,bool _is_auto,expression _initial_value,formal_parameters _property_parametres,default_indexer_property_node _is_default,SourceContext sc) { this._property_name=_property_name; this._property_type=_property_type; @@ -16816,7 +16816,7 @@ namespace PascalABCCompiler.SyntaxTree } if (property_name != null) { - copy.property_name = (ident)property_name.Clone(); + copy.property_name = (property_ident)property_name.Clone(); copy.property_name.Parent = copy; } if (property_type != null) @@ -16971,7 +16971,7 @@ namespace PascalABCCompiler.SyntaxTree switch(ind) { case 0: - property_name = (ident)value; + property_name = (property_ident)value; break; case 1: property_type = (type_definition)value; @@ -54740,6 +54740,359 @@ namespace PascalABCCompiler.SyntaxTree } + /// + /// + /// + [Serializable] + public partial class property_ident : ident + { + + /// + ///Конструктор без параметров. + /// + public property_ident() + { + + } + + /// + ///Конструктор с параметрами. + /// + public property_ident(List _ln) + { + this._ln=_ln; + FillParentsInDirectChilds(); + } + + /// + ///Конструктор с параметрами. + /// + public property_ident(List _ln,SourceContext sc) + { + this._ln=_ln; + source_context = sc; + FillParentsInDirectChilds(); + } + + /// + ///Конструктор с параметрами. + /// + public property_ident(string _name,List _ln) + { + this._name=_name; + this._ln=_ln; + FillParentsInDirectChilds(); + } + + /// + ///Конструктор с параметрами. + /// + public property_ident(string _name,List _ln,SourceContext sc) + { + this._name=_name; + this._ln=_ln; + source_context = sc; + FillParentsInDirectChilds(); + } + public property_ident(ident elem, SourceContext sc = null) + { + Add(elem, sc); + FillParentsInDirectChilds(); + } + + protected List _ln; + + /// + /// + /// + public List ln + { + get + { + return _ln; + } + set + { + _ln=value; + } + } + + + public property_ident Add(ident elem, SourceContext sc = null) + { + ln.Add(elem); + if (elem != null) + elem.Parent = this; + if (sc != null) + source_context = sc; + return this; + } + + public void AddFirst(ident el) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + ln.Insert(0, el); + FillParentsInDirectChilds(); + } + + public void AddFirst(IEnumerable els) + { + if (els == null) + throw new ArgumentNullException(nameof(els)); + ln.InsertRange(0, els); + foreach (var el in els) + if (el != null) + el.Parent = this; + } + + public void AddMany(params ident[] els) + { + if (els == null) + throw new ArgumentNullException(nameof(els)); + ln.AddRange(els); + foreach (var el in els) + if (el != null) + el.Parent = this; + } + + private int FindIndexInList(ident el) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + var ind = ln.FindIndex(x => x == el); + if (ind == -1) + throw new Exception(string.Format("У списка {0} не найден элемент {1} среди дочерних\n", this, el)); + return ind; + } + + public void InsertAfter(ident el, ident newel) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + if (newel == null) + throw new ArgumentNullException(nameof(newel)); + ln.Insert(FindIndexInList(el) + 1, newel); + newel.Parent = this; + } + + public void InsertAfter(ident el, IEnumerable newels) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + if (newels == null) + throw new ArgumentNullException(nameof(newels)); + ln.InsertRange(FindIndexInList(el) + 1, newels); + foreach (var newel in newels) + if (newel != null) + newel.Parent = this; + } + + public void InsertBefore(ident el, ident newel) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + if (newel == null) + throw new ArgumentNullException(nameof(newel)); + ln.Insert(FindIndexInList(el), newel); + newel.Parent = this; + } + + public void InsertBefore(ident el, IEnumerable newels) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + if (newels == null) + throw new ArgumentNullException(nameof(newels)); + ln.InsertRange(FindIndexInList(el), newels); + foreach (var newel in newels) + if (newel != null) + newel.Parent = this; + } + + public bool Remove(ident el) + { + return ln.Remove(el); + } + + public void ReplaceInList(ident el, ident newel) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + if (newel == null) + throw new ArgumentNullException(nameof(newel)); + ln[FindIndexInList(el)] = newel; + newel.Parent = this; + } + + public void ReplaceInList(ident el, IEnumerable newels) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + if (newels == null) + throw new ArgumentNullException(nameof(newels)); + var ind = FindIndexInList(el); + ln.RemoveAt(ind); + ln.InsertRange(ind, newels); + foreach (var newel in newels) + if (newel != null) + newel.Parent = this; + } + + public int RemoveAll(Predicate match) + { + return ln.RemoveAll(match); + } + + public ident Last() + { + if (ln.Count > 0) + return ln[ln.Count - 1]; + throw new InvalidOperationException("Список пуст"); + } + + public int Count + { + get { return ln.Count; } + } + + public void Insert(int pos, ident el) + { + if (el == null) + throw new ArgumentNullException(nameof(el)); + ln.Insert(pos,el); + if (el != null) + el.Parent = this; + } + + + /// Создает копию узла + public override syntax_tree_node Clone() + { + property_ident copy = new property_ident(); + copy.Parent = this.Parent; + if (source_context != null) + copy.source_context = new SourceContext(source_context); + if (attributes != null) + { + copy.attributes = (attribute_list)attributes.Clone(); + copy.attributes.Parent = copy; + } + copy.name = name; + if (ln != null) + { + foreach (ident elem in ln) + { + if (elem != null) + { + copy.Add((ident)elem.Clone()); + copy.Last().Parent = copy; + } + else + copy.Add(null); + } + } + return copy; + } + + /// Получает копию данного узла корректного типа + public new property_ident TypedClone() + { + return Clone() as property_ident; + } + + /// Заполняет поля Parent в непосредственных дочерних узлах + public override void FillParentsInDirectChilds() + { + if (attributes != null) + attributes.Parent = this; + if (ln != null) + { + foreach (var child in ln) + if (child != null) + child.Parent = this; + } + } + + /// Заполняет поля Parent во всем поддереве + public override void FillParentsInAllChilds() + { + FillParentsInDirectChilds(); + attributes?.FillParentsInAllChilds(); + if (ln != null) + { + foreach (var child in ln) + child?.FillParentsInAllChilds(); + } + } + + /// + ///Свойство для получения количества всех подузлов без элементов поля типа List + /// + public override Int32 subnodes_without_list_elements_count + { + get + { + return 0; + } + } + /// + ///Свойство для получения количества всех подузлов. Подузлом также считается каждый элемент поля типа List + /// + public override Int32 subnodes_count + { + get + { + return 0 + (ln == null ? 0 : ln.Count); + } + } + /// + ///Индексатор для получения всех подузлов + /// + public override syntax_tree_node this[Int32 ind] + { + get + { + if(subnodes_count == 0 || ind < 0 || ind > subnodes_count-1) + throw new IndexOutOfRangeException(); + Int32 index_counter=ind - 0; + if(ln != null) + { + if(index_counter < ln.Count) + { + return ln[index_counter]; + } + } + return null; + } + set + { + if(subnodes_count == 0 || ind < 0 || ind > subnodes_count-1) + throw new IndexOutOfRangeException(); + Int32 index_counter=ind - 0; + if(ln != null) + { + if(index_counter < ln.Count) + { + ln[index_counter]= (ident)value; + return; + } + } + } + } + /// + ///Метод для обхода дерева посетителем + /// + ///Объект-посетитель. + ///Return value is void + public override void visit(IVisitor visitor) + { + visitor.visit(this); + } + + } + + } diff --git a/SyntaxTree/tree/TreeHelper.cs b/SyntaxTree/tree/TreeHelper.cs index e1a5c6448..b4ca78e16 100644 --- a/SyntaxTree/tree/TreeHelper.cs +++ b/SyntaxTree/tree/TreeHelper.cs @@ -1123,7 +1123,7 @@ namespace PascalABCCompiler.SyntaxTree public partial class simple_property { - public simple_property(ident name, type_definition type, property_accessors accessors, SourceContext sc = null) + public simple_property(property_ident name, type_definition type, property_accessors accessors, SourceContext sc = null) : this(name, type, null, accessors, null, null, definition_attribute.None, proc_attribute.attr_none, false, null, sc) { } } diff --git a/SyntaxTree/tree/Visitor.cs b/SyntaxTree/tree/Visitor.cs index 700f9e339..28bf29f6c 100644 --- a/SyntaxTree/tree/Visitor.cs +++ b/SyntaxTree/tree/Visitor.cs @@ -1546,6 +1546,12 @@ namespace PascalABCCompiler.SyntaxTree ///Node to visit /// Return value is void void visit(foreach_stmt_formatting _foreach_stmt_formatting); + /// + ///Method to visit property_ident. + /// + ///Node to visit + /// Return value is void + void visit(property_ident _property_ident); } diff --git a/SyntaxTree/tree/tree.xml b/SyntaxTree/tree/tree.xml index 535f16ca1..77fc94f2b 100644 --- a/SyntaxTree/tree/tree.xml +++ b/SyntaxTree/tree/tree.xml @@ -1013,7 +1013,7 @@ - + @@ -3313,6 +3313,16 @@ + + + + + + + + + + Tree.cs @@ -3391,6 +3401,7 @@ + @@ -4336,11 +4347,15 @@ + + + + diff --git a/TestSuite/errors/err0408.pas b/TestSuite/errors/err0408.pas new file mode 100644 index 000000000..c08ec6dba --- /dev/null +++ b/TestSuite/errors/err0408.pas @@ -0,0 +1,20 @@ +type + I1 = interface + property X: byte read; + end; + + I2 = interface + property X: byte read; + end; + + T = class(I1, I2) + public + property I1.X: byte read 0; + //I2.X не реализовано, но компиляция успешна + end; + +begin + var x := new T(); + Writeln(I1(x).X); + Writeln(I2(x).X); +end. \ No newline at end of file diff --git a/TestSuite/errors/err0409.pas b/TestSuite/errors/err0409.pas new file mode 100644 index 000000000..0899716b1 --- /dev/null +++ b/TestSuite/errors/err0409.pas @@ -0,0 +1,14 @@ +type + I1 = interface + property X: byte read; + end; + + T = class(I1) + public + property T.X: byte read 0; + end; + +begin + var x := new T(); + Writeln(I1(x).X); +end. \ No newline at end of file diff --git a/TestSuite/explicitinterface10.pas b/TestSuite/explicitinterface10.pas new file mode 100644 index 000000000..a54dfc30f --- /dev/null +++ b/TestSuite/explicitinterface10.pas @@ -0,0 +1,16 @@ +type + I1 = interface + property X: integer read; + end; + + T1 = record(I1) + property X: integer read 1; + property I1.X: integer read 2; + end; + +begin + var r: T1; + assert(r.X = 1); + var r1: I1 := r; + assert(r1.X = 2); +end. \ No newline at end of file diff --git a/TestSuite/explicitinterface9.pas b/TestSuite/explicitinterface9.pas new file mode 100644 index 000000000..5d1eadf46 --- /dev/null +++ b/TestSuite/explicitinterface9.pas @@ -0,0 +1,16 @@ +type + I1 = interface + property X: integer read; + end; + + T1 = record(I1) + property X: integer read 1; + property I1.X: integer read 2; + end; + +begin + var r: T1; + assert(r.X = 1); + var r1: I1 := r; + assert(r1.X = 2); +end. \ No newline at end of file diff --git a/TestSuite/formatter_tests/input/GraphWPF.pas b/TestSuite/formatter_tests/input/GraphWPF.pas index 5ef18198f..9180fcb5d 100644 --- a/TestSuite/formatter_tests/input/GraphWPF.pas +++ b/TestSuite/formatter_tests/input/GraphWPF.pas @@ -376,8 +376,12 @@ procedure MoveRel(dx,dy: real); /// Рисует отрезок от текущей позиции до точки, смещённой на вектор (dx,dy). Текущая позиция переносится в новую точку procedure LineRel(dx,dy: real); /// Перемещает текущую позицию рисования на вектор (dx,dy) -procedure MoveOn(dx,dy: real); +procedure MoveBy(dx,dy: real); /// Рисует отрезок от текущей позиции до точки, смещённой на вектор (dx,dy). Текущая позиция переносится в новую точку +procedure LineBy(dx,dy: real); +///-- +procedure MoveOn(dx,dy: real); +///-- procedure LineOn(dx,dy: real); /// Рисует ломаную, заданную массивом точек @@ -1206,6 +1210,8 @@ procedure MoveRel(dx,dy: real) := (Pen.fx,Pen.fy) := (Pen.fx + dx, Pen.fy + dy); procedure LineRel(dx,dy: real) := LineTo(Pen.fx + dx, Pen.fy + dy); procedure MoveOn(dx,dy: real) := MoveRel(dx,dy); procedure LineOn(dx,dy: real) := LineRel(dx,dy); +procedure MoveBy(dx,dy: real) := MoveRel(dx,dy); +procedure LineBy(dx,dy: real) := LineRel(dx,dy); procedure PolyLine(points: array of Point) := InvokeVisual(PolyLineP,points); procedure PolyLine(points: array of Point; c: GColor) := InvokeVisual(PolyLinePC,points,c); @@ -1614,6 +1620,11 @@ begin var sz := Size(host.DataContext); + if sz.Width = 0 then + sz.Width := GraphWindow.Width; + if sz.Height = 0 then + sz.Height := GraphWindow.Height; + var bmp := new RenderTargetBitmap(Round(sz.Width*scalex), Round(sz.Height*scaley), dpiX, dpiY, PixelFormats.Pbgra32); var myvis := new DrawingVisual(); diff --git a/TestSuite/formatter_tests/input/OpenCLABC.pas b/TestSuite/formatter_tests/input/OpenCLABC.pas index cfc27c035..bf3b5a1f4 100644 --- a/TestSuite/formatter_tests/input/OpenCLABC.pas +++ b/TestSuite/formatter_tests/input/OpenCLABC.pas @@ -24,67 +24,2691 @@ /// unit OpenCLABC; +{$region ToDo} + +//=================================== +// Обязательно сделать до следующего пула: + +//ToDo .WhenDone после завершения выполнения странно себя вёл... + +//=================================== +// Запланированное: + +//ToDo Синхронные (с припиской Fast, а может Quick) варианты всего работающего по принципу HostQueue +// +//ToDo И асинхронные умнее запускать - помнить значение, указывающее можно ли выполнить их синхронно +// - Может даже можно синхронно выполнить "HPQ(...)+HPQ(...)", в некоторых случаях? +//ToDo Enqueueabl-ы вызывают .Invoke для первого параметра и .InvokeNewQ для остальных +// - А что если все параметры кроме последнего - константы? +// - Надо как то умнее это обрабатывать +//ToDo И сделать наконец нормальный класс-контейнер состояния очереди, параметрами всё не передашь + +//ToDo .Cast.ThenWaitMarker.Cast не оптимизируется - а можно было бы и оптимизировать +// - Для этого надо создавать ещё один псевдо-маркер, но давать ему тот же маркер +// - Но тогда маркер будет активироваться даже если первое преобразование неправильное... + +//ToDo Проверять ".IsReadOnly" перед запасным копированием коллекций + +//ToDo В методах вроде .AddWriteArray1 приходится добавлять &<> + +//ToDo Подумать как об этом можно написать в справке (или не в справке): +// - ReadValue отсутствует +// --- В объяснении KernelArg из указателя всё уже сказано +// --- Надо только как то объединить, чтоб текст был не только про KernelArg... +// - FillArray отсутствует +// --- Проблема в том, что нет блокирующего варианта cl.FillArray +// --- Вообще в теории можно написать отдельную мелкую неуправляемую .dll и $resource её +// --- Но это жесть сколько усложнений ради 1 метода... + +//ToDo А что если вещи, которые могут привести к утечкам памяти при ThreadAbortException (как конструктор контекста) сувать в finally пустого try? +// - Вообще, поидее, должен быть более красивый способ добиться того же... Что то с контрактами? +// - Обязательно сравнить скорость, перед тем как применять... + +//ToDo Buffer переименовать в GPUMem +//ToDo И добавить типы как GPUArray - наверное с методом вроде .Flush, для более эффективной записи +// +//ToDo Инициалию буфера из BufferCommandQueue перенести в, собственно, вызовы GPUCommand.Invoke +// - И там же вызывать GPUArray.Flush + +//ToDo Можно же сохранять неуправляемые очереди в список внутри CLTask, и затем использовать несколько раз +// - И почему я раньше об этом не подумал... + +//ToDo В тестеровщике, в тестах ошибок, в текстах ошибок - постоянно меняются номера лямбд... +// - Наверное стоит захардкодить в тестировщик игнор числа после "<>lambda", и так же для контейнера лямбды + +//ToDo Заполнение Platform.All сейчас вылетит на компе с 0 платформ... +// - Сразу не забыть исправить описание + +//ToDo Всё же стоит добавить .ThenUse - аналог .ThenConvert, не изменяющий значение, а только использующий + +//ToDo IWaitQueue.CancelWait +//ToDo WaitAny(aborter, WaitAll(...)); +// - Что случится с WaitAll если aborter будет первым? +// - Очереди переданные в Wait - вообще не запускаются так +// - Поэтому я и думал про что то типа CancelWait +// - А вообще лучше разрешить выполнять Wait внутри другого Wait +// - И заодно проверить чтобы Abort работало на Wait-ы +// - А вообще всё не то - это костыли +// - Надо специально разрешить передавать какой то маркер аборта +// - И только в WaitAll, другим Wait-ам это не нужно +// - Или можно забыть про всё это и сделать+использовать AbortQueue чтоб убивать и Wait-ы, и всё остальное + +//ToDo Проверки и кидания исключений перед всеми cl.*, чтобы выводить норм сообщения об ошибках +// - В том числе проверки с помощью BlittableHelper + +//ToDo Создание SubDevice из cl_device_id + +//ToDo Очереди-маркеры для Wait-очередей +// - чтобы не приходилось использовать константные для этого + +//ToDo Очередь-обработчик ошибок +// - .HandleExceptions +// - Сделать легко, надо только вставить свой промежуточный CLTaskBase +// - Единственное - для Wait очереди надо хранить так же оригинальный CLTaskBase +//ToDo И какой то аналог try-finally +// - .ThenFinally ? +//ToDo Раздел справки про обработку ошибок +// - Написать что аналог try-finally стоит использовать на Wait-маркерах для потоко-безопастности +// +//ToDo Когда будут очереди-обработчики - удалить ивенты CLTask-ов. Они, по сути, ограниченная версия. +// - И использование их тут изнутри - в целом говнокод... + +//ToDo .Cycle(integer) +//ToDo .Cycle // бесконечность циклов +//ToDo .CycleWhile(***->boolean) +// - Возможность передать свой обработчик ошибок как Exception->Exception +//ToDo В продолжение Cycle: Однако всё ещё остаётся проблема - как сделать ветвление? +// - И если уже делать - стоит сделать и метод CQ.ThenIf(res->boolean; if_true, if_false: CQ) +//ToDo И ещё - AbortQueue, который, по сути, может использоваться как exit, continue или break, если с обработчиками ошибок +// - Или может метод MarkerQueue.Abort? + +//ToDo Интегрировать профайлинг очередей + +//ToDo Перепродумать SubBuffer, в случае перевыделения основного буфера - он плохо себя ведёт... + +//ToDo Может всё же сделать защиту от дурака для "q.AddQueue(q)"? +// - И в справке тогда убрать параграф... + +//=================================== +// Сделать когда-нибуть: + +//ToDo Пройтись по всем функциям OpenCL, посмотреть функционал каких не доступен из OpenCLABC +// - clGetKernelWorkGroupInfo - свойства кернела на определённом устройстве + +//=================================== + +{$endregion ToDo} + +{$region Bugs} + +//ToDo Issue компилятора: +//ToDo https://github.com/pascalabcnet/pascalabcnet/issues/{id} +// - #2221 +// - #2431 + +//ToDo Баги NVidia +//ToDo https://developer.nvidia.com/nvidia_bug/{id} +// - NV#3035203 + +{$endregion} + +{$region Debug}{$ifdef DEBUG} + +{ $define EventDebug} // Регистрация всех cl.RetainEvent и cl.ReleaseEvent + +{$endif DEBUG}{$endregion Debug} + interface uses System; +uses System.Threading; +uses System.Runtime.InteropServices; +uses System.Collections.ObjectModel; uses OpenCL; -uses OpenCLABCBase; - -{$region Re:definition's} type + {$region Re-definition's} + ///Тип устройства, поддерживающего OpenCL DeviceType = OpenCL.DeviceType; ///Уровень кэша, используемый в Device.SplitByAffinityDomain DeviceAffinityDomain = OpenCL.DeviceAffinityDomain; + {$endregion Re-definition's} + + {$region Properties} + + {$region Buffer} + + BufferProperties = sealed partial class + + public constructor(ntv: cl_mem); + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetType: MemObjectType; + private function GetFlags: MemFlags; + private function GetSize: UIntPtr; + private function GetHostPtr: IntPtr; + private function GetMapCount: UInt32; + private function GetReferenceCount: UInt32; + private function GetUsesSvmPointer: Bool; + private function GetOffset: UIntPtr; + + public property &Type: MemObjectType read GetType; + public property Flags: MemFlags read GetFlags; + public property Size: UIntPtr read GetSize; + public property HostPtr: IntPtr read GetHostPtr; + public property MapCount: UInt32 read GetMapCount; + public property ReferenceCount: UInt32 read GetReferenceCount; + public property UsesSvmPointer: Bool read GetUsesSvmPointer; + public property Offset: UIntPtr read GetOffset; + + end; + + {$endregion Buffer} + + {$region Context} + + ContextProperties = sealed partial class + + public constructor(ntv: cl_context); + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetReferenceCount: UInt32; + private function GetNumDevices: UInt32; + private function GetProperties: array of ContextProperties; + + public property ReferenceCount: UInt32 read GetReferenceCount; + public property NumDevices: UInt32 read GetNumDevices; + public property Properties: array of ContextProperties read GetProperties; + + end; + + {$endregion Context} + + {$region Device} + + DeviceProperties = sealed partial class + + public constructor(ntv: cl_device_id); + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetType: DeviceType; + private function GetVendorId: UInt32; + private function GetMaxComputeUnits: UInt32; + private function GetMaxWorkItemDimensions: UInt32; + private function GetMaxWorkItemSizes: array of UIntPtr; + private function GetMaxWorkGroupSize: UIntPtr; + private function GetPreferredVectorWidthChar: UInt32; + private function GetPreferredVectorWidthShort: UInt32; + private function GetPreferredVectorWidthInt: UInt32; + private function GetPreferredVectorWidthLong: UInt32; + private function GetPreferredVectorWidthFloat: UInt32; + private function GetPreferredVectorWidthDouble: UInt32; + private function GetPreferredVectorWidthHalf: UInt32; + private function GetNativeVectorWidthChar: UInt32; + private function GetNativeVectorWidthShort: UInt32; + private function GetNativeVectorWidthInt: UInt32; + private function GetNativeVectorWidthLong: UInt32; + private function GetNativeVectorWidthFloat: UInt32; + private function GetNativeVectorWidthDouble: UInt32; + private function GetNativeVectorWidthHalf: UInt32; + private function GetMaxClockFrequency: UInt32; + private function GetAddressBits: UInt32; + private function GetMaxMemAllocSize: UInt64; + private function GetImageSupport: Bool; + private function GetMaxReadImageArgs: UInt32; + private function GetMaxWriteImageArgs: UInt32; + private function GetMaxReadWriteImageArgs: UInt32; + private function GetIlVersion: String; + private function GetImage2dMaxWidth: UIntPtr; + private function GetImage2dMaxHeight: UIntPtr; + private function GetImage3dMaxWidth: UIntPtr; + private function GetImage3dMaxHeight: UIntPtr; + private function GetImage3dMaxDepth: UIntPtr; + private function GetImageMaxBufferSize: UIntPtr; + private function GetImageMaxArraySize: UIntPtr; + private function GetMaxSamplers: UInt32; + private function GetImagePitchAlignment: UInt32; + private function GetImageBaseAddressAlignment: UInt32; + private function GetMaxPipeArgs: UInt32; + private function GetPipeMaxActiveReservations: UInt32; + private function GetPipeMaxPacketSize: UInt32; + private function GetMaxParameterSize: UIntPtr; + private function GetMemBaseAddrAlign: UInt32; + private function GetSingleFpConfig: DeviceFPConfig; + private function GetDoubleFpConfig: DeviceFPConfig; + private function GetGlobalMemCacheType: DeviceMemCacheType; + private function GetGlobalMemCachelineSize: UInt32; + private function GetGlobalMemCacheSize: UInt64; + private function GetGlobalMemSize: UInt64; + private function GetMaxConstantBufferSize: UInt64; + private function GetMaxConstantArgs: UInt32; + private function GetMaxGlobalVariableSize: UIntPtr; + private function GetGlobalVariablePreferredTotalSize: UIntPtr; + private function GetLocalMemType: DeviceLocalMemType; + private function GetLocalMemSize: UInt64; + private function GetErrorCorrectionSupport: Bool; + private function GetProfilingTimerResolution: UIntPtr; + private function GetEndianLittle: Bool; + private function GetAvailable: Bool; + private function GetCompilerAvailable: Bool; + private function GetLinkerAvailable: Bool; + private function GetExecutionCapabilities: DeviceExecCapabilities; + private function GetQueueOnHostProperties: CommandQueueProperties; + private function GetQueueOnDeviceProperties: CommandQueueProperties; + private function GetQueueOnDevicePreferredSize: UInt32; + private function GetQueueOnDeviceMaxSize: UInt32; + private function GetMaxOnDeviceQueues: UInt32; + private function GetMaxOnDeviceEvents: UInt32; + private function GetBuiltInKernels: String; + private function GetName: String; + private function GetVendor: String; + private function GetProfile: String; + private function GetVersion: String; + private function GetOpenclCVersion: String; + private function GetExtensions: String; + private function GetPrintfBufferSize: UIntPtr; + private function GetPreferredInteropUserSync: Bool; + private function GetPartitionMaxSubDevices: UInt32; + private function GetPartitionProperties: array of DevicePartitionProperty; + private function GetPartitionAffinityDomain: DeviceAffinityDomain; + private function GetPartitionType: array of DevicePartitionProperty; + private function GetReferenceCount: UInt32; + private function GetSvmCapabilities: DeviceSVMCapabilities; + private function GetPreferredPlatformAtomicAlignment: UInt32; + private function GetPreferredGlobalAtomicAlignment: UInt32; + private function GetPreferredLocalAtomicAlignment: UInt32; + private function GetMaxNumSubGroups: UInt32; + private function GetSubGroupIndependentForwardProgress: Bool; + + public property &Type: DeviceType read GetType; + public property VendorId: UInt32 read GetVendorId; + public property MaxComputeUnits: UInt32 read GetMaxComputeUnits; + public property MaxWorkItemDimensions: UInt32 read GetMaxWorkItemDimensions; + public property MaxWorkItemSizes: array of UIntPtr read GetMaxWorkItemSizes; + public property MaxWorkGroupSize: UIntPtr read GetMaxWorkGroupSize; + public property PreferredVectorWidthChar: UInt32 read GetPreferredVectorWidthChar; + public property PreferredVectorWidthShort: UInt32 read GetPreferredVectorWidthShort; + public property PreferredVectorWidthInt: UInt32 read GetPreferredVectorWidthInt; + public property PreferredVectorWidthLong: UInt32 read GetPreferredVectorWidthLong; + public property PreferredVectorWidthFloat: UInt32 read GetPreferredVectorWidthFloat; + public property PreferredVectorWidthDouble: UInt32 read GetPreferredVectorWidthDouble; + public property PreferredVectorWidthHalf: UInt32 read GetPreferredVectorWidthHalf; + public property NativeVectorWidthChar: UInt32 read GetNativeVectorWidthChar; + public property NativeVectorWidthShort: UInt32 read GetNativeVectorWidthShort; + public property NativeVectorWidthInt: UInt32 read GetNativeVectorWidthInt; + public property NativeVectorWidthLong: UInt32 read GetNativeVectorWidthLong; + public property NativeVectorWidthFloat: UInt32 read GetNativeVectorWidthFloat; + public property NativeVectorWidthDouble: UInt32 read GetNativeVectorWidthDouble; + public property NativeVectorWidthHalf: UInt32 read GetNativeVectorWidthHalf; + public property MaxClockFrequency: UInt32 read GetMaxClockFrequency; + public property AddressBits: UInt32 read GetAddressBits; + public property MaxMemAllocSize: UInt64 read GetMaxMemAllocSize; + public property ImageSupport: Bool read GetImageSupport; + public property MaxReadImageArgs: UInt32 read GetMaxReadImageArgs; + public property MaxWriteImageArgs: UInt32 read GetMaxWriteImageArgs; + public property MaxReadWriteImageArgs: UInt32 read GetMaxReadWriteImageArgs; + public property IlVersion: String read GetIlVersion; + public property Image2dMaxWidth: UIntPtr read GetImage2dMaxWidth; + public property Image2dMaxHeight: UIntPtr read GetImage2dMaxHeight; + public property Image3dMaxWidth: UIntPtr read GetImage3dMaxWidth; + public property Image3dMaxHeight: UIntPtr read GetImage3dMaxHeight; + public property Image3dMaxDepth: UIntPtr read GetImage3dMaxDepth; + public property ImageMaxBufferSize: UIntPtr read GetImageMaxBufferSize; + public property ImageMaxArraySize: UIntPtr read GetImageMaxArraySize; + public property MaxSamplers: UInt32 read GetMaxSamplers; + public property ImagePitchAlignment: UInt32 read GetImagePitchAlignment; + public property ImageBaseAddressAlignment: UInt32 read GetImageBaseAddressAlignment; + public property MaxPipeArgs: UInt32 read GetMaxPipeArgs; + public property PipeMaxActiveReservations: UInt32 read GetPipeMaxActiveReservations; + public property PipeMaxPacketSize: UInt32 read GetPipeMaxPacketSize; + public property MaxParameterSize: UIntPtr read GetMaxParameterSize; + public property MemBaseAddrAlign: UInt32 read GetMemBaseAddrAlign; + public property SingleFpConfig: DeviceFPConfig read GetSingleFpConfig; + public property DoubleFpConfig: DeviceFPConfig read GetDoubleFpConfig; + public property GlobalMemCacheType: DeviceMemCacheType read GetGlobalMemCacheType; + public property GlobalMemCachelineSize: UInt32 read GetGlobalMemCachelineSize; + public property GlobalMemCacheSize: UInt64 read GetGlobalMemCacheSize; + public property GlobalMemSize: UInt64 read GetGlobalMemSize; + public property MaxConstantBufferSize: UInt64 read GetMaxConstantBufferSize; + public property MaxConstantArgs: UInt32 read GetMaxConstantArgs; + public property MaxGlobalVariableSize: UIntPtr read GetMaxGlobalVariableSize; + public property GlobalVariablePreferredTotalSize: UIntPtr read GetGlobalVariablePreferredTotalSize; + public property LocalMemType: DeviceLocalMemType read GetLocalMemType; + public property LocalMemSize: UInt64 read GetLocalMemSize; + public property ErrorCorrectionSupport: Bool read GetErrorCorrectionSupport; + public property ProfilingTimerResolution: UIntPtr read GetProfilingTimerResolution; + public property EndianLittle: Bool read GetEndianLittle; + public property Available: Bool read GetAvailable; + public property CompilerAvailable: Bool read GetCompilerAvailable; + public property LinkerAvailable: Bool read GetLinkerAvailable; + public property ExecutionCapabilities: DeviceExecCapabilities read GetExecutionCapabilities; + public property QueueOnHostProperties: CommandQueueProperties read GetQueueOnHostProperties; + public property QueueOnDeviceProperties: CommandQueueProperties read GetQueueOnDeviceProperties; + public property QueueOnDevicePreferredSize: UInt32 read GetQueueOnDevicePreferredSize; + public property QueueOnDeviceMaxSize: UInt32 read GetQueueOnDeviceMaxSize; + public property MaxOnDeviceQueues: UInt32 read GetMaxOnDeviceQueues; + public property MaxOnDeviceEvents: UInt32 read GetMaxOnDeviceEvents; + public property BuiltInKernels: String read GetBuiltInKernels; + public property Name: String read GetName; + public property Vendor: String read GetVendor; + public property Profile: String read GetProfile; + public property Version: String read GetVersion; + public property OpenclCVersion: String read GetOpenclCVersion; + public property Extensions: String read GetExtensions; + public property PrintfBufferSize: UIntPtr read GetPrintfBufferSize; + public property PreferredInteropUserSync: Bool read GetPreferredInteropUserSync; + public property PartitionMaxSubDevices: UInt32 read GetPartitionMaxSubDevices; + public property PartitionProperties: array of DevicePartitionProperty read GetPartitionProperties; + public property PartitionAffinityDomain: DeviceAffinityDomain read GetPartitionAffinityDomain; + public property PartitionType: array of DevicePartitionProperty read GetPartitionType; + public property ReferenceCount: UInt32 read GetReferenceCount; + public property SvmCapabilities: DeviceSVMCapabilities read GetSvmCapabilities; + public property PreferredPlatformAtomicAlignment: UInt32 read GetPreferredPlatformAtomicAlignment; + public property PreferredGlobalAtomicAlignment: UInt32 read GetPreferredGlobalAtomicAlignment; + public property PreferredLocalAtomicAlignment: UInt32 read GetPreferredLocalAtomicAlignment; + public property MaxNumSubGroups: UInt32 read GetMaxNumSubGroups; + public property SubGroupIndependentForwardProgress: Bool read GetSubGroupIndependentForwardProgress; + + end; + + {$endregion Device} + + {$region Kernel} + + KernelProperties = sealed partial class + + public constructor(ntv: cl_kernel); + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetFunctionName: String; + private function GetNumArgs: UInt32; + private function GetReferenceCount: UInt32; + private function GetAttributes: String; + + public property FunctionName: String read GetFunctionName; + public property NumArgs: UInt32 read GetNumArgs; + public property ReferenceCount: UInt32 read GetReferenceCount; + public property Attributes: String read GetAttributes; + + end; + + {$endregion Kernel} + + {$region Platform} + + PlatformProperties = sealed partial class + + public constructor(ntv: cl_platform_id); + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetProfile: String; + private function GetVersion: String; + private function GetName: String; + private function GetVendor: String; + private function GetExtensions: String; + private function GetHostTimerResolution: UInt64; + + public property Profile: String read GetProfile; + public property Version: String read GetVersion; + public property Name: String read GetName; + public property Vendor: String read GetVendor; + public property Extensions: String read GetExtensions; + public property HostTimerResolution: UInt64 read GetHostTimerResolution; + + end; + + {$endregion Platform} + + {$region ProgramCode} + + ProgramCodeProperties = sealed partial class + + public constructor(ntv: cl_program); + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetReferenceCount: UInt32; + private function GetSource: String; + private function GetIl: array of Byte; + private function GetNumKernels: UIntPtr; + private function GetKernelNames: String; + private function GetScopeGlobalCtorsPresent: Bool; + private function GetScopeGlobalDtorsPresent: Bool; + + public property ReferenceCount: UInt32 read GetReferenceCount; + public property Source: String read GetSource; + public property Il: array of Byte read GetIl; + public property NumKernels: UIntPtr read GetNumKernels; + public property KernelNames: String read GetKernelNames; + public property ScopeGlobalCtorsPresent: Bool read GetScopeGlobalCtorsPresent; + public property ScopeGlobalDtorsPresent: Bool read GetScopeGlobalDtorsPresent; + + end; + + {$endregion ProgramCode} + + {$endregion Properties} + + {$region Wrappers} + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueue = abstract partial class end; + ///Представляет аргумент, передаваемый в вызов kernel-а + KernelArg = abstract partial class end; + + {$region Platform} + ///Представляет платформу OpenCL, объединяющую одно или несколько устройств - Platform = OpenCLABCBase.Platform; + Platform = partial class + private ntv: cl_platform_id; + + ///Создаёт обёртку для указанного неуправляемого объекта + public constructor(ntv: cl_platform_id) := self.ntv := ntv; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private static _all: IList; + private static function GetAll: IList; + begin + if _all=nil then + begin + var c: UInt32; + cl.GetPlatformIDs(0, IntPtr.Zero, c).RaiseIfError; + + var all_arr := new cl_platform_id[c]; + cl.GetPlatformIDs(c, all_arr[0], IntPtr.Zero).RaiseIfError; + + _all := new ReadOnlyCollection(all_arr.ConvertAll(pl->new Platform(pl))); + end; + Result := _all; + end; + ///Возвращает список всех доступных платформ OpenCL + ///Данный список создаётся 1 раз, при первом обращении + public static property All: IList read GetAll; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{self.GetType.Name}[{ntv.val}]'; + + end; + + {$endregion Platform} + + {$region Device} + ///Представляет устройство, поддерживающее OpenCL - Device = OpenCLABCBase.Device; + Device = partial class + private ntv: cl_device_id; + + ///Создаёт обёртку для указанного неуправляемого объекта + public constructor(ntv: cl_device_id) := self.ntv := ntv; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function GetBasePlatform: Platform; + begin + var pl: cl_platform_id; + cl.GetDeviceInfo(self.ntv, DeviceInfo.DEVICE_PLATFORM, new UIntPtr(sizeof(cl_platform_id)), pl, IntPtr.Zero).RaiseIfError; + Result := new Platform(pl); + end; + ///Возвращает платформу данного устройства + public property BasePlatform: Platform read GetBasePlatform; + + ///Собирает массив устройств указанного типа для указанной платформы + ///Возвращает nil, если ни одно устройство не найдено + public static function GetAllFor(pl: Platform; t: DeviceType): array of Device; + begin + + var c: UInt32; + var ec := cl.GetDeviceIDs(pl.ntv, t, 0, IntPtr.Zero, c); + if ec=ErrorCode.DEVICE_NOT_FOUND then exit; + ec.RaiseIfError; + + var all := new cl_device_id[c]; + cl.GetDeviceIDs(pl.ntv, t, c, all[0], IntPtr.Zero).RaiseIfError; + + Result := all.ConvertAll(dvc->new Device(dvc)); + end; + ///Собирает массив устройств GPU для указанной платформы + ///Возвращает nil, если ни одно устройство не найдено + public static function GetAllFor(pl: Platform) := GetAllFor(pl, DeviceType.DEVICE_TYPE_GPU); + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{self.GetType.Name}[{ntv.val}]'; + + end; + + {$endregion Device} + + {$region SubDevice} + ///Представляет виртуальное устройство, использующее часть ядер другого устройства ///Объекты данного типа обычно создаются методами "Device.Split*" - SubDevice = OpenCLABCBase.SubDevice; + SubDevice = partial class(Device) + private _parent: Device; + ///Возвращает родительское устройство, часть ядер которого использует данное устройство + public property Parent: Device read _parent; + + private constructor(dvc: cl_device_id; parent: Device); + begin + inherited Create(dvc); + self._parent := parent; + end; + private constructor := inherited; + + ///Освобождает неуправляемые ресурсы. Данный метод вызывается автоматически во время сборки мусора + ///Данный метод не должен вызываться из пользовательского кода. Он виден только на случай если вы хотите переопределить его в своём классе-наследнике + protected procedure Finalize; override := + cl.ReleaseDevice(ntv).RaiseIfError; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{inherited ToString} of {Parent}'; + + end; + + {$endregion SubDevice} + + {$region Context} + ///Представляет контекст для хранения данных и выполнения команд на GPU - Context = OpenCLABCBase.Context; + Context = partial class + private ntv: cl_context; + + private dvcs: IList; + ///Возвращает список устройств, используемых данным контекстом + public property AllDevices: IList read dvcs; + + private main_dvc: Device; + ///Возвращает главное устройство контекста, на котором выделяется память под буферы и внутренние объекты очередей + public property MainDevice: Device read main_dvc; + + private function GetAllNtvDevices: array of cl_device_id; + begin + Result := new cl_device_id[dvcs.Count]; + for var i := 0 to Result.Length-1 do + Result[i] := dvcs[i].ntv; + end; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{self.GetType.Name}[{ntv.val}] on devices: [{AllDevices.JoinToString('', '')}]; Main device: {MainDevice}'; + + {$region Default} + + private static default_need_init := true; + private static default_init_lock := new object; + private static _default: Context; + + private static function GetDefault: Context; + begin + + // Теоретически default_init_lock может оказаться nil уже после проверки default_need_init, поэтому "??" + if default_need_init then lock default_init_lock??new object do if default_need_init then + begin + default_need_init := false; + default_init_lock := nil; + _default := MakeNewDefaultContext; + end; + + Result := _default; + end; + private static procedure SetDefault(new_default: Context); + begin + default_need_init := false; + default_init_lock := nil; + _default := new_default; + end; + ///Возвращает или задаёт главный контекст, используемый там, где контекст не указывается явно (как неявные очереди) + ///При первом обращении к данному свойству OpenCLABC пытается создать новый контекст + ///При создании главного контекста приоритет отдаётся полноценным GPU, но если таких нет - берётся любое устройство, поддерживающее OpenCL + /// + ///Если устройств поддерживающих OpenCL нет, то Context.Default изначально будет nil + ///Но это свидетельствует скорее об отсутствии драйверов, чем отстутсвии устройств + public static property &Default: Context read GetDefault write SetDefault; + + /// + protected static function MakeNewDefaultContext: Context; + begin + Result := nil; + + var pls := Platform.All; + if pls=nil then exit; + + foreach var pl in pls do + begin + var dvcs := Device.GetAllFor(pl); + if dvcs=nil then continue; + Result := new Context(dvcs); + exit; + end; + + foreach var pl in pls do + begin + var dvcs := Device.GetAllFor(pl, DeviceType.DEVICE_TYPE_ALL); + if dvcs=nil then continue; + Result := new Context(dvcs); + exit; + end; + + end; + + {$endregion Default} + + {$region constructor's} + + /// + protected static procedure CheckMainDevice(main_dvc: Device; dvc_lst: IList) := + if not dvc_lst.Contains(main_dvc) then raise new ArgumentException($'main_dvc должен быть в списке устройств контекста'); + + ///Создаёт контекст с указанными AllDevices и MainDevice + public constructor(dvcs: IList; main_dvc: Device); + begin + CheckMainDevice(main_dvc, dvcs); + + var ntv_dvcs := new cl_device_id[dvcs.Count]; + for var i := 0 to ntv_dvcs.Length-1 do + ntv_dvcs[i] := dvcs[i].ntv; + + var ec: ErrorCode; + //ToDo позволить использовать CL_CONTEXT_INTEROP_USER_SYNC в свойствах + self.ntv := cl.CreateContext(nil, ntv_dvcs.Count, ntv_dvcs, nil, IntPtr.Zero, ec); + ec.RaiseIfError; + + self.dvcs := if dvcs.IsReadOnly then dvcs else new ReadOnlyCollection(dvcs.ToArray); + self.main_dvc := main_dvc; + end; + ///Создаёт контекст с указанными AllDevices + ///В качестве MainDevice берётся первое устройство из массива + public constructor(params dvcs: array of Device) := Create(dvcs, dvcs[0]); + + /// + protected static function GetContextDevices(ntv: cl_context): array of Device; + begin + + var sz: UIntPtr; + cl.GetContextInfo(ntv, ContextInfo.CONTEXT_DEVICES, UIntPtr.Zero, nil, sz).RaiseIfError; + + var res := new cl_device_id[uint64(sz) div Marshal.SizeOf&]; + cl.GetContextInfo(ntv, ContextInfo.CONTEXT_DEVICES, sz, res[0], IntPtr.Zero).RaiseIfError; + + Result := res.ConvertAll(dvc->new Device(dvc)); + end; + private procedure InitFromNtv(ntv: cl_context; dvcs: IList; main_dvc: Device); + begin + CheckMainDevice(main_dvc, dvcs); + cl.RetainContext(ntv).RaiseIfError; + self.ntv := ntv; + // Копирование должно происходить в вызывающих методах + self.dvcs := if dvcs.IsReadOnly then dvcs else new ReadOnlyCollection(dvcs); + self.main_dvc := main_dvc; + end; + ///Создаёт обёртку для указанного неуправляемого объекта + ///При успешном создании обёртки вызывается cl.Retain + ///А во время вызова .Dispose - cl.Release + public constructor(ntv: cl_context; main_dvc: Device) := + InitFromNtv(ntv, GetContextDevices(ntv), main_dvc); + + ///Создаёт обёртку для указанного неуправляемого объекта + ///При успешном создании обёртки вызывается cl.Retain + ///А во время вызова .Dispose - cl.Release + public constructor(ntv: cl_context); + begin + var dvcs := GetContextDevices(ntv); + InitFromNtv(ntv, dvcs, dvcs[0]); + end; + + private constructor(c: Context; main_dvc: Device) := + InitFromNtv(c.ntv, c.dvcs, main_dvc); + ///Создаёт совместимый контекст, равный данному с одним отличием - MainDevice заменён на dvc + public function MakeSibling(new_main_dvc: Device) := new Context(self, new_main_dvc); + + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + ///Позволяет OpenCL удалить неуправляемый объект + ///Данный метод вызывается автоматически во время сборки мусора, если объект ещё не удалён + public procedure Dispose := + if ntv<>cl_context.Zero then lock self do + begin + if ntv=cl_context.Zero then exit; + cl.ReleaseContext(ntv).RaiseIfError; + ntv := cl_context.Zero; + end; + ///Освобождает неуправляемые ресурсы. Данный метод вызывается автоматически во время сборки мусора + ///Данный метод не должен вызываться из пользовательского кода. Он виден только на случай если вы хотите переопределить его в своём классе-наследнике + protected procedure Finalize; override := Dispose; + + {$endregion constructor's} + + end; + + {$endregion Context} + + {$region Buffer} ///Представляет область памяти устройства OpenCL - Buffer = OpenCLABCBase.Buffer; + Buffer = partial class + private ntv: cl_mem; + + private sz: UIntPtr; + ///Возвращает размер буфера в байтах + public property Size: UIntPtr read sz; + ///Возвращает размер буфера в байтах + public property Size32: UInt32 read sz.ToUInt32; + ///Возвращает размер буфера в байтах + public property Size64: UInt64 read sz.ToUInt64; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{self.GetType.Name}[{ntv.val}] of size {Size}'; + + {$region constructor's} + + ///Создаёт буфер указанного в байтах размера + ///Память на GPU не выделяется до вызова метода .Init + public constructor(size: UIntPtr) := self.sz := size; + ///Создаёт буфер указанного в байтах размера + ///Память на GPU не выделяется до вызова метода .Init + public constructor(size: integer) := Create(new UIntPtr(size)); + ///Создаёт буфер указанного в байтах размера + ///Память на GPU не выделяется до вызова метода .Init + public constructor(size: int64) := Create(new UIntPtr(size)); + + ///Создаёт буфер указанного в байтах размера + ///Память на GPU выделяется сразу, на явно указанном контексте + public constructor(size: UIntPtr; c: Context); + begin + Create(size); + Init(c); + end; + ///Создаёт буфер указанного в байтах размера + ///Память на GPU выделяется сразу, на явно указанном контексте + public constructor(size: integer; c: Context) := Create(new UIntPtr(size), c); + ///Создаёт буфер указанного в байтах размера + ///Память на GPU выделяется сразу, на явно указанном контексте + public constructor(size: int64; c: Context) := Create(new UIntPtr(size), c); + + ///Создаёт обёртку для указанного неуправляемого объекта + ///При успешном создании обёртки вызывается cl.Retain + ///А во время вызова .Dispose - cl.Release + public constructor(ntv: cl_mem); + begin + cl.RetainMemObject(ntv).RaiseIfError; + self.ntv := ntv; + + cl.GetMemObjectInfo(ntv, MemInfo.MEM_SIZE, new UIntPtr(Marshal.SizeOf&), self.sz, IntPtr.Zero).RaiseIfError; + GC.AddMemoryPressure(Size64); + + end; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + ///Выделяет память для данного буфера в указанном контексте + ///Если память уже выделена, то она освобождается и выделяется заново + public procedure Init(c: Context); virtual := + lock self do + begin + + var ec: ErrorCode; + var new_ntv := cl.CreateBuffer(c.ntv, MemFlags.MEM_READ_WRITE, sz, IntPtr.Zero, ec); + ec.RaiseIfError; + + if self.ntv=cl_mem.Zero then + GC.AddMemoryPressure(Size64) else + cl.ReleaseMemObject(self.ntv).RaiseIfError; + + self.ntv := new_ntv; + end; + + ///Выделяет память для данного буфера в указанном контексте + ///Если память уже выделена, то данный методы ничего не делает + public procedure InitIfNeed(c: Context); virtual := + if self.ntv=cl_mem.Zero then lock self do + begin + if self.ntv<>cl_mem.Zero then exit; // Во время ожидания lock могли инициализировать + + var ec: ErrorCode; + var new_ntv := cl.CreateBuffer(c.ntv, MemFlags.MEM_READ_WRITE, sz, IntPtr.Zero, ec); + ec.RaiseIfError; + + GC.AddMemoryPressure(Size64); + self.ntv := new_ntv; + end; + + {$endregion constructor's} + + {$region 1#Write&Read} + + ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM + public function WriteData(ptr: CommandQueue): Buffer; + + ///Копирует всё содержимое буфера в RAM, по указанному адресу + public function ReadData(ptr: CommandQueue): Buffer; + + ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function WriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer; + + ///Копирует часть содержимого буфера в RAM, по указанному адресу + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function ReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer; + + ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM + public function WriteData(ptr: pointer): Buffer; + + ///Копирует всё содержимое буфера в RAM, по указанному адресу + public function ReadData(ptr: pointer): Buffer; + + ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function WriteData(ptr: pointer; buff_offset, len: CommandQueue): Buffer; + + ///Копирует часть содержимого буфера в RAM, по указанному адресу + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function ReadData(ptr: pointer; buff_offset, len: CommandQueue): Buffer; + + ///Записывает указанное значение размерного типа в начало буфера + public function WriteValue(val: TRecord): Buffer; where TRecord: record; + + ///Записывает указанное значение размерного типа в буфер + ///buff_offset указывает отступ от начала буфера, в байтах + public function WriteValue(val: TRecord; buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Записывает указанное значение размерного типа в начало буфера + public function WriteValue(val: CommandQueue): Buffer; where TRecord: record; + + ///Записывает указанное значение размерного типа в буфер + ///buff_offset указывает отступ от начала буфера, в байтах + public function WriteValue(val: CommandQueue; buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Записывает весь массив в начало буфера + public function WriteArray1(a: CommandQueue): Buffer; where TRecord: record; + + ///Записывает весь массив в начало буфера + public function WriteArray2(a: CommandQueue): Buffer; where TRecord: record; + + ///Записывает весь массив в начало буфера + public function WriteArray3(a: CommandQueue): Buffer; where TRecord: record; + + ///Читает из буфера достаточно байт чтоб заполнить весь массив + public function ReadArray1(a: CommandQueue): Buffer; where TRecord: record; + + ///Читает из буфера достаточно байт чтоб заполнить весь массив + public function ReadArray2(a: CommandQueue): Buffer; where TRecord: record; + + ///Читает из буфера достаточно байт чтоб заполнить весь массив + public function ReadArray3(a: CommandQueue): Buffer; where TRecord: record; + + ///Записывает указанный участок массива в буфер + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + public function WriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Записывает указанный участок массива в буфер + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function WriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Записывает указанный участок массива в буфер + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function WriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Читает в буфер указанный участок массива + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + public function ReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Читает в буфер указанный участок массива + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function ReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer; where TRecord: record; + + ///Читает в буфер указанный участок массива + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function ReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer; where TRecord: record; + + {$endregion 1#Write&Read} + + {$region 2#Fill} + + ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями весь буфер + public function FillData(ptr: CommandQueue; pattern_len: CommandQueue): Buffer; + + ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями часть буфера + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function FillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): Buffer; + + ///Заполняет весь буфер копиями указанного значения размерного типа + public function FillValue(val: TRecord): Buffer; where TRecord: record; + + ///Заполняет часть буфера копиями указанного значения размерного типа + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function FillValue(val: TRecord; buff_offset, len: CommandQueue): Buffer; where TRecord: record; + + ///Заполняет весь буфер копиями указанного значения размерного типа + public function FillValue(val: CommandQueue): Buffer; where TRecord: record; + + ///Заполняет часть буфера копиями указанного значения размерного типа + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function FillValue(val: CommandQueue; buff_offset, len: CommandQueue): Buffer; where TRecord: record; + + {$endregion 2#Fill} + + {$region 3#Copy} + + ///Копирует данные из текущего буфера в b + ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера + public function CopyTo(b: CommandQueue): Buffer; + + ///Копирует данные из b в текущий буфер + ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера + public function CopyForm(b: CommandQueue): Buffer; + + ///Копирует данные из текущего буфера в b + ///from_pos указывает отступ в байтах от начала буфера, из которого копируют + ///to_pos указывает отступ в байтах от начала буфера, в который копируют + ///len указывает кол-во копируемых байт + public function CopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer; + + ///Копирует данные из b в текущий буфер + ///from_pos указывает отступ в байтах от начала буфера, из которого копируют + ///to_pos указывает отступ в байтах от начала буфера, в который копируют + ///len указывает кол-во копируемых байт + public function CopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer; + + {$endregion 3#Copy} + + {$region Get} + + ///Выделяет область неуправляемой памяти и копирует в неё всё содержимое данного буфера + public function GetData: IntPtr; + + ///Выделяет область неуправляемой памяти и копирует в неё часть содержимого данного буфера + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function GetData(buff_offset, len: CommandQueue): IntPtr; + + ///Читает значение указанного размерного типа из начала буфера + public function GetValue: TRecord; where TRecord: record; + + ///Читает значение указанного размерного типа из буфера + ///buff_offset указывает отступ от начала буфера, в байтах + public function GetValue(buff_offset: CommandQueue): TRecord; where TRecord: record; + + ///Создаёт массив максимального размера (на сколько хватит байт буфера) и копирует в него содержимое буфера + public function GetArray1: array of TRecord; where TRecord: record; + + ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера + public function GetArray1(len: CommandQueue): array of TRecord; where TRecord: record; + + ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера + public function GetArray2(len1,len2: CommandQueue): array[,] of TRecord; where TRecord: record; + + ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера + public function GetArray3(len1,len2,len3: CommandQueue): array[,,] of TRecord; where TRecord: record; + + {$endregion Get} + + end; + + {$endregion Buffer} + + {$region SubBuffer} + ///Представляет область памяти внутри другого буфера - SubBuffer = OpenCLABCBase.SubBuffer; - ///Представляет подпрограмму, выполняемую на GPU - Kernel = OpenCLABCBase.Kernel; + SubBuffer = partial class(Buffer) + + private _parent: Buffer; + ///Возвращает родительский буфер + public property Parent: Buffer read _parent; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{inherited ToString} inside {Parent}'; + + {$region constructor's} + + private constructor(parent: Buffer; reg: cl_buffer_region); + begin + inherited Create(reg.size); + + var parent_ntv := parent.ntv; + if parent_ntv=cl_mem.Zero then raise new InvalidOperationException($'Ожидался инициализированный буфер. Используйте .Init, или конструктор принимающий контекст'); + + var ec: ErrorCode; + self.ntv := cl.CreateSubBuffer(parent_ntv, MemFlags.MEM_READ_WRITE, BufferCreateType.BUFFER_CREATE_TYPE_REGION, reg, ec); + ec.RaiseIfError; + + self._parent := parent; + end; + ///Создаёт буфер из области памяти родительского буфера parent + ///origin указывает отступ в байтах от начала parent + ///size указывает размер нового буфера + ///Память parent должна быть выделена перед вызовом данного конструктора, + ///потому что новый буфер будет использовать память parent, вместо создания новой области памяти + public constructor(parent: Buffer; origin, size: UIntPtr) := Create(parent, new cl_buffer_region(origin, size)); + + ///Создаёт буфер из области памяти родительского буфера parent + ///origin указывает отступ в байтах от начала parent + ///size указывает размер нового буфера + ///Память parent должна быть выделена перед вызовом данного конструктора, + ///потому что новый буфер будет использовать память parent, вместо создания новой области памяти + public constructor(parent: Buffer; origin, size: UInt32) := Create(parent, new UIntPtr(origin), new UIntPtr(size)); + ///Создаёт буфер из области памяти родительского буфера parent + ///origin указывает отступ в байтах от начала parent + ///size указывает размер нового буфера + ///Память parent должна быть выделена перед вызовом данного конструктора, + ///потому что новый буфер будет использовать память parent, вместо создания новой области памяти + public constructor(parent: Buffer; origin, size: UInt64) := Create(parent, new UIntPtr(origin), new UIntPtr(size)); + + private procedure InitIgnoreOrErr := + if self.ntv=cl_mem.Zero then raise new NotSupportedException($'SubBuffer нельзя инициализировать, потому что он использует память другого буфера'); + ///-- + public procedure Init(c: Context); override := InitIgnoreOrErr; + ///-- + public procedure InitIfNeed(c: Context); override := InitIgnoreOrErr; + + {$endregion constructor's} + + end; + + {$endregion SubBuffer} + + {$region ProgramCode} + ///Представляет контейнер с откомпилированным кодом для GPU, содержащим подпрограммы-kernel'ы - ProgramCode = OpenCLABCBase.ProgramCode; + ProgramCode = partial class + private ntv: cl_program; + + private _c: Context; + ///Возвращает контекст, на котором компилировали данный код для GPU + public property BaseContext: Context read _c; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{self.GetType.Name}[{ntv.val}]'; + + {$region constructor's} + + private procedure Build; + begin + var ec := cl.BuildProgram(self.ntv, _c.dvcs.Count,_c.GetAllNtvDevices, nil, nil,IntPtr.Zero); + if not ec.IS_ERROR then exit; + + if ec=ErrorCode.BUILD_PROGRAM_FAILURE then + begin + var sb := new StringBuilder($'Ошибка компиляции OpenCL программы:'); + + foreach var dvc in _c.AllDevices do + begin + sb += #10#10; + sb += dvc.ToString; + sb += ':'#10; + + var sz: UIntPtr; + cl.GetProgramBuildInfo(self.ntv, dvc.ntv, ProgramBuildInfo.PROGRAM_BUILD_LOG, UIntPtr.Zero,IntPtr.Zero,sz).RaiseIfError; + + var str_ptr := Marshal.AllocHGlobal(IntPtr(pointer(sz))); + try + cl.GetProgramBuildInfo(self.ntv, dvc.ntv, ProgramBuildInfo.PROGRAM_BUILD_LOG, sz,str_ptr,IntPtr.Zero).RaiseIfError; + sb += Marshal.PtrToStringAnsi(str_ptr); + finally + Marshal.FreeHGlobal(str_ptr); + end; + + end; + + raise new OpenCLException(ec, sb.ToString); + end else + ec.RaiseIfError; + + end; + + ///Компилирует указанные тексты программ на указанном контексте + ///Внимание! Именно тексты, Не имена файлов + public constructor(c: Context; params files_texts: array of string); + begin + + var ec: ErrorCode; + self.ntv := cl.CreateProgramWithSource(c.ntv, files_texts.Length, files_texts, nil, ec); + ec.RaiseIfError; + + self._c := c; + self.Build; + + end; + + private constructor(ntv: cl_program; c: Context); + begin + cl.RetainProgram(ntv).RaiseIfError; + self._c := c; + self.ntv := ntv; + end; + + private static function GetProgContext(ntv: cl_program): Context; + begin + var c: cl_context; + cl.GetProgramInfo(ntv, ProgramInfo.PROGRAM_CONTEXT, new UIntPtr(Marshal.SizeOf&), c, IntPtr.Zero).RaiseIfError; + Result := new Context(c); + end; + ///Создаёт обёртку для указанного неуправляемого объекта + ///При успешном создании обёртки вызывается cl.Retain + ///А во время вызова .Dispose - cl.Release + public constructor(ntv: cl_program) := + Create(ntv, GetProgContext(ntv)); + + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + ///Позволяет OpenCL удалить неуправляемый объект + ///Данный метод вызывается автоматически во время сборки мусора, если объект ещё не удалён + public procedure Dispose := + if ntv<>cl_program.Zero then lock self do + begin + if ntv=cl_program.Zero then exit; + cl.ReleaseProgram(ntv).RaiseIfError; + ntv := cl_program.Zero; + end; + ///Освобождает неуправляемые ресурсы. Данный метод вызывается автоматически во время сборки мусора + ///Данный метод не должен вызываться из пользовательского кода. Он виден только на случай если вы хотите переопределить его в своём классе-наследнике + protected procedure Finalize; override := Dispose; + + {$endregion constructor's} + + {$region Serialize} + + ///Сохраняет прекомпилированную программу как набор байт + public function Serialize: array of array of byte; + begin + var sz: UIntPtr; + + cl.GetProgramInfo(ntv, ProgramInfo.PROGRAM_BINARY_SIZES, UIntPtr.Zero, nil, sz).RaiseIfError; + var szs := new UIntPtr[sz.ToUInt64 div sizeof(UIntPtr)]; + cl.GetProgramInfo(ntv, ProgramInfo.PROGRAM_BINARY_SIZES, sz, szs[0], IntPtr.Zero).RaiseIfError; + + var res := new IntPtr[szs.Length]; + SetLength(Result, szs.Length); + + for var i := 0 to szs.Length-1 do res[i] := Marshal.AllocHGlobal(IntPtr(pointer(szs[i]))); + try + cl.GetProgramInfo(ntv, ProgramInfo.PROGRAM_BINARIES, sz, res[0], IntPtr.Zero).RaiseIfError; + for var i := 0 to szs.Length-1 do + begin + var a := new byte[szs[i].ToUInt64]; + Marshal.Copy(res[i], a, 0, a.Length); + Result[i] := a; + end; + finally + for var i := 0 to szs.Length-1 do Marshal.FreeHGlobal(res[i]); + end; + + end; + + ///Сохраняет прекомпилированную программу в поток + public procedure SerializeTo(bw: System.IO.BinaryWriter); + begin + var bin := Serialize; + + bw.Write(bin.Length); + foreach var a in bin do + begin + bw.Write(a.Length); + bw.Write(a); + end; + + end; + ///Сохраняет прекомпилированную программу в поток + public procedure SerializeTo(str: System.IO.Stream) := + SerializeTo(new System.IO.BinaryWriter(str)); + + {$endregion Serialize} + + {$region Deserialize} + + ///Загружает прекомпилированную программу из набора байт + public static function Deserialize(c: Context; bin: array of array of byte): ProgramCode; + begin + var ntv: cl_program; + + var dvcs := c.GetAllNtvDevices; + + var ec: ErrorCode; + ntv := cl.CreateProgramWithBinary( + c.ntv, dvcs.Length, dvcs[0], + bin.ConvertAll(a->new UIntPtr(a.Length))[0], bin, + IntPtr.Zero, ec + ); + ec.RaiseIfError; + + Result := new ProgramCode(ntv, c); + Result.Build; + + end; + + ///Загружает прекомпилированную программу из потока + public static function DeserializeFrom(c: Context; br: System.IO.BinaryReader): ProgramCode; + begin + var bin: array of array of byte; + + SetLength(bin, br.ReadInt32); + for var i := 0 to bin.Length-1 do + begin + var len := br.ReadInt32; + bin[i] := br.ReadBytes(len); + if bin[i].Length<>len then raise new System.IO.EndOfStreamException; + end; + + Result := Deserialize(c, bin); + end; + ///Загружает прекомпилированную программу из потока + public static function DeserializeFrom(c: Context; str: System.IO.Stream) := + DeserializeFrom(c, new System.IO.BinaryReader(str)); + + {$endregion Deserialize} + + end; - ///Представляет задачу выполнения очереди, создаваемую методом Context.BeginInvoke - CLTaskBase = OpenCLABCBase.CLTaskBase; - ///Представляет задачу выполнения очереди, создаваемую методом Context.BeginInvoke - CLTask = OpenCLABCBase.CLTask; + {$endregion ProgramCode} + + {$region Kernel} + + ///Представляет подпрограмму, выполняемую на GPU + Kernel = partial class + private ntv: cl_kernel; + + private code: ProgramCode; + ///Возвращает контейнер кода, содержащий данную подпрограмму + public property CodeContainer: ProgramCode read code; + + private k_name: string; + ///Возвращает имя данной подпрограммы + public property Name: string read k_name; + + ///Возвращает строку с основными данными о данном объекте + public function ToString: string; override := + $'{self.GetType.Name}[{Name}:{ntv.val}] from {code}'; + + {$region constructor's} + + ///Создаёт независимый клон неуправляемого объекта + ///Внимание: Клон НЕ будет удалён автоматически при сборке мусора. Для него надо вручную вызывать cl.ReleaseKernel + protected function MakeNewNtv: cl_kernel; + begin + var ec: ErrorCode; + Result := cl.CreateKernel(code.ntv, k_name, ec); + ec.RaiseIfError; + end; + private constructor(code: ProgramCode; name: string); + begin + self.code := code; + self.k_name := name; + self.ntv := self.MakeNewNtv; + end; + + ///Создаёт обёртку для указанного неуправляемого объекта + ///При успешном создании обёртки вызывается cl.Retain + ///А во время вызова .Dispose - cl.Release + public constructor(ntv: cl_kernel; retain: boolean := true); + begin + + var code_ntv: cl_program; + cl.GetKernelInfo(ntv, KernelInfo.KERNEL_PROGRAM, new UIntPtr(cl_program.Size), code_ntv, IntPtr.Zero).RaiseIfError; + self.code := new ProgramCode(code_ntv); + + var sz: UIntPtr; + cl.GetKernelInfo(ntv, KernelInfo.KERNEL_FUNCTION_NAME, UIntPtr.Zero, nil, sz).RaiseIfError; + var str_ptr := Marshal.AllocHGlobal(IntPtr(pointer(sz))); + try + cl.GetKernelInfo(ntv, KernelInfo.KERNEL_FUNCTION_NAME, sz, str_ptr, IntPtr.Zero).RaiseIfError; + self.k_name := Marshal.PtrToStringAnsi(str_ptr); + finally + Marshal.FreeHGlobal(str_ptr); + end; + + if retain then cl.RetainKernel(ntv).RaiseIfError; + self.ntv := ntv; + end; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + ///Позволяет OpenCL удалить неуправляемый объект + ///Данный метод вызывается автоматически во время сборки мусора, если объект ещё не удалён + public procedure Dispose := + if ntv<>cl_kernel.Zero then lock self do + begin + if ntv=cl_kernel.Zero then exit; + cl.ReleaseKernel(ntv).RaiseIfError; + ntv := cl_kernel.Zero; + end; + ///Освобождает неуправляемые ресурсы. Данный метод вызывается автоматически во время сборки мусора + ///Данный метод не должен вызываться из пользовательского кода. Он виден только на случай если вы хотите переопределить его в своём классе-наследнике + protected procedure Finalize; override := Dispose; + + {$endregion constructor's} + + {$region UseExclusiveNative} + + private exclusive_ntv_lock := new object; + ///Гарантирует что неуправляемый объект будет использоваться только в 1 потоке одновременно + ///Если неуправляемый объект данного kernel-а используется другим потоком - в процедурную переменную передаётся его независимый клон + ///Внимание: Клон неуправляемого объекта будет удалён сразу после выхода из вашей процедурной переменной, если не вызвать cl.RetainKernel + protected procedure UseExclusiveNative(p: cl_kernel->()); + begin + var owned := Monitor.TryEnter(exclusive_ntv_lock); + try + if owned then + p(self.ntv) else + begin + var k := MakeNewNtv; + try + p(k); + finally + cl.ReleaseKernel(k).RaiseIfError; + end; + end; + finally + if owned then Monitor.Exit(exclusive_ntv_lock); + end; + end; + ///Гарантирует что неуправляемый объект будет использоваться только в 1 потоке одновременно + ///Если неуправляемый объект данного kernel-а используется другим потоком - в процедурную переменную передаётся его независимый клон + ///Внимание: Клон неуправляемого объекта будет удалён сразу после выхода из вашей процедурной переменной, если не вызвать cl.RetainKernel + protected function UseExclusiveNative(f: cl_kernel->T): T; + begin + var owned := Monitor.TryEnter(exclusive_ntv_lock); + try + if owned then + Result := f(self.ntv) else + begin + var k := MakeNewNtv; + try + Result := f(k); + finally + cl.ReleaseKernel(k).RaiseIfError; + end; + end; + finally + if owned then Monitor.Exit(exclusive_ntv_lock); + end; + end; + + {$endregion UseExclusiveNative} + + {$region 1#Exec} + + ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы + public function Exec1(sz1: CommandQueue; params args: array of KernelArg): Kernel; + + ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы + public function Exec2(sz1,sz2: CommandQueue; params args: array of KernelArg): Kernel; + + ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы + public function Exec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): Kernel; + + ///Выполняет kernel с расширенным набором параметров + ///Данная перегрузка используется в первую очередь для тонких оптимизаций + ///Если она вам понадобилась по другой причина - пожалуйста, напишите в issue + public function Exec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): Kernel; + + {$endregion 1#Exec} + + end; + + ///Представляет контейнер с откомпилированным кодом для GPU, содержащим подпрограммы-kernel'ы + ProgramCode = partial class + + ///Находит в коде kernel с указанным именем + ///Регистр имени важен! + public property KernelByName[kname: string]: Kernel read new Kernel(self, kname); default; + + ///Создаёт массив из всех kernel-ов данного кода + public function GetAllKernels: array of Kernel; + begin + + var c: UInt32; + cl.CreateKernelsInProgram(ntv, 0, IntPtr.Zero, c).RaiseIfError; + + var res := new cl_kernel[c]; + cl.CreateKernelsInProgram(ntv, c, res[0], IntPtr.Zero).RaiseIfError; + + Result := res.ConvertAll(k->new Kernel(k, false)); + end; + + end; + + {$endregion Kernel} + + {$region Common} + + ///Представляет платформу OpenCL, объединяющую одно или несколько устройств + Platform = partial class + + ///Возвращает имя (дескриптор) неуправляемого объекта + public property Native: cl_platform_id read ntv; + + private prop: PlatformProperties; + private function GetProperties: PlatformProperties; + begin + if prop=nil then prop := new PlatformProperties(ntv); + Result := prop; + end; + ///Возвращает контейнер свойств неуправляемого объекта + public property Properties: PlatformProperties read GetProperties; + + public static function operator=(wr1, wr2: Platform): boolean := wr1.ntv = wr2.ntv; + public static function operator<>(wr1, wr2: Platform): boolean := wr1.ntv <> wr2.ntv; + + ///-- + public function Equals(obj: object): boolean; override := + (obj is Platform(var wr)) and (self = wr); + + end; + + ///Представляет устройство, поддерживающее OpenCL + Device = partial class + + ///Возвращает имя (дескриптор) неуправляемого объекта + public property Native: cl_device_id read ntv; + + private prop: DeviceProperties; + private function GetProperties: DeviceProperties; + begin + if prop=nil then prop := new DeviceProperties(ntv); + Result := prop; + end; + ///Возвращает контейнер свойств неуправляемого объекта + public property Properties: DeviceProperties read GetProperties; + + public static function operator=(wr1, wr2: Device): boolean := wr1.ntv = wr2.ntv; + public static function operator<>(wr1, wr2: Device): boolean := wr1.ntv <> wr2.ntv; + + ///-- + public function Equals(obj: object): boolean; override := + (obj is Device(var wr)) and (self = wr); + + end; + + ///Представляет контекст для хранения данных и выполнения команд на GPU + Context = partial class + + ///Возвращает имя (дескриптор) неуправляемого объекта + public property Native: cl_context read ntv; + + private prop: ContextProperties; + private function GetProperties: ContextProperties; + begin + if prop=nil then prop := new ContextProperties(ntv); + Result := prop; + end; + ///Возвращает контейнер свойств неуправляемого объекта + public property Properties: ContextProperties read GetProperties; + + public static function operator=(wr1, wr2: Context): boolean := wr1.ntv = wr2.ntv; + public static function operator<>(wr1, wr2: Context): boolean := wr1.ntv <> wr2.ntv; + + ///-- + public function Equals(obj: object): boolean; override := + (obj is Context(var wr)) and (self = wr); + + end; + + ///Представляет область памяти устройства OpenCL + Buffer = partial class + + ///Возвращает имя (дескриптор) неуправляемого объекта + public property Native: cl_mem read ntv; + + private prop: BufferProperties; + private function GetProperties: BufferProperties; + begin + if prop=nil then prop := new BufferProperties(ntv); + Result := prop; + end; + ///Возвращает контейнер свойств неуправляемого объекта + public property Properties: BufferProperties read GetProperties; + + public static function operator=(wr1, wr2: Buffer): boolean := wr1.ntv = wr2.ntv; + public static function operator<>(wr1, wr2: Buffer): boolean := wr1.ntv <> wr2.ntv; + + ///-- + public function Equals(obj: object): boolean; override := + (obj is Buffer(var wr)) and (self = wr); + + end; + + ///Представляет подпрограмму, выполняемую на GPU + Kernel = partial class + + ///Возвращает имя (дескриптор) неуправляемого объекта + public property Native: cl_kernel read ntv; + + private prop: KernelProperties; + private function GetProperties: KernelProperties; + begin + if prop=nil then prop := new KernelProperties(ntv); + Result := prop; + end; + ///Возвращает контейнер свойств неуправляемого объекта + public property Properties: KernelProperties read GetProperties; + + public static function operator=(wr1, wr2: Kernel): boolean := wr1.ntv = wr2.ntv; + public static function operator<>(wr1, wr2: Kernel): boolean := wr1.ntv <> wr2.ntv; + + ///-- + public function Equals(obj: object): boolean; override := + (obj is Kernel(var wr)) and (self = wr); + + end; + + ///Представляет контейнер с откомпилированным кодом для GPU, содержащим подпрограммы-kernel'ы + ProgramCode = partial class + + ///Возвращает имя (дескриптор) неуправляемого объекта + public property Native: cl_program read ntv; + + private prop: ProgramCodeProperties; + private function GetProperties: ProgramCodeProperties; + begin + if prop=nil then prop := new ProgramCodeProperties(ntv); + Result := prop; + end; + ///Возвращает контейнер свойств неуправляемого объекта + public property Properties: ProgramCodeProperties read GetProperties; + + public static function operator=(wr1, wr2: ProgramCode): boolean := wr1.ntv = wr2.ntv; + public static function operator<>(wr1, wr2: ProgramCode): boolean := wr1.ntv <> wr2.ntv; + + ///-- + public function Equals(obj: object): boolean; override := + (obj is ProgramCode(var wr)) and (self = wr); + + end; + + {$endregion Common} + + {$region Misc} + + ///Представляет область памяти устройства OpenCL + Buffer = partial class + + ///Освобождает память, выделенную под данный буфер, если она выделена + ///Внимание, если снова использовать данный буфер - память выделится заново + public procedure Dispose; virtual := + if ntv<>cl_mem.Zero then lock self do + begin + if self.ntv=cl_mem.Zero then exit; // Во время ожидания lock могли удалить + self.prop := nil; + GC.RemoveMemoryPressure(Size64); + cl.ReleaseMemObject(ntv).RaiseIfError; + ntv := cl_mem.Zero; + end; + ///Освобождает неуправляемые ресурсы. Данный метод вызывается автоматически во время сборки мусора + ///Данный метод не должен вызываться из пользовательского кода. Он виден только на случай если вы хотите переопределить его в своём классе-наследнике + protected procedure Finalize; override := Dispose; + + end; + + ///Представляет область памяти внутри другого буфера + SubBuffer = partial class + + ///-- + public procedure Dispose; override := + if ntv<>cl_mem.Zero then lock self do + begin + if self.ntv=cl_mem.Zero then exit; // Во время ожидания lock могли удалить + self.prop := nil; + cl.ReleaseMemObject(ntv).RaiseIfError; + ntv := cl_mem.Zero; + end; + + end; + + ///Представляет устройство, поддерживающее OpenCL + Device = partial class + + private supported_split_modes: array of DevicePartitionProperty := nil; + private function GetSSM: array of DevicePartitionProperty; + begin + if supported_split_modes=nil then supported_split_modes := Properties.PartitionType; + Result := supported_split_modes; + end; + + private function Split(params props: array of DevicePartitionProperty): array of SubDevice; + begin + if not GetSSM.Contains(props[0]) then + raise new NotSupportedException($'Данный режим .Split не поддерживается выбранным устройством'); + + var c: UInt32; + cl.CreateSubDevices(self.ntv, props, 0, IntPtr.Zero, c).RaiseIfError; + + var res := new cl_device_id[int64(c)]; + cl.CreateSubDevices(self.ntv, props, c, res[0], IntPtr.Zero).RaiseIfError; + + Result := res.ConvertAll(sdvc->new SubDevice(sdvc, self)); + end; + + ///Указывает, поддерживает ли это устройство вызов метода .SplitEqually + public property CanSplitEqually: boolean read DevicePartitionProperty.DEVICE_PARTITION_EQUALLY in GetSSM; + ///Создаёт максимальное возможное количество виртуальных устройств, + ///каждое из которых содержит CUCount ядер данного устройства + public function SplitEqually(CUCount: integer): array of SubDevice; + begin + if CUCount <= 0 then raise new ArgumentException($'Количество ядер должно быть положительным числом, а не {CUCount}'); + Result := Split( + DevicePartitionProperty.DEVICE_PARTITION_EQUALLY, + DevicePartitionProperty.Create(CUCount), + DevicePartitionProperty.Create(0) + ); + end; + + ///Указывает, поддерживает ли это устройство вызов метода .SplitByCounts + public property CanSplitByCounts: boolean read DevicePartitionProperty.DEVICE_PARTITION_BY_COUNTS in GetSSM; + ///Создаёт массив виртуальных устройств, каждое из которых содержит указанное кол-во ядер + public function SplitByCounts(params CUCounts: array of integer): array of SubDevice; + begin + foreach var CUCount in CUCounts do + if CUCount <= 0 then raise new ArgumentException($'Количество ядер должно быть положительным числом, а не {CUCount}'); + + var props := new DevicePartitionProperty[CUCounts.Length+2]; + props[0] := DevicePartitionProperty.DEVICE_PARTITION_BY_COUNTS; + for var i := 0 to CUCounts.Length-1 do + props[i+1] := new DevicePartitionProperty(CUCounts[i]); + props[props.Length-1] := DevicePartitionProperty.DEVICE_PARTITION_BY_COUNTS_LIST_END; + + Result := Split(props); + end; + + ///Указывает, поддерживает ли это устройство вызов метода .SplitByAffinityDomain + public property CanSplitByAffinityDomain: boolean read DevicePartitionProperty.DEVICE_PARTITION_BY_AFFINITY_DOMAIN in GetSSM; + ///Разделяет данное устройство на отдельные группы ядер так, + ///чтобы у каждой группы ядер был общий кэш указанного уровня + public function SplitByAffinityDomain(affinity_domain: DeviceAffinityDomain) := + Split( + DevicePartitionProperty.DEVICE_PARTITION_BY_AFFINITY_DOMAIN, + DevicePartitionProperty.Create(new IntPtr(affinity_domain.val)), + DevicePartitionProperty.Create(0) + ); + + end; + + {$endregion Misc} + + {$endregion Wrappers} + + {$region CommandQueue} + + {$region Base} ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU - CommandQueueBase = OpenCLABCBase.CommandQueueBase; + CommandQueueBase = abstract partial class + + {$region ToString} + + private static function DisplayNameForType(t: System.Type): string; + begin + Result := t.Name; + + if t.IsGenericType then + begin + var ind := Result.IndexOf('`'); + Result := Result.Remove(ind) + '<' + t.GenericTypeArguments.JoinToString(', ') + '>'; + end; + + end; + private function DisplayName: string; virtual := DisplayNameForType(self.GetType); + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); abstract; + + private static function GetValueRuntimeType(val: T) := + if typeof(T).IsValueType then + typeof(T) else + if val = default(T) then + nil else val.GetType; + + private function ToStringHeader(sb: StringBuilder; index: Dictionary): boolean; + begin + sb += DisplayName; + + var ind: integer; + Result := not index.TryGetValue(self, ind); + + if Result then + begin + ind := index.Count; + index[self] := ind; + end; + + sb += '#'; + sb.Append(ind); + + end; + private procedure ToString(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet; write_tabs: boolean := true); + begin + delayed.Remove(self); + + if write_tabs then sb.Append(#9, tabs); + ToStringHeader(sb, index); + ToStringImpl(sb, tabs+1, index, delayed); + + if tabs=0 then foreach var q in delayed do + begin + sb += #10; + q.ToString(sb, 0, index, new HashSet); + end; + + end; + + ///Возвращает строковое представление данной очереди + ///Используйте это значение только для отладки, потому что данный метод довольно медленный + public function ToString: string; override; + begin + var sb := new StringBuilder; + ToString(sb, 0, new Dictionary, new HashSet); + Result := sb.ToString; + end; + + ///Вызывает Write(ToString) для данной очереди и возвращает её же + public function Print: CommandQueueBase; + begin + Write(self.ToString); + Result := self; + end; + ///Вызывает Writeln(ToString) для данной очереди и возвращает её же + public function Println: CommandQueueBase; + begin + Writeln(self.ToString); + Result := self; + end; + + {$endregion ToString} + + end; + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU - CommandQueue = OpenCLABCBase.CommandQueue; + CommandQueue = abstract partial class(CommandQueueBase) + + end; + + {$endregion Base} + + {$region Const} ///Интерфейс, который реализован только классом ConstQueue ///Позволяет получить значение, из которого была создана константая очередь, не зная его типа - IConstQueue = OpenCLABCBase.IConstQueue; + IConstQueue = interface + ///Возвращает значение из которого была создана данная константная очередь + function GetConstVal: Object; + end; ///Представляет константную очередь ///Константные очереди ничего не выполняют и возвращает заданное при создании значение - ConstQueue = OpenCLABCBase.ConstQueue; + ConstQueue = sealed partial class(CommandQueue, IConstQueue) + private res: T; + + ///Создаёт новую константную очередь из заданного значения + public constructor(o: T) := self.res := o; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public function IConstQueue.GetConstVal: object := self.res; + ///Возвращает значение из которого была создана данная константная очередь + public property Val: T read self.res; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' '; + var rt := GetValueRuntimeType(res); + if typeof(T) <> rt then + sb.Append(rt); + sb += '{ '; + if rt<>nil then + sb.Append(Val) else + sb += 'nil'; + sb += ' }'#10; + end; + + end; - ///Представляет очередь-контейнер для команд GPU, применяемых к объекту типа Buffer - BufferCommandQueue = OpenCLABCBase.BufferCommandQueue; - ///Представляет очередь-контейнер для команд GPU, применяемых к объекту типа Kernel - KernelCommandQueue = OpenCLABCBase.KernelCommandQueue; + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueueBase = abstract partial class + + public static function operator implicit(o: object): CommandQueueBase := + new ConstQueue(o); + + end; + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueue = abstract partial class + + public static function operator implicit(o: T): CommandQueue := + new ConstQueue(o); + + end; + + {$endregion Const} + + {$region Cast} + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueueBase = abstract partial class + + ///Если данная очередь проходит по условию "... is CommandQueue" - возвращает себя же + ///Иначе возвращает очередь-обёртку, выполняющую "res := T(res)", где res - результат данной очереди + public function Cast: CommandQueue; + + end; + + {$endregion Cast} + + {$region ThenConvert} + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueueBase = partial abstract class + + private function ThenConvertBase(f: (object, Context)->TOtp): CommandQueue; virtual; + + ///Создаёт очередь, которая выполнит данную + ///А затем выполнит на CPU функцию f, используя результат данной очереди + public function ThenConvert(f: object->TOtp ) := ThenConvertBase((o,c)->f(o)); + ///Создаёт очередь, которая выполнит данную + ///А затем выполнит на CPU функцию f, используя результат данной очереди и контекст выполнения + public function ThenConvert(f: (object, Context)->TOtp) := ThenConvertBase(f); + + end; + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueue = partial abstract class(CommandQueueBase) + + private function ThenConvertBase(f: (object, Context)->TOtp): CommandQueue; override := + ThenConvert(f as object as Func2); //ToDo #2221 + + ///Создаёт очередь, которая выполнит данную + ///А затем выполнит на CPU функцию f, используя результат данной очереди + public function ThenConvert(f: T->TOtp): CommandQueue := ThenConvert((o,c)->f(o)); + ///Создаёт очередь, которая выполнит данную + ///А затем выполнит на CPU функцию f, используя результат данной очереди и контекст выполнения + public function ThenConvert(f: (T, Context)->TOtp): CommandQueue; + + end; + + {$endregion ThenConvert} + + {$region +/*} + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueueBase = partial abstract class + + private function AfterQueueSyncBase(q: CommandQueueBase): CommandQueueBase; virtual; + private function AfterQueueAsyncBase(q: CommandQueueBase): CommandQueueBase; virtual; + + public static function operator+(q1, q2: CommandQueueBase): CommandQueueBase := q2.AfterQueueSyncBase(q1); + public static function operator*(q1, q2: CommandQueueBase): CommandQueueBase := q2.AfterQueueAsyncBase(q1); + + public static procedure operator+=(var q1: CommandQueueBase; q2: CommandQueueBase) := q1 := q1+q2; + public static procedure operator*=(var q1: CommandQueueBase; q2: CommandQueueBase) := q1 := q1*q2; + + end; + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueue = partial abstract class(CommandQueueBase) + + private function AfterQueueSyncBase (q: CommandQueueBase): CommandQueueBase; override := q+self; + private function AfterQueueAsyncBase(q: CommandQueueBase): CommandQueueBase; override := q*self; + + public static function operator+(q1: CommandQueueBase; q2: CommandQueue): CommandQueue; + public static function operator*(q1: CommandQueueBase; q2: CommandQueue): CommandQueue; + + public static procedure operator+=(var q1: CommandQueue; q2: CommandQueue) := q1 := q1+q2; + public static procedure operator*=(var q1: CommandQueue; q2: CommandQueue) := q1 := q1*q2; + + end; + + {$endregion +/*} + + {$region Multiusable} + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueueBase = partial abstract class + + private function MultiusableBase: ()->CommandQueueBase; virtual; + + ///Создаёт функцию, вызывая которую можно создать любое кол-во очередей-удлинителей для данной очереди + ///Подробнее в справке: "Очередь>>Создание очередей>>Множественное использование очереди" + public function Multiusable := MultiusableBase; + + end; + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueue = partial abstract class(CommandQueueBase) + + private function MultiusableBase: ()->CommandQueueBase; override := Multiusable() as object as Func; //ToDo #2221 + + ///Создаёт функцию, вызывая которую можно создать любое кол-во очередей-удлинителей для данной очереди + ///Подробнее в справке: "Очередь>>Создание очередей>>Множественное использование очереди" + public function Multiusable: ()->CommandQueue; + + end; + + {$endregion Multiusable} + + {$region Wait} + + ///Представляет базовый класс маркеров для Wait очередей + WaitMarkerBase = abstract partial class(CommandQueueBase) + + ///Посылает сигнал выполненности всем ожидающим Wait очередям + public procedure SendSignal; + + end; + + ///Представляет простой маркер для Wait очередей + ///При выполнении возвращает object(nil) + WaitMarker = sealed partial class(WaitMarkerBase) + + ///Создаёт новый маркер + public constructor := exit; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override := sb += #10; + + end; + + ///Представляет псевдо-маркер для Wait очередей, являющийся обёрткой очереди с возвращаемым значением + ///Этот тип является наследником CommandQueue, а значит он не может наследовать сразу и от WaitMarkerBase + ///Но при присвоении или передаче параметром он разлагается в обычный маркер, поэтому его можно передавать в любые Wait очереди + PseudoWaitMarker = sealed partial class + private q: CommandQueue; + private wrap: WaitMarkerBase; + + ///Создаёт новый псевдо-маркер для Wait очередей + public constructor(q: CommandQueue); + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public static function operator implicit(pmarker: PseudoWaitMarker): WaitMarkerBase := pmarker.wrap; + + ///Посылает сигнал выполненности всем ожидающим Wait очередям + public procedure SendSignal := wrap.SendSignal; + + end; + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueueBase = abstract partial class + + private function ThenWaitMarkerBase: WaitMarkerBase; virtual; + ///Создаёт новую обёртку-псевдо-маркер (PseudoWaitMarker), которая работает как очередь, + ///но разлогается в обычный маркер для Wait очередей при присвоении или передаче параметром + public function ThenWaitMarker := ThenWaitMarkerBase; + + private function ThenWaitForAllBase(markers: sequence of WaitMarkerBase): CommandQueueBase; virtual; + private function ThenWaitForAnyBase(markers: sequence of WaitMarkerBase): CommandQueueBase; virtual; + + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждого из заданых маркеров + public function ThenWaitForAll(params markers: array of WaitMarkerBase) := ThenWaitForAllBase(markers); + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждого из заданых маркеров + public function ThenWaitForAll( markers: sequence of WaitMarkerBase) := ThenWaitForAllBase(markers); + + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любого из заданных маркеров + public function ThenWaitForAny(params markers: array of WaitMarkerBase) := ThenWaitForAnyBase(markers); + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любого из заданных маркеров + public function ThenWaitForAny( markers: sequence of WaitMarkerBase) := ThenWaitForAnyBase(markers); + + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от заданого маркера + public function ThenWaitFor(marker: WaitMarkerBase) := ThenWaitForAll(marker); + + end; + + ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU + CommandQueue = abstract partial class(CommandQueueBase) + + private function ThenWaitMarkerBase: WaitMarkerBase; override := ThenWaitMarker; + + ///Создаёт новую обёртку-псевдо-маркер (PseudoWaitMarker), которая работает как очередь, + ///но разлогается в обычный маркер для Wait очередей при присвоении или передаче параметром + public function ThenWaitMarker := new PseudoWaitMarker(self); + + private function ThenWaitForAllBase(markers: sequence of WaitMarkerBase): CommandQueueBase; override := ThenWaitForAll(markers); + private function ThenWaitForAnyBase(markers: sequence of WaitMarkerBase): CommandQueueBase; override := ThenWaitForAny(markers); + + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждого из заданых маркеров + public function ThenWaitForAll(params markers: array of WaitMarkerBase): CommandQueue := ThenWaitForAll(markers.AsEnumerable); + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждого из заданых маркеров + public function ThenWaitForAll( markers: sequence of WaitMarkerBase): CommandQueue; + + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любого из заданных маркеров + public function ThenWaitForAny(params markers: array of WaitMarkerBase): CommandQueue := ThenWaitForAny(markers.AsEnumerable); + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любого из заданных маркеров + public function ThenWaitForAny( markers: sequence of WaitMarkerBase): CommandQueue; + + ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от заданого маркера + public function ThenWaitFor(marker: WaitMarkerBase) := ThenWaitForAll(marker); + + end; + + {$endregion Wait} + + {$endregion CommandQueue} + + {$region CLTask} + + ///Представляет задачу выполнения очереди, создаваемую методом Context.BeginInvoke + CLTaskBase = abstract partial class + protected wh := new ManualResetEvent(false); + protected wh_lock := new object; + + {$region Property's} + + private function OrgQueueBase: CommandQueueBase; abstract; + ///Возвращает очередь, которую выполняет данный CLTask + public property OrgQueue: CommandQueueBase read OrgQueueBase; + + private org_c: Context; + ///Возвращает контекст, в котором выполняется данный CLTask + public property OrgContext: Context read org_c; + + {$endregion Property's} + + {$region CLTask event's} + + private procedure WhenDoneBase(cb: Action); abstract; + ///Добавляет подпрограмму-обработчик, которая будет вызвана когда выполнение очереди завершится (успешно или с ошибой) + public procedure WhenDone(cb: Action) := WhenDoneBase(cb); + + private procedure WhenCompleteBase(cb: Action); abstract; + ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если выполнение очереди завершится успешно + public procedure WhenComplete(cb: Action) := WhenCompleteBase(cb); + + private procedure WhenErrorBase(cb: Action); abstract; + ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если при выполнении очереди будет вызвано исключение + public procedure WhenError(cb: Action) := WhenErrorBase(cb); + + /// True если очередь уже завершилась + protected function AddEventHandler(ev: List; cb: T): boolean; where T: Delegate; + begin + lock wh_lock do + begin + Result := wh.WaitOne(0); + if not Result then ev += cb; + end; + end; + + {$endregion CLTask event's} + + {$region Error's} + protected err_lst := new List; + + /// lock err_lst do err_lst.ToArray + protected function GetErrArr: array of Exception; + begin + lock err_lst do + Result := err_lst.ToArray; + end; + + ///Возвращает исключение, полученное при выполнении очереди + ///Возвращает nil, если исключений не было + public property Error: AggregateException read err_lst.Count=0 ? nil : new AggregateException($'При выполнении очереди было вызвано {err_lst.Count} исключений. Используйте try чтоб получить больше информации', GetErrArr); + + {$endregion Error's} + + {$region AddErr} + protected static AbortStatus := new CommandExecutionStatus(integer.MinValue); + + ///Регестрирует ошибку выполнения очереди + protected procedure AddErr(e: Exception); + + + ///Регестрирует ошибку выполнения очереди + ///Возвращает False если значение не было ошибкой. Иначе возвращает True + protected function AddErr(ec: ErrorCode): boolean; + begin + if not ec.IS_ERROR then exit; + AddErr(new OpenCLException(ec, $'Внутренняя ошибка OpenCLABC: {ec}{#10}{Environment.StackTrace}')); + Result := true; + end; + + ///Регестрирует ошибку выполнения очереди + ///Возвращает False если значение не было ошибкой. Иначе возвращает True + protected function AddErr(st: CommandExecutionStatus) := + (st=AbortStatus) or (st.IS_ERROR and AddErr(ErrorCode(st))); + + {$endregion AddErr} + + {$region Wait} + + ///Ожидает окончания выполнения очереди (если оно ещё не завершилось) + ///Вызывает исключение, если оно было вызвано при выполнении очереди + public procedure Wait; + begin + wh.WaitOne; + var err := self.Error; + if err<>nil then raise err; + end; + + private function WaitResBase: object; abstract; + ///Ожидает окончания выполнения очереди (если оно ещё не завершилось) + ///Вызывает исключение, если оно было вызвано при выполнении очереди + ///А затем возвращает результат выполнения + public function WaitRes := WaitResBase; + + {$endregion Wait} + + end; + + ///Представляет задачу выполнения очереди, создаваемую методом Context.BeginInvoke + CLTask = sealed partial class(CLTaskBase) + private q: CommandQueue; + private q_res: T; + + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + {$region Property's} + + ///Возвращает очередь, которую выполняет данный CLTask + public property OrgQueue: CommandQueue read q; reintroduce; + protected function OrgQueueBase: CommandQueueBase; override := self.OrgQueue; + + {$endregion Property's} + + {$region CLTask event's} + + private EvDone := new List>>; + ///Добавляет подпрограмму-обработчик, которая будет вызвана когда выполнение очереди завершится (успешно или с ошибой) + public procedure WhenDone(cb: Action>); reintroduce := + if AddEventHandler(EvDone, cb) then cb(self); + private procedure WhenDoneBase(cb: Action); override := + WhenDone(cb as object as Action>); //ToDo #2221 + + private EvComplete := new List, T>>; + ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если выполнение очереди завершится успешно + public procedure WhenComplete(cb: Action, T>); reintroduce := + if AddEventHandler(EvComplete, cb) then cb(self, q_res); + private procedure WhenCompleteBase(cb: Action); override := + WhenComplete(cb as object as Action, T>); //ToDo #2221 + + private EvError := new List, array of Exception>>; + ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если при выполнении очереди будет вызвано исключение + public procedure WhenError(cb: Action, array of Exception>); reintroduce := + if AddEventHandler(EvError, cb) then cb(self, GetErrArr); + private procedure WhenErrorBase(cb: Action); override := + WhenError(cb as object as Action, array of Exception>); //ToDo #2221 + + {$endregion CLTask event's} + + {$region Wait} + + ///Ожидает окончания выполнения очереди (если оно ещё не завершилось) + ///Вызывает исключение, если оно было вызвано при выполнении очереди + ///А затем возвращает результат выполнения + public function WaitRes: T; reintroduce; + begin + Wait; + Result := self.q_res; + end; + private function WaitResBase: object; override := WaitRes; + + {$endregion Wait} + + end; + + ///Представляет контекст для хранения данных и выполнения команд на GPU + Context = partial class + + ///Запускает данную очередь и все её подочереди + ///Как только всё запущено: возвращает объект типа CLTask<>, через который можно следить за процессом выполнения + public function BeginInvoke(q: CommandQueue): CLTask; + ///Запускает данную очередь и все её подочереди + ///Как только всё запущено: возвращает объект типа CLTask<>, через который можно следить за процессом выполнения + public function BeginInvoke(q: CommandQueueBase): CLTaskBase; + + ///Запускает данную очередь и все её подочереди + ///Затем ожидает окончания выполнения и возвращает полученный результат + public function SyncInvoke(q: CommandQueue) := BeginInvoke(q).WaitRes; + ///Запускает данную очередь и все её подочереди + ///Затем ожидает окончания выполнения и возвращает полученный результат + public function SyncInvoke(q: CommandQueueBase) := BeginInvoke(q).WaitRes; + + end; + + {$endregion CLTask} + + {$region KernelArg} ///Представляет аргумент, передаваемый в вызов kernel-а - KernelArg = OpenCLABCBase.KernelArg; + KernelArg = abstract partial class + + {$region Buffer} + + ///Создаёт аргумент kernel-а, представляющий буфер + public static function FromBuffer(b: Buffer): KernelArg; + public static function operator implicit(b: Buffer): KernelArg := FromBuffer(b); + + ///Создаёт аргумент kernel-а, представляющий буфер + public static function FromBufferCQ(bq: CommandQueue): KernelArg; + public static function operator implicit(bq: CommandQueue): KernelArg := FromBufferCQ(bq); + + {$endregion Buffer} + + {$region Record} + + ///Создаёт аргумент kernel-а, представляющий небольшое значение размерного типа + public static function FromRecord(val: TRecord): KernelArg; where TRecord: record; + public static function operator implicit(val: TRecord): KernelArg; where TRecord: record; begin Result := FromRecord(val); end; + + ///Создаёт аргумент kernel-а, представляющий небольшое значение размерного типа + public static function FromRecordCQ(valq: CommandQueue): KernelArg; where TRecord: record; + public static function operator implicit(valq: CommandQueue): KernelArg; where TRecord: record; begin Result := FromRecordCQ(valq); end; + + {$endregion Record} + + {$region Ptr} + + ///Создаёт аргумент kernel-а, представляющий адрес в неуправляемой памяти + public static function FromPtr(ptr: IntPtr; sz: UIntPtr): KernelArg; + + ///Создаёт аргумент kernel-а, представляющий адрес в неуправляемой памяти + public static function FromPtrCQ(ptr_q: CommandQueue; sz_q: CommandQueue): KernelArg; + + ///Создаёт аргумент kernel-а, представляющий адрес размерного значения со стека + ///Внимание! Адрес должен ссылаться именно на стек, иначе программа может время от времени падать с ошибками доступа к памяти + ///Это значит, что передавать можно только адрес локальной переменной, не захваченной ни одной лямбдой + public static function FromRecordPtr(ptr: ^TRecord): KernelArg; where TRecord: record; begin Result := FromPtr(new IntPtr(ptr), new UIntPtr(Marshal.SizeOf&)); end; + public static function operator implicit(ptr: ^TRecord): KernelArg; where TRecord: record; begin Result := FromRecordPtr(ptr); end; + + {$endregion Ptr} + + {$region ToString} + + private function DisplayName: string; virtual := CommandQueueBase.DisplayNameForType(self.GetType); + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); abstract; + + private procedure ToString(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet; write_tabs: boolean := true); + begin + if write_tabs then sb.Append(#9, tabs); + sb += DisplayName; + + ToStringImpl(sb, tabs+1, index, delayed); + + if tabs=0 then foreach var q in delayed do + begin + sb += #10; + q.ToString(sb, 0, index, new HashSet); + end; + + end; + + ///Возвращает строковое представление данного объекта KernelArg + ///Используйте это значение только для отладки, потому что данный метод довольно медленный + public function ToString: string; override; + begin + var sb := new StringBuilder; + ToString(sb, 0, new Dictionary, new HashSet); + Result := sb.ToString; + end; + + ///Вызывает Write(ToString) для данного объекта KernelArg и возвращает его же + public function Print: KernelArg; + begin + Write(self.ToString); + Result := self; + end; + ///Вызывает Writeln(ToString) для данного объекта KernelArg и возвращает его же + public function Println: KernelArg; + begin + Writeln(self.ToString); + Result := self; + end; + + {$endregion ToString} + + end; -{$endregion Re:definition's} + {$endregion KernelArg} + + {$region BufferCommandQueue} + + ///Представляет очередь-контейнер для команд GPU, применяемых к объекту типа Buffer + BufferCommandQueue = sealed partial class + + ///Создаёт контейнер команд, который будет применять команды к указанному объекту + public constructor(o: Buffer); + ///Создаёт контейнер команд, который будет применять команды к объекту, который вернёт указанная очередь + ///За каждое одно выполнение контейнера - q выполнится ровно один раз + public constructor(q: CommandQueue); + private constructor; + + {$region Special .Add's} + + ///Добавляет выполнение очереди в список обычных команд для GPU + public function AddQueue(q: CommandQueueBase): BufferCommandQueue; + + ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU + public function AddProc(p: Buffer->()): BufferCommandQueue; + ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU + public function AddProc(p: (Buffer, Context)->()): BufferCommandQueue; + + ///Добавляет ожидание сигнала выполненности от всех заданных маркеров + public function AddWaitAll(params markers: array of WaitMarkerBase): BufferCommandQueue; + ///Добавляет ожидание сигнала выполненности от всех заданных маркеров + public function AddWaitAll(markers: sequence of WaitMarkerBase): BufferCommandQueue; + + ///Добавляет ожидание первого сигнала выполненности от одного из заданных маркеров + public function AddWaitAny(params markers: array of WaitMarkerBase): BufferCommandQueue; + ///Добавляет ожидание первого сигнала выполненности от одного из заданных маркеров + public function AddWaitAny(markers: sequence of WaitMarkerBase): BufferCommandQueue; + + ///Добавляет ожидание сигнала выполненности от заданного маркера + public function AddWait(marker: WaitMarkerBase): BufferCommandQueue; + + {$endregion Special .Add's} + + {$region 1#Write&Read} + + ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM + public function AddWriteData(ptr: CommandQueue): BufferCommandQueue; + + ///Копирует всё содержимое буфера в RAM, по указанному адресу + public function AddReadData(ptr: CommandQueue): BufferCommandQueue; + + ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddWriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue; + + ///Копирует часть содержимого буфера в RAM, по указанному адресу + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue; + + ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM + public function AddWriteData(ptr: pointer): BufferCommandQueue; + + ///Копирует всё содержимое буфера в RAM, по указанному адресу + public function AddReadData(ptr: pointer): BufferCommandQueue; + + ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddWriteData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue; + + ///Копирует часть содержимого буфера в RAM, по указанному адресу + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddReadData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue; + + ///Записывает указанное значение размерного типа в начало буфера + public function AddWriteValue(val: TRecord): BufferCommandQueue; where TRecord: record; + + ///Записывает указанное значение размерного типа в буфер + ///buff_offset указывает отступ от начала буфера, в байтах + public function AddWriteValue(val: TRecord; buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает указанное значение размерного типа в начало буфера + public function AddWriteValue(val: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает указанное значение размерного типа в буфер + ///buff_offset указывает отступ от начала буфера, в байтах + public function AddWriteValue(val: CommandQueue; buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает весь массив в начало буфера + public function AddWriteArray1(a: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает весь массив в начало буфера + public function AddWriteArray2(a: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает весь массив в начало буфера + public function AddWriteArray3(a: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Читает из буфера достаточно байт чтоб заполнить весь массив + public function AddReadArray1(a: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Читает из буфера достаточно байт чтоб заполнить весь массив + public function AddReadArray2(a: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Читает из буфера достаточно байт чтоб заполнить весь массив + public function AddReadArray3(a: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает указанный участок массива в буфер + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + public function AddWriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает указанный участок массива в буфер + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function AddWriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Записывает указанный участок массива в буфер + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function AddWriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Читает в буфер указанный участок массива + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + public function AddReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Читает в буфер указанный участок массива + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function AddReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Читает в буфер указанный участок массива + ///a_offset(-ы) указывают индекс в массиве + ///len указывает кол-во задействованных элементов массива + ///buff_offset указывает отступ от начала буфера, в байтах + /// + ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально + ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] + ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку + public function AddReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; + + {$endregion 1#Write&Read} + + {$region 2#Fill} + + ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями весь буфер + public function AddFillData(ptr: CommandQueue; pattern_len: CommandQueue): BufferCommandQueue; + + ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями часть буфера + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddFillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): BufferCommandQueue; + + ///Заполняет весь буфер копиями указанного значения размерного типа + public function AddFillValue(val: TRecord): BufferCommandQueue; where TRecord: record; + + ///Заполняет часть буфера копиями указанного значения размерного типа + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddFillValue(val: TRecord; buff_offset, len: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Заполняет весь буфер копиями указанного значения размерного типа + public function AddFillValue(val: CommandQueue): BufferCommandQueue; where TRecord: record; + + ///Заполняет часть буфера копиями указанного значения размерного типа + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddFillValue(val: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue; where TRecord: record; + + {$endregion 2#Fill} + + {$region 3#Copy} + + ///Копирует данные из текущего буфера в b + ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера + public function AddCopyTo(b: CommandQueue): BufferCommandQueue; + + ///Копирует данные из b в текущий буфер + ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера + public function AddCopyForm(b: CommandQueue): BufferCommandQueue; + + ///Копирует данные из текущего буфера в b + ///from_pos указывает отступ в байтах от начала буфера, из которого копируют + ///to_pos указывает отступ в байтах от начала буфера, в который копируют + ///len указывает кол-во копируемых байт + public function AddCopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue; + + ///Копирует данные из b в текущий буфер + ///from_pos указывает отступ в байтах от начала буфера, из которого копируют + ///to_pos указывает отступ в байтах от начала буфера, в который копируют + ///len указывает кол-во копируемых байт + public function AddCopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue; + + {$endregion 3#Copy} + + {$region Get} + + ///Выделяет область неуправляемой памяти и копирует в неё всё содержимое данного буфера + public function AddGetData: CommandQueue; + + ///Выделяет область неуправляемой памяти и копирует в неё часть содержимого данного буфера + ///buff_offset указывает отступ от начала буфера, в байтах + ///len указывает кол-во задействованных байт буфера + public function AddGetData(buff_offset, len: CommandQueue): CommandQueue; + + ///Читает значение указанного размерного типа из начала буфера + public function AddGetValue: CommandQueue; where TRecord: record; + + ///Читает значение указанного размерного типа из буфера + ///buff_offset указывает отступ от начала буфера, в байтах + public function AddGetValue(buff_offset: CommandQueue): CommandQueue; where TRecord: record; + + ///Создаёт массив максимального размера (на сколько хватит байт буфера) и копирует в него содержимое буфера + public function AddGetArray1: CommandQueue; where TRecord: record; + + ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера + public function AddGetArray1(len: CommandQueue): CommandQueue; where TRecord: record; + + ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера + public function AddGetArray2(len1,len2: CommandQueue): CommandQueue; where TRecord: record; + + ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера + public function AddGetArray3(len1,len2,len3: CommandQueue): CommandQueue; where TRecord: record; + + {$endregion Get} + + end; + + ///Представляет область памяти устройства OpenCL + Buffer = partial class + ///Создаёт новую очередь-контейнер для команд GPU, применяемых к данному буферу + public function NewQueue := new BufferCommandQueue(self); + end; + + ///Представляет аргумент, передаваемый в вызов kernel-а + KernelArg = abstract partial class + public static function operator implicit(bq: BufferCommandQueue): KernelArg; + end; + + {$endregion BufferCommandQueue} + + {$region KernelCommandQueue} + + ///Представляет очередь-контейнер для команд GPU, применяемых к объекту типа Kernel + KernelCommandQueue = sealed partial class + + ///Создаёт контейнер команд, который будет применять команды к указанному объекту + public constructor(o: Kernel); + ///Создаёт контейнер команд, который будет применять команды к объекту, который вернёт указанная очередь + ///За каждое одно выполнение контейнера - q выполнится ровно один раз + public constructor(q: CommandQueue); + private constructor; + + {$region Special .Add's} + + ///Добавляет выполнение очереди в список обычных команд для GPU + public function AddQueue(q: CommandQueueBase): KernelCommandQueue; + + ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU + public function AddProc(p: Kernel->()): KernelCommandQueue; + ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU + public function AddProc(p: (Kernel, Context)->()): KernelCommandQueue; + + ///Добавляет ожидание сигнала выполненности от всех заданных маркеров + public function AddWaitAll(params markers: array of WaitMarkerBase): KernelCommandQueue; + ///Добавляет ожидание сигнала выполненности от всех заданных маркеров + public function AddWaitAll(markers: sequence of WaitMarkerBase): KernelCommandQueue; + + ///Добавляет ожидание первого сигнала выполненности от одного из заданных маркеров + public function AddWaitAny(params markers: array of WaitMarkerBase): KernelCommandQueue; + ///Добавляет ожидание первого сигнала выполненности от одного из заданных маркеров + public function AddWaitAny(markers: sequence of WaitMarkerBase): KernelCommandQueue; + + ///Добавляет ожидание сигнала выполненности от заданного маркера + public function AddWait(marker: WaitMarkerBase): KernelCommandQueue; + + {$endregion Special .Add's} + + {$region 1#Exec} + + ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы + public function AddExec1(sz1: CommandQueue; params args: array of KernelArg): KernelCommandQueue; + + ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы + public function AddExec2(sz1,sz2: CommandQueue; params args: array of KernelArg): KernelCommandQueue; + + ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы + public function AddExec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): KernelCommandQueue; + + ///Выполняет kernel с расширенным набором параметров + ///Данная перегрузка используется в первую очередь для тонких оптимизаций + ///Если она вам понадобилась по другой причина - пожалуйста, напишите в issue + public function AddExec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): KernelCommandQueue; + + {$endregion 1#Exec} + + end; + + ///Представляет подпрограмму, выполняемую на GPU + Kernel = partial class + ///Создаёт новую очередь-контейнер для команд GPU, применяемых к данному kernel-у + public function NewQueue := new KernelCommandQueue(self); + end; + + {$endregion KernelCommandQueue} + +{$region Global subprograms} {$region HFQ/HPQ} @@ -106,18 +2730,18 @@ function HPQ(p: Context->()): CommandQueueBase; {$region WaitFor} -///Создаёт очередь, ожидающую сигнала выполненности от каждой из указанных очередей -function WaitForAll(params qs: array of CommandQueueBase): CommandQueueBase; -///Создаёт очередь, ожидающую сигнала выполненности от каждой из указанных очередей -function WaitForAll(qs: sequence of CommandQueueBase): CommandQueueBase; +///Создаёт очередь, ожидающую сигнала выполненности от каждого из указанных маркеров +function WaitForAll(params markers: array of WaitMarkerBase): CommandQueueBase; +///Создаёт очередь, ожидающую сигнала выполненности от каждого из указанных маркеров +function WaitForAll( markers: sequence of WaitMarkerBase): CommandQueueBase; -///Создаёт очередь, ожидающую первого сигнала выполненности от любой из указанных очередей -function WaitForAny(params qs: array of CommandQueueBase): CommandQueueBase; -///Создаёт очередь, ожидающую первого сигнала выполненности от любой из указанных очередей -function WaitForAny(qs: sequence of CommandQueueBase): CommandQueueBase; +///Создаёт очередь, ожидающую первого сигнала выполненности от любого из указанных маркеров +function WaitForAny(params markers: array of WaitMarkerBase): CommandQueueBase; +///Создаёт очередь, ожидающую первого сигнала выполненности от любого из указанных маркеров +function WaitForAny( markers: sequence of WaitMarkerBase): CommandQueueBase; -///Создаёт очередь, ожидающую сигнала выполненности от указанной очереди -function WaitFor(q: CommandQueueBase): CommandQueueBase; +///Создаёт очередь, ожидающую сигнала выполненности от заданного маркера +function WaitFor(marker: WaitMarkerBase): CommandQueueBase; {$endregion WaitFor} @@ -373,8 +2997,6547 @@ function CombineAsyncQueue7 = abstract class + protected ntv: TNtv; + public constructor(ntv: TNtv) := self.ntv := ntv; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure GetSizeImpl(id: TInfo; var sz: UIntPtr); abstract; + protected procedure GetValImpl(id: TInfo; sz: UIntPtr; var res: byte); abstract; + + protected function GetSize(id: TInfo): UIntPtr; + begin GetSizeImpl(id, Result); end; + + protected procedure FillPtr(id: TInfo; sz: UIntPtr; ptr: IntPtr) := + GetValImpl(id, sz, PByte(pointer(ptr))^); + protected procedure FillVal(id: TInfo; sz: UIntPtr; var res: T) := + GetValImpl(id, sz, PByte(pointer(@res))^); + + protected function GetVal(id: TInfo): T; + begin FillVal(id, new UIntPtr(Marshal.SizeOf&), Result); end; + protected function GetValArr(id: TInfo): array of T; + begin + var sz := GetSize(id); + Result := new T[uint64(sz) div Marshal.SizeOf&]; + + if Result.Length<>0 then + FillVal(id, sz, Result[0]); + + end; +// protected function GetValArrArr(id: TInfo; szs: array of UIntPtr): array of array of T; +// type PT = ^T; +// begin +// if szs.Length=0 then +// begin +// SetLength(Result,0); +// exit; +// end; +// +// var res := new IntPtr[szs.Length]; +// SetLength(Result, szs.Length); +// +// for var i := 0 to szs.Length-1 do res[i] := Marshal.AllocHGlobal(IntPtr(pointer(szs[i]))); +// try +// +// FillVal(id, new UIntPtr(szs.Length*Marshal.SizeOf&), res[0]); +// +// var tsz := Marshal.SizeOf&; +// for var i := 0 to szs.Length-1 do +// begin +// Result[i] := new T[uint64(szs[i]) div tsz]; +// //To Do более эффективное копирование +// for var i2 := 0 to Result[i].Length-1 do +// Result[i][i2] := PT(pointer(res[i]+tsz*i2))^; +// end; +// +// finally +// for var i := 0 to szs.Length-1 do Marshal.FreeHGlobal(res[i]); +// end; +// +// end; + + private function GetString(id: TInfo): string; + begin + var sz := GetSize(id); + + var str_ptr := Marshal.AllocHGlobal(IntPtr(pointer(sz))); + try + FillPtr(id, sz, str_ptr); + Result := Marshal.PtrToStringAnsi(str_ptr); + finally + Marshal.FreeHGlobal(str_ptr); + end; + + end; + + end; + +{$endregion Base} + +{$region Buffer} + +type + BufferProperties = sealed partial class(NtvPropertiesBase) + + private static function clGetSize(ntv: cl_mem; param_name: MemInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; + external 'opencl.dll' name 'clGetMemObjectInfo'; + private static function clGetVal(ntv: cl_mem; param_name: MemInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; + external 'opencl.dll' name 'clGetMemObjectInfo'; + + protected procedure GetSizeImpl(id: MemInfo; var sz: UIntPtr); override := + clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; + protected procedure GetValImpl(id: MemInfo; sz: UIntPtr; var res: byte); override := + clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; + + end; + +constructor BufferProperties.Create(ntv: cl_mem) := inherited Create(ntv); + +function BufferProperties.GetType := GetVal&(MemInfo.MEM_TYPE); +function BufferProperties.GetFlags := GetVal&(MemInfo.MEM_FLAGS); +function BufferProperties.GetSize := GetVal&(MemInfo.MEM_SIZE); +function BufferProperties.GetHostPtr := GetVal&(MemInfo.MEM_HOST_PTR); +function BufferProperties.GetMapCount := GetVal&(MemInfo.MEM_MAP_COUNT); +function BufferProperties.GetReferenceCount := GetVal&(MemInfo.MEM_REFERENCE_COUNT); +function BufferProperties.GetUsesSvmPointer := GetVal&(MemInfo.MEM_USES_SVM_POINTER); +function BufferProperties.GetOffset := GetVal&(MemInfo.MEM_OFFSET); + +{$endregion Buffer} + +{$region Context} + +type + ContextProperties = sealed partial class(NtvPropertiesBase) + + private static function clGetSize(ntv: cl_context; param_name: ContextInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; + external 'opencl.dll' name 'clGetContextInfo'; + private static function clGetVal(ntv: cl_context; param_name: ContextInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; + external 'opencl.dll' name 'clGetContextInfo'; + + protected procedure GetSizeImpl(id: ContextInfo; var sz: UIntPtr); override := + clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; + protected procedure GetValImpl(id: ContextInfo; sz: UIntPtr; var res: byte); override := + clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; + + end; + +constructor ContextProperties.Create(ntv: cl_context) := inherited Create(ntv); + +function ContextProperties.GetReferenceCount := GetVal&(ContextInfo.CONTEXT_REFERENCE_COUNT); +function ContextProperties.GetNumDevices := GetVal&(ContextInfo.CONTEXT_NUM_DEVICES); +function ContextProperties.GetProperties := GetValArr&(ContextInfo.CONTEXT_PROPERTIES); + +{$endregion Context} + +{$region Device} + +type + DeviceProperties = sealed partial class(NtvPropertiesBase) + + private static function clGetSize(ntv: cl_device_id; param_name: DeviceInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; + external 'opencl.dll' name 'clGetDeviceInfo'; + private static function clGetVal(ntv: cl_device_id; param_name: DeviceInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; + external 'opencl.dll' name 'clGetDeviceInfo'; + + protected procedure GetSizeImpl(id: DeviceInfo; var sz: UIntPtr); override := + clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; + protected procedure GetValImpl(id: DeviceInfo; sz: UIntPtr; var res: byte); override := + clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; + + end; + +constructor DeviceProperties.Create(ntv: cl_device_id) := inherited Create(ntv); + +function DeviceProperties.GetType := GetVal&(DeviceInfo.DEVICE_TYPE); +function DeviceProperties.GetVendorId := GetVal&(DeviceInfo.DEVICE_VENDOR_ID); +function DeviceProperties.GetMaxComputeUnits := GetVal&(DeviceInfo.DEVICE_MAX_COMPUTE_UNITS); +function DeviceProperties.GetMaxWorkItemDimensions := GetVal&(DeviceInfo.DEVICE_MAX_WORK_ITEM_DIMENSIONS); +function DeviceProperties.GetMaxWorkItemSizes := GetValArr&(DeviceInfo.DEVICE_MAX_WORK_ITEM_SIZES); +function DeviceProperties.GetMaxWorkGroupSize := GetVal&(DeviceInfo.DEVICE_MAX_WORK_GROUP_SIZE); +function DeviceProperties.GetPreferredVectorWidthChar := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_CHAR); +function DeviceProperties.GetPreferredVectorWidthShort := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_SHORT); +function DeviceProperties.GetPreferredVectorWidthInt := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_INT); +function DeviceProperties.GetPreferredVectorWidthLong := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_LONG); +function DeviceProperties.GetPreferredVectorWidthFloat := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_FLOAT); +function DeviceProperties.GetPreferredVectorWidthDouble := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE); +function DeviceProperties.GetPreferredVectorWidthHalf := GetVal&(DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_HALF); +function DeviceProperties.GetNativeVectorWidthChar := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_CHAR); +function DeviceProperties.GetNativeVectorWidthShort := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_SHORT); +function DeviceProperties.GetNativeVectorWidthInt := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_INT); +function DeviceProperties.GetNativeVectorWidthLong := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_LONG); +function DeviceProperties.GetNativeVectorWidthFloat := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_FLOAT); +function DeviceProperties.GetNativeVectorWidthDouble := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_DOUBLE); +function DeviceProperties.GetNativeVectorWidthHalf := GetVal&(DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_HALF); +function DeviceProperties.GetMaxClockFrequency := GetVal&(DeviceInfo.DEVICE_MAX_CLOCK_FREQUENCY); +function DeviceProperties.GetAddressBits := GetVal&(DeviceInfo.DEVICE_ADDRESS_BITS); +function DeviceProperties.GetMaxMemAllocSize := GetVal&(DeviceInfo.DEVICE_MAX_MEM_ALLOC_SIZE); +function DeviceProperties.GetImageSupport := GetVal&(DeviceInfo.DEVICE_IMAGE_SUPPORT); +function DeviceProperties.GetMaxReadImageArgs := GetVal&(DeviceInfo.DEVICE_MAX_READ_IMAGE_ARGS); +function DeviceProperties.GetMaxWriteImageArgs := GetVal&(DeviceInfo.DEVICE_MAX_WRITE_IMAGE_ARGS); +function DeviceProperties.GetMaxReadWriteImageArgs := GetVal&(DeviceInfo.DEVICE_MAX_READ_WRITE_IMAGE_ARGS); +function DeviceProperties.GetIlVersion := GetString(DeviceInfo.DEVICE_IL_VERSION); +function DeviceProperties.GetImage2dMaxWidth := GetVal&(DeviceInfo.DEVICE_IMAGE2D_MAX_WIDTH); +function DeviceProperties.GetImage2dMaxHeight := GetVal&(DeviceInfo.DEVICE_IMAGE2D_MAX_HEIGHT); +function DeviceProperties.GetImage3dMaxWidth := GetVal&(DeviceInfo.DEVICE_IMAGE3D_MAX_WIDTH); +function DeviceProperties.GetImage3dMaxHeight := GetVal&(DeviceInfo.DEVICE_IMAGE3D_MAX_HEIGHT); +function DeviceProperties.GetImage3dMaxDepth := GetVal&(DeviceInfo.DEVICE_IMAGE3D_MAX_DEPTH); +function DeviceProperties.GetImageMaxBufferSize := GetVal&(DeviceInfo.DEVICE_IMAGE_MAX_BUFFER_SIZE); +function DeviceProperties.GetImageMaxArraySize := GetVal&(DeviceInfo.DEVICE_IMAGE_MAX_ARRAY_SIZE); +function DeviceProperties.GetMaxSamplers := GetVal&(DeviceInfo.DEVICE_MAX_SAMPLERS); +function DeviceProperties.GetImagePitchAlignment := GetVal&(DeviceInfo.DEVICE_IMAGE_PITCH_ALIGNMENT); +function DeviceProperties.GetImageBaseAddressAlignment := GetVal&(DeviceInfo.DEVICE_IMAGE_BASE_ADDRESS_ALIGNMENT); +function DeviceProperties.GetMaxPipeArgs := GetVal&(DeviceInfo.DEVICE_MAX_PIPE_ARGS); +function DeviceProperties.GetPipeMaxActiveReservations := GetVal&(DeviceInfo.DEVICE_PIPE_MAX_ACTIVE_RESERVATIONS); +function DeviceProperties.GetPipeMaxPacketSize := GetVal&(DeviceInfo.DEVICE_PIPE_MAX_PACKET_SIZE); +function DeviceProperties.GetMaxParameterSize := GetVal&(DeviceInfo.DEVICE_MAX_PARAMETER_SIZE); +function DeviceProperties.GetMemBaseAddrAlign := GetVal&(DeviceInfo.DEVICE_MEM_BASE_ADDR_ALIGN); +function DeviceProperties.GetSingleFpConfig := GetVal&(DeviceInfo.DEVICE_SINGLE_FP_CONFIG); +function DeviceProperties.GetDoubleFpConfig := GetVal&(DeviceInfo.DEVICE_DOUBLE_FP_CONFIG); +function DeviceProperties.GetGlobalMemCacheType := GetVal&(DeviceInfo.DEVICE_GLOBAL_MEM_CACHE_TYPE); +function DeviceProperties.GetGlobalMemCachelineSize := GetVal&(DeviceInfo.DEVICE_GLOBAL_MEM_CACHELINE_SIZE); +function DeviceProperties.GetGlobalMemCacheSize := GetVal&(DeviceInfo.DEVICE_GLOBAL_MEM_CACHE_SIZE); +function DeviceProperties.GetGlobalMemSize := GetVal&(DeviceInfo.DEVICE_GLOBAL_MEM_SIZE); +function DeviceProperties.GetMaxConstantBufferSize := GetVal&(DeviceInfo.DEVICE_MAX_CONSTANT_BUFFER_SIZE); +function DeviceProperties.GetMaxConstantArgs := GetVal&(DeviceInfo.DEVICE_MAX_CONSTANT_ARGS); +function DeviceProperties.GetMaxGlobalVariableSize := GetVal&(DeviceInfo.DEVICE_MAX_GLOBAL_VARIABLE_SIZE); +function DeviceProperties.GetGlobalVariablePreferredTotalSize := GetVal&(DeviceInfo.DEVICE_GLOBAL_VARIABLE_PREFERRED_TOTAL_SIZE); +function DeviceProperties.GetLocalMemType := GetVal&(DeviceInfo.DEVICE_LOCAL_MEM_TYPE); +function DeviceProperties.GetLocalMemSize := GetVal&(DeviceInfo.DEVICE_LOCAL_MEM_SIZE); +function DeviceProperties.GetErrorCorrectionSupport := GetVal&(DeviceInfo.DEVICE_ERROR_CORRECTION_SUPPORT); +function DeviceProperties.GetProfilingTimerResolution := GetVal&(DeviceInfo.DEVICE_PROFILING_TIMER_RESOLUTION); +function DeviceProperties.GetEndianLittle := GetVal&(DeviceInfo.DEVICE_ENDIAN_LITTLE); +function DeviceProperties.GetAvailable := GetVal&(DeviceInfo.DEVICE_AVAILABLE); +function DeviceProperties.GetCompilerAvailable := GetVal&(DeviceInfo.DEVICE_COMPILER_AVAILABLE); +function DeviceProperties.GetLinkerAvailable := GetVal&(DeviceInfo.DEVICE_LINKER_AVAILABLE); +function DeviceProperties.GetExecutionCapabilities := GetVal&(DeviceInfo.DEVICE_EXECUTION_CAPABILITIES); +function DeviceProperties.GetQueueOnHostProperties := GetVal&(DeviceInfo.DEVICE_QUEUE_ON_HOST_PROPERTIES); +function DeviceProperties.GetQueueOnDeviceProperties := GetVal&(DeviceInfo.DEVICE_QUEUE_ON_DEVICE_PROPERTIES); +function DeviceProperties.GetQueueOnDevicePreferredSize := GetVal&(DeviceInfo.DEVICE_QUEUE_ON_DEVICE_PREFERRED_SIZE); +function DeviceProperties.GetQueueOnDeviceMaxSize := GetVal&(DeviceInfo.DEVICE_QUEUE_ON_DEVICE_MAX_SIZE); +function DeviceProperties.GetMaxOnDeviceQueues := GetVal&(DeviceInfo.DEVICE_MAX_ON_DEVICE_QUEUES); +function DeviceProperties.GetMaxOnDeviceEvents := GetVal&(DeviceInfo.DEVICE_MAX_ON_DEVICE_EVENTS); +function DeviceProperties.GetBuiltInKernels := GetString(DeviceInfo.DEVICE_BUILT_IN_KERNELS); +function DeviceProperties.GetName := GetString(DeviceInfo.DEVICE_NAME); +function DeviceProperties.GetVendor := GetString(DeviceInfo.DEVICE_VENDOR); +function DeviceProperties.GetProfile := GetString(DeviceInfo.DEVICE_PROFILE); +function DeviceProperties.GetVersion := GetString(DeviceInfo.DEVICE_VERSION); +function DeviceProperties.GetOpenclCVersion := GetString(DeviceInfo.DEVICE_OPENCL_C_VERSION); +function DeviceProperties.GetExtensions := GetString(DeviceInfo.DEVICE_EXTENSIONS); +function DeviceProperties.GetPrintfBufferSize := GetVal&(DeviceInfo.DEVICE_PRINTF_BUFFER_SIZE); +function DeviceProperties.GetPreferredInteropUserSync := GetVal&(DeviceInfo.DEVICE_PREFERRED_INTEROP_USER_SYNC); +function DeviceProperties.GetPartitionMaxSubDevices := GetVal&(DeviceInfo.DEVICE_PARTITION_MAX_SUB_DEVICES); +function DeviceProperties.GetPartitionProperties := GetValArr&(DeviceInfo.DEVICE_PARTITION_PROPERTIES); +function DeviceProperties.GetPartitionAffinityDomain := GetVal&(DeviceInfo.DEVICE_PARTITION_AFFINITY_DOMAIN); +function DeviceProperties.GetPartitionType := GetValArr&(DeviceInfo.DEVICE_PARTITION_TYPE); +function DeviceProperties.GetReferenceCount := GetVal&(DeviceInfo.DEVICE_REFERENCE_COUNT); +function DeviceProperties.GetSvmCapabilities := GetVal&(DeviceInfo.DEVICE_SVM_CAPABILITIES); +function DeviceProperties.GetPreferredPlatformAtomicAlignment := GetVal&(DeviceInfo.DEVICE_PREFERRED_PLATFORM_ATOMIC_ALIGNMENT); +function DeviceProperties.GetPreferredGlobalAtomicAlignment := GetVal&(DeviceInfo.DEVICE_PREFERRED_GLOBAL_ATOMIC_ALIGNMENT); +function DeviceProperties.GetPreferredLocalAtomicAlignment := GetVal&(DeviceInfo.DEVICE_PREFERRED_LOCAL_ATOMIC_ALIGNMENT); +function DeviceProperties.GetMaxNumSubGroups := GetVal&(DeviceInfo.DEVICE_MAX_NUM_SUB_GROUPS); +function DeviceProperties.GetSubGroupIndependentForwardProgress := GetVal&(DeviceInfo.DEVICE_SUB_GROUP_INDEPENDENT_FORWARD_PROGRESS); + +{$endregion Device} + +{$region Kernel} + +type + KernelProperties = sealed partial class(NtvPropertiesBase) + + private static function clGetSize(ntv: cl_kernel; param_name: KernelInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; + external 'opencl.dll' name 'clGetKernelInfo'; + private static function clGetVal(ntv: cl_kernel; param_name: KernelInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; + external 'opencl.dll' name 'clGetKernelInfo'; + + protected procedure GetSizeImpl(id: KernelInfo; var sz: UIntPtr); override := + clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; + protected procedure GetValImpl(id: KernelInfo; sz: UIntPtr; var res: byte); override := + clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; + + end; + +constructor KernelProperties.Create(ntv: cl_kernel) := inherited Create(ntv); + +function KernelProperties.GetFunctionName := GetString(KernelInfo.KERNEL_FUNCTION_NAME); +function KernelProperties.GetNumArgs := GetVal&(KernelInfo.KERNEL_NUM_ARGS); +function KernelProperties.GetReferenceCount := GetVal&(KernelInfo.KERNEL_REFERENCE_COUNT); +function KernelProperties.GetAttributes := GetString(KernelInfo.KERNEL_ATTRIBUTES); + +{$endregion Kernel} + +{$region Platform} + +type + PlatformProperties = sealed partial class(NtvPropertiesBase) + + private static function clGetSize(ntv: cl_platform_id; param_name: PlatformInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; + external 'opencl.dll' name 'clGetPlatformInfo'; + private static function clGetVal(ntv: cl_platform_id; param_name: PlatformInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; + external 'opencl.dll' name 'clGetPlatformInfo'; + + protected procedure GetSizeImpl(id: PlatformInfo; var sz: UIntPtr); override := + clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; + protected procedure GetValImpl(id: PlatformInfo; sz: UIntPtr; var res: byte); override := + clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; + + end; + +constructor PlatformProperties.Create(ntv: cl_platform_id) := inherited Create(ntv); + +function PlatformProperties.GetProfile := GetString(PlatformInfo.PLATFORM_PROFILE); +function PlatformProperties.GetVersion := GetString(PlatformInfo.PLATFORM_VERSION); +function PlatformProperties.GetName := GetString(PlatformInfo.PLATFORM_NAME); +function PlatformProperties.GetVendor := GetString(PlatformInfo.PLATFORM_VENDOR); +function PlatformProperties.GetExtensions := GetString(PlatformInfo.PLATFORM_EXTENSIONS); +function PlatformProperties.GetHostTimerResolution := GetVal&(PlatformInfo.PLATFORM_HOST_TIMER_RESOLUTION); + +{$endregion Platform} + +{$region ProgramCode} + +type + ProgramCodeProperties = sealed partial class(NtvPropertiesBase) + + private static function clGetSize(ntv: cl_program; param_name: ProgramInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; + external 'opencl.dll' name 'clGetProgramInfo'; + private static function clGetVal(ntv: cl_program; param_name: ProgramInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; + external 'opencl.dll' name 'clGetProgramInfo'; + + protected procedure GetSizeImpl(id: ProgramInfo; var sz: UIntPtr); override := + clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; + protected procedure GetValImpl(id: ProgramInfo; sz: UIntPtr; var res: byte); override := + clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; + + end; + +constructor ProgramCodeProperties.Create(ntv: cl_program) := inherited Create(ntv); + +function ProgramCodeProperties.GetReferenceCount := GetVal&(ProgramInfo.PROGRAM_REFERENCE_COUNT); +function ProgramCodeProperties.GetSource := GetString(ProgramInfo.PROGRAM_SOURCE); +function ProgramCodeProperties.GetIl := GetValArr&(ProgramInfo.PROGRAM_IL); +function ProgramCodeProperties.GetNumKernels := GetVal&(ProgramInfo.PROGRAM_NUM_KERNELS); +function ProgramCodeProperties.GetKernelNames := GetString(ProgramInfo.PROGRAM_KERNEL_NAMES); +function ProgramCodeProperties.GetScopeGlobalCtorsPresent := GetVal&(ProgramInfo.PROGRAM_SCOPE_GLOBAL_CTORS_PRESENT); +function ProgramCodeProperties.GetScopeGlobalDtorsPresent := GetVal&(ProgramInfo.PROGRAM_SCOPE_GLOBAL_DTORS_PRESENT); + +{$endregion ProgramCode} + +{$endregion Properties} + +{$region Util type's} + +{$region EventDebug}{$ifdef EventDebug} + +type + EventRetainReleaseData = record + private is_release: boolean; + private reason: string; + + private static debug_time_counter := Stopwatch.StartNew; + private time: TimeSpan; + + public constructor(is_release: boolean; reason: string); + begin + self.is_release := is_release; + self.reason := reason; + self.time := debug_time_counter.Elapsed; + end; + + private function GetActStr := is_release ? 'Released' : 'Retained'; + public function ToString: string; override := + $'{time} | {GetActStr} when: {reason}'; + + end; + EventDebug = static class + + {$region Retain/Release} + + private static RefCounter := new Dictionary>; + private static function RefCounterFor(ev: cl_event): List; + begin + lock RefCounter do + if not RefCounter.TryGetValue(ev, Result) then + begin + Result := new List; + RefCounter[ev] := Result; + end; + end; + + public static procedure RegisterEventRetain(ev: cl_event; reason: string); + begin + var lst := RefCounterFor(ev); + lock lst do lst += new EventRetainReleaseData(false, reason); + end; + public static procedure RegisterEventRelease(ev: cl_event; reason: string); + begin + var lst := RefCounterFor(ev); + lock lst do lst += new EventRetainReleaseData(true, reason); + end; + + public static procedure ReportRefCounterInfo := + lock output do lock RefCounter do + begin + + foreach var ev in RefCounter.Keys do + begin + $'Logging state change of {ev}'.Println; + var lst := RefCounter[ev]; + var c := 0; + lock lst do + foreach var act in lst do + begin + if act.is_release then + c -= 1 else + c += 1; + $'{c,3} | {act}'.Println; + end; + Writeln('-'*30); + end; + + Writeln('='*40); + end; + + {$endregion Retain/Release} + + end; + +{$endif EventDebug}{$endregion EventDebug} + +{$region NativeUtils} + +type + NativeUtils = static class + + public static function AsPtr(p: pointer): ^T := p; + public static function AsPtr(p: IntPtr) := AsPtr&(pointer(p)); + + public static function CopyToUnm(a: TRecord): IntPtr; where TRecord: record; + begin + Result := Marshal.AllocHGlobal(Marshal.SizeOf&); + AsPtr&(Result)^ := a; + end; + + public static function GCHndAlloc(o: object) := + CopyToUnm(GCHandle.Alloc(o)); + + public static procedure GCHndFree(gc_hnd_ptr: IntPtr); + begin + AsPtr&(gc_hnd_ptr)^.Free; + Marshal.FreeHGlobal(gc_hnd_ptr); + end; + + public static function StartNewBgThread(p: Action): Thread; + begin + Result := new Thread(p); + Result.IsBackground := true; + Result.Start; + end; + + protected static procedure FixCQ(c: cl_context; dvc: cl_device_id; var cq: cl_command_queue); + begin + if cq <> cl_command_queue.Zero then exit; + var ec: ErrorCode; + cq := cl.CreateCommandQueue(c, dvc, CommandQueueProperties.NONE, ec); + ec.RaiseIfError; + end; + + end; + +{$endregion NativeUtils} + +{$region Blittable} + +type + BlittableException = sealed class(Exception) + public constructor(t, blame: System.Type; source_name: string) := + inherited Create(t=blame ? $'Тип {t} нельзя использовать в {source_name}' : $'Тип {t} нельзя использовать в {source_name}, потому что он содержит тип {blame}' ); + end; + BlittableHelper = static class + + private static blittable_cache := new Dictionary; + public static function Blame(t: System.Type): System.Type; + begin + if t.IsPointer then exit; + if t.IsClass then + begin + Result := t; + exit; + end; + + //ToDo Протестировать - может быстрее будет без blittable_cache, потому что всё заинлайнится? + if blittable_cache.TryGetValue(t, Result) then exit; + + foreach var fld in t.GetFields(System.Reflection.BindingFlags.Instance or System.Reflection.BindingFlags.Public or System.Reflection.BindingFlags.NonPublic) do + if fld.FieldType<>t then + begin + Result := Blame(fld.FieldType); + if Result<>nil then break; + end; + + blittable_cache[t] := Result; + end; + +// public static function IsBlittable(t: System.Type) := Blame(t)=nil; + public static procedure RaiseIfNeed(t: System.Type; source_name: string); + begin + var blame := BlittableHelper.Blame(t); + if blame=nil then exit; + raise new BlittableException(t, blame, source_name); + end; + + end; + +{$endregion Blittable} + +{$region EventList} + +type + EventList = sealed partial class + public evs: array of cl_event; + public count := 0; + public abortable := false; // true только если можно моментально отменить + + {$region Misc} + + public property Item[i: integer]: cl_event read evs[i]; default; + + public static function operator=(l1, l2: EventList): boolean; + begin + Result := false; + if object.ReferenceEquals(l1, l2) then + begin + Result := true; + exit; + end; + if object.ReferenceEquals(l1, nil) then exit; + if object.ReferenceEquals(l2, nil) then exit; + if l1.count <> l2.count then exit; + for var i := 0 to l1.count-1 do + if l1[i]<>l2[i] then exit; + Result := true; + end; + public static function operator<>(l1, l2: EventList): boolean := not (l1=l2); + + {$endregion Misc} + + {$region constructor's} + + public constructor := exit; + public constructor(count: integer) := + if count<>0 then self.evs := new cl_event[count]; + + public static function operator implicit(ev: cl_event): EventList; + begin + if ev=cl_event.Zero then + Result := new EventList else + begin + Result := new EventList(1); + Result += ev; + end; + end; + + public constructor(params evs: array of cl_event); + begin + self.evs := evs; + self.count := evs.Length; + end; + + {$endregion constructor's} + + {$region operator+} + + public static procedure operator+=(l: EventList; ev: cl_event); + begin + l.evs[l.count] := ev; + l.count += 1; + end; + + public static procedure operator+=(l: EventList; ev: EventList); + begin + for var i := 0 to ev.count-1 do + l += ev[i]; + l.abortable := l.abortable or ev.abortable; + end; + + public static function operator+(l1, l2: EventList): EventList; + begin + Result := new EventList(l1.count+l2.count); + Result += l1; + Result += l2; + Result.abortable := l1.abortable or l2.abortable; + end; + + public static function operator+(l: EventList; ev: cl_event): EventList; + begin + Result := new EventList(l.count+1); + Result += l; + Result += ev; + end; + + {$endregion operator+} + + {$region cl_event.AttachCallback} + + public static procedure AttachNativeCallback(ev: cl_event; cb: EventCallback) := + cl.SetEventCallback(ev, CommandExecutionStatus.COMPLETE, cb, NativeUtils.GCHndAlloc(cb)).RaiseIfError; + + private static function DefaultStatusErr(tsk: CLTaskBase; st: CommandExecutionStatus; save_err: boolean): boolean := + if save_err then tsk.AddErr(st) else st.IS_ERROR; + + public static procedure AttachCallback(ev: cl_event; work: Action; tsk: CLTaskBase; need_ev_release: boolean{$ifdef EventDebug}; reason: string{$endif}; st_err_handler: (CLTaskBase, CommandExecutionStatus, boolean)->boolean := DefaultStatusErr; save_err: boolean := true) := + AttachNativeCallback(ev, (ev,st,data)-> + begin + if need_ev_release then + begin + tsk.AddErr(cl.ReleaseEvent(ev)); + {$ifdef EventDebug} + EventDebug.RegisterEventRelease(ev, $'discarding after use in AttachCallback, working on {reason}'); + {$endif EventDebug} + end; + + if not st_err_handler(tsk, st, save_err) then + try + work; + except + on e: Exception do tsk.AddErr(e); + end; + + NativeUtils.GCHndFree(data); + end); + + public static procedure AttachFinallyCallback(ev: cl_event; work: Action; tsk: CLTaskBase; need_ev_release: boolean{$ifdef EventDebug}; reason: string{$endif}) := + AttachNativeCallback(ev, (ev,st,data)-> + begin + if need_ev_release then + begin + tsk.AddErr(cl.ReleaseEvent(ev)); + {$ifdef EventDebug} + if reason=nil then raise new InvalidOperationException; + EventDebug.RegisterEventRelease(ev, $'discarding after use in AttachFinallyCallback, working on {reason}'); + {$endif EventDebug} + end; + + try + work; + except + on e: Exception do tsk.AddErr(e); + end; + + NativeUtils.GCHndFree(data); + end); + + {$endregion cl_event.AttachCallback} + + {$region EventList.AttachCallback} + + private function ToMarker(c: cl_context; dvc: cl_device_id; var cq: cl_command_queue; expect_smart_status_err: boolean): cl_event; + begin + {$ifdef DEBUG} + if count <= 1 then raise new System.NotSupportedException; + {$endif DEBUG} + + NativeUtils.FixCQ(c, dvc, cq); + cl.EnqueueMarkerWithWaitList(cq, self.count, self.evs, Result).RaiseIfError; + {$ifdef EventDebug} + EventDebug.RegisterEventRetain(Result, $'enq''ed marker for evs: {evs.JoinToString}'); + {$endif EventDebug} + if expect_smart_status_err then self.Retain( + {$ifdef EventDebug}$'making sure ev isn''t deleted until SmartStatusErr'{$endif} + ); + + end; + + private function SmartStatusErr(tsk: CLTaskBase; org_st: CommandExecutionStatus; save_err: boolean; need_release: boolean): boolean; + begin + //ToDo NV#3035203 + //ToDo И добавить использование save_err, когда раскомметирую +// if not org_st.IS_ERROR then exit; +// if org_st.val <> ErrorCode.EXEC_STATUS_ERROR_FOR_EVENTS_IN_WAIT_LIST.val then +// Result := tsk.AddErr(org_st) else + + {$ifdef DEBUG} + if count <= 1 then raise new System.NotSupportedException; + {$endif DEBUG} + + for var i := 0 to count-1 do + begin + var st: CommandExecutionStatus; + var ec := cl.GetEventInfo( + evs[i], EventInfo.EVENT_COMMAND_EXECUTION_STATUS, + new UIntPtr(sizeof(CommandExecutionStatus)), st, IntPtr.Zero + ); + + if tsk.AddErr(ec) then continue; + if save_err ? tsk.AddErr(st) : st.IS_ERROR then Result := true; + + end; + + if need_release then self.Release( + {$ifdef EventDebug}$'after use in SmartStatusErr'{$endif} + ); + + //ToDo NV#3035203 - без бага эта часть не нужна + if org_st.val <> ErrorCode.EXEC_STATUS_ERROR_FOR_EVENTS_IN_WAIT_LIST.val then + if save_err ? tsk.AddErr(org_st) : org_st.IS_ERROR then Result := true; + end; + + public procedure AttachCallback(work: Action; tsk: CLTaskBase; c: cl_context; dvc: cl_device_id; var cq: cl_command_queue{$ifdef EventDebug}; reason: string{$endif}; save_err: boolean := true) := + case self.count of + 0: work; + 1: AttachCallback(self.evs[0], work, tsk, false{$ifdef EventDebug}, nil{$endif}, DefaultStatusErr, save_err); + else AttachCallback(self.ToMarker(c, dvc, cq, true), work, tsk, true{$ifdef EventDebug}, reason{$endif}, (tsk,st,save_err)->SmartStatusErr(tsk,st,save_err,true), save_err); + end; + + public procedure AttachFinallyCallback(work: Action; tsk: CLTaskBase; c: cl_context; dvc: cl_device_id; var cq: cl_command_queue{$ifdef EventDebug}; reason: string{$endif}) := + case self.count of + 0: work; + 1: AttachFinallyCallback(self.evs[0], work, tsk, false{$ifdef EventDebug}, nil{$endif}); + else AttachFinallyCallback(self.ToMarker(c, dvc, cq, false), work, tsk, true{$ifdef EventDebug}, reason{$endif}); + end; + + {$endregion EventList.AttachCallback} + + {$region Retain/Release} + + public procedure Retain({$ifdef EventDebug}reason: string{$endif}) := + for var i := 0 to count-1 do + begin + cl.RetainEvent(evs[i]).RaiseIfError; + {$ifdef EventDebug} + EventDebug.RegisterEventRetain(evs[i], $'{reason}, together with evs: {evs.JoinToString}'); + {$endif EventDebug} + end; + + public procedure Release({$ifdef EventDebug}reason: string{$endif}) := + for var i := 0 to count-1 do + begin + cl.ReleaseEvent(evs[i]).RaiseIfError; + {$ifdef EventDebug} + EventDebug.RegisterEventRelease(evs[i], $'{reason}, together with evs: {evs.JoinToString}'); + {$endif EventDebug} + end; + + /// True если возникла ошибка + public function WaitAndRelease(tsk: CLTaskBase): boolean; + begin + {$ifdef DEBUG} + if count=0 then raise new NotSupportedException; + {$endif DEBUG} + + var ec := cl.WaitForEvents(self.count, self.evs); + if count=1 then + Result := tsk.AddErr(ec) else + Result := SmartStatusErr(tsk, CommandExecutionStatus(ec), true, false); + + self.Release({$ifdef EventDebug}$'discarding after being waited upon'{$endif EventDebug}); + end; + + {$endregion Retain/Release} + + end; + +{$endregion EventList} + +{$region UserEvent} + +type + UserEvent = sealed class + private uev: cl_event; + private done := false; + + {$region constructor's} + + private constructor(c: cl_context{$ifdef EventDebug}; reason: string{$endif}); + begin + var ec: ErrorCode; + self.uev := cl.CreateUserEvent(c, ec); + ec.RaiseIfError; + {$ifdef EventDebug} + EventDebug.RegisterEventRetain(self.uev, $'Created for {reason}'); + {$endif EventDebug} + end; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + public static function MakeUserEvent(tsk: CLTaskBase; c: cl_context{$ifdef EventDebug}; reason: string{$endif}): UserEvent; + + public static function StartBackgroundWork(after: EventList; work: Action; c: cl_context; tsk: CLTaskBase{$ifdef EventDebug}; reason: string{$endif}): UserEvent; + begin + var res := MakeUserEvent(tsk, c + {$ifdef EventDebug}, $'BackgroundWork, executing {reason}, after waiting on: {after?.evs?.JoinToString}'{$endif} + ); + + var abort_thr_ev := new AutoResetEvent(false); + EventList.AttachFinallyCallback(res, ()->abort_thr_ev.Set(), tsk, false{$ifdef EventDebug}, nil{$endif}); + + var work_thr: Thread; + var abort_thr := NativeUtils.StartNewBgThread(()-> + begin + abort_thr_ev.WaitOne; // Изначальная пауза, чтобы work_thr не убили до того как он успеет запуститься и выполнить after.Release + abort_thr_ev.WaitOne; + work_thr.Abort; + end); + + work_thr := NativeUtils.StartNewBgThread(()-> + try + var err := false; + try + if (after<>nil) and (after.count<>0) then + begin + if not after.abortable then + after := after + MakeUserEvent(tsk,c + {$ifdef EventDebug}, $'abortability of BackgroundWork wait on: {after.evs.JoinToString}'{$endif} + ); + err := after.WaitAndRelease(tsk); + end; + finally + abort_thr_ev.Set; + // Далее - в любом случае выполняется res.SetStatus, который вызывает + // содержимое res.AttachFinallyCallback выше + // Поэтому abort_thr никогда не застрянет + end; + + if err then + begin + abort_thr.Abort; + res.Abort; + end else + begin + work; + abort_thr.Abort; + res.SetStatus(CommandExecutionStatus.COMPLETE); + end; + + except + on e: Exception do + begin + tsk.AddErr(e); + // Первый .AddErr всегда сам вызывает .Abort на всех UserEvent + // А значит и abort_thr.Abort уже выполнило выше + // Единственное исключение - если "e is ThreadAbortException" + // Но это случится только если abort_thr уже доработало +// abort_thr.Abort; +// res.Abort; + end; + end); + + Result := res; + end; + + {$endregion constructor's} + + {$region Status} + + public property CanRemove: boolean read done; + + /// True если статус получилось изменить + public function SetStatus(st: CommandExecutionStatus): boolean; + begin + lock self do + begin + if done then exit; + cl.SetUserEventStatus(uev, st).RaiseIfError; + done := true; + Result := true; + end; + end; + /// True если статус получилось изменить + public function SetStatus(st: CommandExecutionStatus; tsk: CLTaskBase): boolean; + begin + lock self do + begin + if done then exit; + if tsk.AddErr(cl.SetUserEventStatus(uev, st)) then exit; + done := true; + Result := true; + end; + end; + public function Abort := SetStatus(CLTaskBase.AbortStatus); + + {$endregion Status} + + {$region operator's} + + public static function operator implicit(ev: UserEvent): cl_event := ev.uev; + public static function operator implicit(ev: UserEvent): EventList; + begin + Result := ev.uev; + Result.abortable := true; + end; + + public static function operator+(ev1: EventList; ev2: UserEvent): EventList; + begin + Result := ev1 + ev2.uev; + Result.abortable := true; + end; + public static procedure operator+=(ev1: EventList; ev2: UserEvent); + begin + ev1 += ev2.uev; + ev1.abortable := true; + end; + + {$endregion operator's} + + end; + + EventList = sealed partial class + + private static function Combine(evs: IList; tsk: CLTaskBase; c: cl_context; main_dvc: cl_device_id; var cq: cl_command_queue): EventList; + begin + var count := 0; + var need_abort_ev := true; + + for var i := 0 to evs.Count-1 do + begin + count += evs[i].count; + if need_abort_ev and evs[i].abortable then need_abort_ev := false; + end; + if count=0 then exit; + + Result := new EventList(count + integer(need_abort_ev)); + + for var i := 0 to evs.Count-1 do + Result += evs[i]; + + if need_abort_ev then + begin + var uev := UserEvent.MakeUserEvent(tsk, c + {$ifdef EventDebug}, $'abortability of EventList.Combine of: {Result.evs.Take(Result.count).JoinToString}'{$endif} + ); + Result.AttachFinallyCallback(()->uev.SetStatus(CommandExecutionStatus.COMPLETE), tsk, c, main_dvc, cq + {$ifdef EventDebug}, $'setting abort ev: {uev.uev}'{$endif} + ); + Result += uev.uev; //ToDo #2431 // Result += uev; и abortable не надо ручками + Result.abortable := true; + end; + + end; + + end; + +{$endregion UserEvent} + +{$region QueueRes} + +type + {$region Misc} + + IPtrQueueRes = interface + function GetPtr: ^T; + end; + QRPtrWrap = sealed class(IPtrQueueRes) + private ptr: ^T := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); + + public constructor(val: T) := self.ptr^ := val; + private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure Finalize; override := + Marshal.FreeHGlobal(new IntPtr(ptr)); + + public function GetPtr: ^T := ptr; + + end; + + {$endregion Misc} + + {$region Base} + + QueueRes = abstract partial class end; + QueueResBase = abstract partial class + public ev: EventList; + public can_set_ev := true; + + public constructor(ev: EventList) := + self.ev := ev; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public function GetResBase: object; abstract; + public function TrySetEvBase(new_ev: EventList): QueueResBase; abstract; + + public function LazyQuickTransformBase(f: object->T2): QueueRes; abstract; + + end; + + QueueRes = abstract partial class(QueueResBase) + + public function GetRes: T; abstract; + public function GetResBase: object; override := GetRes; + + public function TrySetEv(new_ev: EventList): QueueRes; + begin + if self.ev=new_ev then + Result := self else + begin + Result := if can_set_ev then self else Clone; + Result.ev := new_ev; + end; + end; + public function TrySetEvBase(new_ev: EventList): QueueResBase; override := TrySetEv(new_ev); + + public function Clone: QueueRes; abstract; + + public function EnsureAbortability(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue): QueueRes; + begin + Result := self; + if (ev.count<>0) and not ev.abortable then + begin + var uev := UserEvent.MakeUserEvent(tsk, c.ntv + {$ifdef EventDebug}, $'abortability of QueueRes with .ev: {ev.evs.JoinToString}'{$endif} + ); + ev.AttachFinallyCallback(()->uev.SetStatus(CommandExecutionStatus.COMPLETE), tsk, c.ntv, main_dvc, cq{$ifdef EventDebug}, $'setting abort ev: {uev.uev}'{$endif}); + Result := Result.TrySetEv(ev + uev); + end; + end; + + public function LazyQuickTransform(f: T->T2): QueueRes; abstract; + public function LazyQuickTransformBase(f: object->T2): QueueRes; override := + LazyQuickTransform(o->f(o)); //ToDo #2221 + + /// Должно выполнятся только после ожидания ивентов + public function ToPtr: IPtrQueueRes; abstract; + + end; + + {$endregion Base} + + {$region Const} + + // Результат который просто есть + QueueResConst = sealed partial class(QueueRes) + private res: T; + + public constructor(res: T; ev: EventList); + begin + inherited Create(ev); + self.res := res; + end; + private constructor := inherited; + + public function Clone: QueueRes; override := new QueueResConst(res, ev); + + public function GetRes: T; override := res; + + public function LazyQuickTransform(f: T->T2): QueueRes; override := + new QueueResConst(f(self.res), self.ev); + + public function ToPtr: IPtrQueueRes; override := new QRPtrWrap(res); + + end; + + {$endregion Const} + + {$region Func} + + // Результат который надо будет сначала дождаться, а потом ещё досчитать + QueueResFunc = sealed partial class(QueueRes) + private f: ()->T; + + public constructor(f: ()->T; ev: EventList); + begin + inherited Create(ev); + self.f := f; + end; + private constructor := inherited; + + public function Clone: QueueRes; override := new QueueResFunc(f, ev); + + public function GetRes: T; override := f(); + + public function LazyQuickTransform(f2: T->T2): QueueRes; override := + new QueueResFunc(()->f2(self.f), self.ev); + + public function ToPtr: IPtrQueueRes; override := new QRPtrWrap(self.f()); + + end; + + {$endregion Func} + + {$region Delayed} + + // Результат который будет сохранён куда то, надо только дождаться + QueueResDelayedBase = abstract partial class(QueueRes) + + // QueueResFunc, потому что результат сохраняется именно в этот объект, а не в клон + public function Clone: QueueRes; override := new QueueResFunc(self.GetRes, ev); + + public procedure SetRes(value: T); abstract; + + public function LazyQuickTransform(f: T->T2): QueueRes; override := + new QueueResFunc(()->f(self.GetRes()), self.ev); + + end; + + QueueResDelayedObj = sealed partial class(QueueResDelayedBase) + private res := default(T); + + public constructor := inherited Create(nil); + + public function GetRes: T; override := res; + public procedure SetRes(value: T); override := res := value; + + public function ToPtr: IPtrQueueRes; override := new QRPtrWrap(res); + + end; + + QueueResDelayedPtr = sealed partial class(QueueResDelayedBase, IPtrQueueRes) + private ptr: ^T := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); + + public constructor := inherited Create(nil); + + public constructor(res: T; ev: EventList); + begin + inherited Create(ev); + self.ptr^ := res; + end; + + public function GetPtr: ^T := ptr; + public function GetRes: T; override := ptr^; + public procedure SetRes(value: T); override := ptr^ := value; + + protected procedure Finalize; override := + Marshal.FreeHGlobal(new IntPtr(ptr)); + + public function ToPtr: IPtrQueueRes; override := self; + + end; + + QueueResDelayedBase = abstract partial class(QueueRes) + + public static function MakeNew(need_ptr_qr: boolean) := + if need_ptr_qr then + new QueueResDelayedPtr as QueueResDelayedBase else + new QueueResDelayedObj as QueueResDelayedBase; + + end; + + {$endregion Delayed} + +{$endregion QueueRes} + +{$region MWEventContainer} + +type + MWEventContainer = sealed class // MW = Multi Wait + private curr_handlers := new Queue<()->boolean>; + private cached := 0; + + public procedure AddHandler(handler: ()->boolean) := lock self do + if cached=0 then + curr_handlers += handler else + if handler() then + cached -= 1; + + public procedure ExecuteHandler := + lock self do + begin + while curr_handlers.Count<>0 do + if curr_handlers.Dequeue()() then + exit; + cached += 1; + end; + + end; + +{$endregion MWEventContainer} + +{$endregion Util type's} + +{$region MultiusableBase} + +type + MultiusableCommandQueueHubBase = abstract class + + end; + +{$endregion MultiusableBase} + +{$region CommandQueue} + +{$region Base} + +type + CommandQueueBase = abstract partial class + + protected function InvokeBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueResBase; abstract; + + private procedure FinishAfterNewQ(cq: cl_command_queue; ev: EventList; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id); + begin + {$ifdef DEBUG} + if (ev.count<>0) and not ev.abortable then raise new System.NotSupportedException; + {$endif DEBUG} + if cq=cl_command_queue.Zero then exit; + + ev.AttachFinallyCallback(()-> + begin + System.Threading.Tasks.Task.Run(()->tsk.AddErr(cl.ReleaseCommandQueue(cq))) + end, tsk, c.ntv, main_dvc, cq{$ifdef EventDebug}, $'cl.ReleaseCommandQueue'{$endif}); + + end; + protected function InvokeNewQBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; prev_ev: EventList): QueueResBase; + begin + var cq := cl_command_queue.Zero; + Result := InvokeBase(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + FinishAfterNewQ(cq, Result.ev, tsk, c, main_dvc); + end; + + /// Добавление tsk в качестве ключа для всех ожидаемых очередей + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; + + end; + + CommandQueue = abstract partial class(CommandQueueBase) + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; abstract; + protected function InvokeBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueResBase; override := + Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + + protected function InvokeNewQ(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; prev_ev: EventList): QueueRes; + begin + var cq := cl_command_queue.Zero; + Result := Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + FinishAfterNewQ(cq, Result.ev, tsk, c, main_dvc); + end; + + end; + +{$endregion Base} + +{$region Const} + +type + ConstQueue = sealed partial class(CommandQueue, IConstQueue) + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + if prev_ev=nil then prev_ev := new EventList; + + if need_ptr_qr then + Result := new QueueResDelayedPtr (self.res, prev_ev) else + Result := new QueueResConst (self.res, prev_ev); + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + end; + +{$endregion Const} + +{$region WaitMarker} + +type + WaitMarkerBase = abstract partial class(CommandQueueBase) + private mw_evs := new Dictionary; + + private procedure RegisterWaiterTask(tsk: CLTaskBase) := + lock mw_evs do if not mw_evs.ContainsKey(tsk) then + begin + mw_evs[tsk] := new MWEventContainer; + tsk.WhenDone(tsk->lock mw_evs do mw_evs.Remove(tsk)); + end; + + private procedure AddMWHandler(tsk: CLTaskBase; handler: ()->boolean); + begin + var cont: MWEventContainer; + lock mw_evs do cont := mw_evs[tsk]; + cont.AddHandler(handler); + end; + + end; + + WaitMarker = sealed partial class(WaitMarkerBase) + + protected function InvokeBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueResBase; override; + begin + {$ifdef DEBUG} + if need_ptr_qr then raise new System.InvalidOperationException; + {$endif DEBUG} + Result := new QueueResConst(nil, prev_ev ?? new EventList); + Result.ev.AttachCallback(self.SendSignal, tsk, c.ntv, main_dvc, cq{$ifdef EventDebug}, $'ExecuteMWHandlers'{$endif}, false); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + end; + + PseudoWaitMarkerWrapper = sealed class(WaitMarkerBase) + private org: CommandQueueBase; + public constructor(org: CommandQueueBase) := self.org := org; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected function InvokeBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueResBase; override := + org.InvokeBase(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + org.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + org.ToStringHeader(sb, index); + sb += #10; + + end; + + end; + PseudoWaitMarker = sealed partial class(CommandQueue) + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + Result := self.q.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + Result.ev.AttachCallback(wrap.SendSignal, tsk, c.ntv, main_dvc, cq{$ifdef EventDebug}, $'ExecuteMWHandlers'{$endif}, false); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + wrap.ToStringHeader(sb, index); + sb += #10; + + q.ToString(sb, tabs, index, delayed); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + q.RegisterWaitables(tsk, prev_hubs); + + end; + +procedure WaitMarkerBase.SendSignal; +begin + if mw_evs.Count=0 then exit; + var conts: array of MWEventContainer; + lock mw_evs do conts := mw_evs.Values.ToArray; + for var i := 0 to conts.Length-1 do conts[i].ExecuteHandler; +end; + +constructor PseudoWaitMarker.Create(q: CommandQueue); +begin + self.q := q; + self.wrap := new PseudoWaitMarkerWrapper(self); +end; + +function CommandQueueBase.ThenWaitMarkerBase := self.Cast&.ThenWaitMarker.wrap; + +{$endregion WaitMarker} + +{$region Host} + +type + /// очередь, выполняющая какую то работу на CPU, всегда в отдельном потоке + HostQueue = abstract class(CommandQueue) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; abstract; + + protected function ExecFunc(o: TInp; c: Context): TRes; abstract; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + var prev_qr := InvokeSubQs(tsk, c, main_dvc, cq, prev_ev); + + var qr := QueueResDelayedBase&.MakeNew(need_ptr_qr); + qr.ev := UserEvent.StartBackgroundWork(prev_qr.ev, ()->qr.SetRes( ExecFunc(prev_qr.GetRes(), c) ), c.ntv, tsk + {$ifdef EventDebug}, $'body of {self.GetType}'{$endif} + ); + + Result := qr; + end; + + end; + +{$endregion Host} + +{$endregion CommandQueue} + +{$region CLTask} + +type + CLTaskBase = abstract partial class + protected mu_res := new Dictionary; + + {$region UserEvent's} + protected user_events := new List; + + protected function MakeUserEvent(c: cl_context{$ifdef EventDebug}; reason: string{$endif}): UserEvent; + begin + Result := new UserEvent(c{$ifdef EventDebug}, reason{$endif}); + + lock user_events do + begin + if err_lst.Count<>0 then + Result.Abort else + user_events += Result; + end; + + end; + + {$endregion UserEvent's} + + end; + + CLTask = sealed partial class(CLTaskBase) + + protected constructor(q: CommandQueue; c: Context); + begin + self.q := q; + self.org_c := c; + q.RegisterWaitables(self, new HashSet); + + var cq: cl_command_queue; + var qr := q.Invoke(self, c, c.MainDevice.ntv, false, cq, nil); + + // mu выполняют лишний .Retain, чтобы ивент не удалился пока очередь ещё запускается + foreach var mu_qr in mu_res.Values do + mu_qr.ev.Release({$ifdef EventDebug}$'excessive mu ev'{$endif}); + mu_res := nil; + + {$ifdef DEBUG} + if (qr.ev.count<>0) and not qr.ev.abortable then raise new NotSupportedException; + {$endif DEBUG} + + //CQ.Invoke всегда выполняет UserEvent.EnsureAbortability, поэтому тут оно не нужно + qr.ev.AttachFinallyCallback(()-> + begin + qr.ev.Release({$ifdef EventDebug}$'last ev of CLTask'{$endif}); + if cq<>cl_command_queue.Zero then + System.Threading.Tasks.Task.Run(()->self.AddErr( cl.ReleaseCommandQueue(cq) )); + OnQDone(qr); + end, self, c.ntv, c.MainDevice.ntv, cq{$ifdef EventDebug}, $'CLTask.OnQDone'{$endif}); + + end; + + private procedure OnQDone(qr: QueueRes); + begin + var l_EvDone: array of Action>; + var l_EvComplete: array of Action, T>; + var l_EvError: array of Action, array of Exception>; + + lock wh_lock do + try + + l_EvDone := EvDone.ToArray; + l_EvComplete := EvComplete.ToArray; + l_EvError := EvError.ToArray; + + if err_lst.Count=0 then self.q_res := qr.GetRes; + finally + wh.Set; + end; + + foreach var ev in l_EvDone do + try + ev(self); + except + on e: Exception do AddErr(e); + end; + + if err_lst.Count=0 then + begin + + foreach var ev in l_EvComplete do + try + ev(self, self.q_res); + except + on e: Exception do AddErr(e); + end; + + end else + if l_EvError.Length<>0 then + begin + var err_arr := GetErrArr; + + foreach var ev in l_EvError do + try + ev(self, err_arr); + except + on e: Exception do AddErr(e); + end; + + end; + + end; + + end; + + CLTaskResLess = sealed class(CLTaskBase) + protected q: CommandQueueBase; + protected q_res: object; + + protected function OrgQueueBase: CommandQueueBase; override := q; + + protected constructor(q: CommandQueueBase; c: Context); + begin + self.q := q; + self.org_c := c; + q.RegisterWaitables(self, new HashSet); + + var cq: cl_command_queue; + var qr := q.InvokeBase(self, c, c.MainDevice.ntv, false, cq, nil); + + // mu выполняют лишний .Retain, чтобы ивент не удалился пока очередь ещё запускается + foreach var mu_qr in mu_res.Values do + mu_qr.ev.Release({$ifdef EventDebug}$'excessive mu ev'{$endif}); + mu_res := nil; + + {$ifdef DEBUG} + if (qr.ev.count<>0) and not qr.ev.abortable then raise new NotSupportedException; + {$endif DEBUG} + + qr.ev.AttachFinallyCallback(()-> + begin + qr.ev.Release({$ifdef EventDebug}$'last ev of CLTask'{$endif}); + if cq<>cl_command_queue.Zero then + System.Threading.Tasks.Task.Run(()->self.AddErr( cl.ReleaseCommandQueue(cq) )); + OnQDone(qr); + end, self, c.ntv, c.MainDevice.ntv, cq{$ifdef EventDebug}, $'CLTaskResLess.OnQDone'{$endif}); + + end; + + {$region CLTask event's} + + protected EvDone := new List>; + protected procedure WhenDoneBase(cb: Action); override := + if AddEventHandler(EvDone, cb) then cb(self); + + protected EvComplete := new List>; + protected procedure WhenCompleteBase(cb: Action); override := + if AddEventHandler(EvComplete, cb) then cb(self, q_res); + + protected EvError := new List>; + protected procedure WhenErrorBase(cb: Action); override := + if AddEventHandler(EvError, cb) then cb(self, GetErrArr); + + {$endregion CLTask event's} + + {$region Execution} + + private procedure OnQDone(qr: QueueResBase); + begin + var l_EvDone: array of Action; + var l_EvComplete: array of Action; + var l_EvError: array of Action; + + lock wh_lock do + try + + l_EvDone := EvDone.ToArray; + l_EvComplete := EvComplete.ToArray; + l_EvError := EvError.ToArray; + + if err_lst.Count=0 then self.q_res := qr.GetResBase; + finally + wh.Set; + end; + + foreach var ev in l_EvDone do + try + ev(self); + except + on e: Exception do AddErr(e); + end; + + if err_lst.Count=0 then + begin + + foreach var ev in l_EvComplete do + try + ev(self, self.q_res); + except + on e: Exception do AddErr(e); + end; + + end else + if l_EvError.Length<>0 then + begin + var err_arr := GetErrArr; + + foreach var ev in l_EvError do + try + ev(self, err_arr); + except + on e: Exception do AddErr(e); + end; + + end; + + end; + + protected function WaitResBase: object; override; + begin + Wait; + Result := q_res; + end; + + {$endregion Execution} + + end; + +function Context.BeginInvoke(q: CommandQueue) := new CLTask(q, self); +function Context.BeginInvoke(q: CommandQueueBase) := new CLTaskResLess(q, self); + +procedure CLTaskBase.AddErr(e: Exception) := +begin + if e is ThreadAbortException then exit; + lock err_lst do err_lst += e; + lock user_events do + begin + for var i := user_events.Count-1 downto 0 do + user_events[i].Abort; + user_events.Clear; + end; +end; + +static function UserEvent.MakeUserEvent(tsk: CLTaskBase; c: cl_context{$ifdef EventDebug}; reason: string{$endif}) := tsk.MakeUserEvent(c{$ifdef EventDebug}, reason{$endif}); + +{$endregion CLTask} + +{$region Queue converter's} + +{$region Cast} + +type + ICastQueue = interface + function GetQ: CommandQueueBase; + end; + CastQueue = sealed class(CommandQueue, ICastQueue) + private q: CommandQueueBase; + public function ICastQueue.GetQ := q; + + public constructor(q: CommandQueueBase) := self.q := q; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override := + q.InvokeBase(tsk, c, main_dvc, false, cq, prev_ev).LazyQuickTransformBase(o-> + try + Result := T(o); + except + on e: Exception do + tsk.AddErr(e); + end); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + q.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + q.ToString(sb, tabs, index, delayed); + end; + + end; + +function CommandQueueBase.Cast: CommandQueue; +begin + var q := self; + if q is ICastQueue(var cq) then q := cq.GetQ; + Result := + if q is IConstQueue(var cq) then + new ConstQueue(T(cq.GetConstVal)) else + if q is CommandQueue(var tcq) then + tcq else + new CastQueue(q); +end; + +{$endregion Cast} + +{$region ThenConvert} + +type + CommandQueueThenConvert = sealed class(HostQueue) + protected q: CommandQueue; + protected f: (TInp, Context)->TRes; + + public constructor(q: CommandQueue; f: (TInp, Context)->TRes); + begin + self.q := q; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + q.RegisterWaitables(tsk, prev_hubs); + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override := + q.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + + protected function ExecFunc(o: TInp; c: Context): TRes; override := f(o, c); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(f); + sb += #10; + q.ToString(sb, tabs, index, delayed); + end; + + end; + +function CommandQueueBase.ThenConvertBase(f: (object, Context)->TOtp) := +self.Cast&.ThenConvert(f); + +function CommandQueue.ThenConvert(f: (T, Context)->TOtp) := +new CommandQueueThenConvert(self, f); + +{$endregion ThenConvert} + +{$region +/*} + +{$region Simple} + +type + ISimpleQueueArray = interface + function GetQS: sequence of CommandQueueBase; + end; + SimpleQueueArray = abstract class(CommandQueue, ISimpleQueueArray) + protected qs: array of CommandQueueBase; + protected last: CommandQueue; + + public constructor(params qs: array of CommandQueueBase); + begin + self.qs := new CommandQueueBase[qs.Length-1]; + System.Array.Copy(qs, self.qs, qs.Length-1); + self.last := qs[qs.Length-1].Cast&; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public function GetQS: sequence of CommandQueueBase := qs.Append(last as CommandQueueBase); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + foreach var q in qs do q.RegisterWaitables(tsk, prev_hubs); + last.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + foreach var q in GetQS do + q.ToString(sb, tabs, index, delayed); + end; + + end; + + ISimpleSyncQueueArray = interface(ISimpleQueueArray) end; + SimpleSyncQueueArray = sealed class(SimpleQueueArray, ISimpleSyncQueueArray) + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + + for var i := 0 to qs.Length-1 do + prev_ev := qs[i].InvokeBase(tsk, c, main_dvc, false, cq, prev_ev).ev; + + Result := last.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + end; + + end; + + ISimpleAsyncQueueArray = interface(ISimpleQueueArray) end; + SimpleAsyncQueueArray = sealed class(SimpleQueueArray, ISimpleAsyncQueueArray) + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then + loop qs.Length do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var evs := new EventList[qs.Length+1]; + + for var i := 0 to qs.Length-1 do + evs[i] := qs[i].InvokeNewQBase(tsk, c, main_dvc, false, prev_ev).ev; + + // Используем внешнюю cq, чтобы не создавать лишнюю + Result := last.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + evs[qs.Length] := Result.ev; + + Result := Result.TrySetEv( EventList.Combine(evs, tsk, c.ntv, main_dvc, cq) ?? new EventList ); + end; + + end; + +{$endregion Simple} + +{$region Conv} + +{$region Generic} + +type + ConvQueueArrayBase = abstract class(HostQueue) + protected qs: array of CommandQueue; + protected f: Func; + + public constructor(qs: array of CommandQueue; f: Func); + begin + self.qs := qs; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + foreach var q in qs do q.RegisterWaitables(tsk, prev_hubs); + + protected function ExecFunc(o: array of TInp; c: Context): TRes; override := f(o, c); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(f); + sb += #10; + foreach var q in qs do + q.ToString(sb, tabs, index, delayed); + end; + + end; + + ConvSyncQueueArray = sealed class(ConvQueueArrayBase) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + var qrs := new QueueRes[qs.Length]; + + for var i := 0 to qs.Length-1 do + begin + var qr := qs[i].Invoke(tsk, c, main_dvc, false, cq, prev_ev); + prev_ev := qr.ev; + qrs[i] := qr; + end; + + Result := new QueueResFunc(()-> + begin + Result := new TInp[qrs.Length]; + for var i := 0 to qrs.Length-1 do + Result[i] := qrs[i].GetRes; + end, prev_ev); + end; + + end; + ConvAsyncQueueArray = sealed class(ConvQueueArrayBase) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop qs.Length-1 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qrs := new QueueRes[qs.Length]; + var evs := new EventList[qs.Length]; + + for var i := 0 to qs.Length-2 do + begin + var qr := qs[i].InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + qrs[i] := qr; + evs[i] := qr.ev; + end; + + // Отдельно, чтобы не создавать лишнюю cq + var qr := qs[qs.Length-1].Invoke(tsk, c, main_dvc, false, cq, prev_ev); + qrs[evs.Length-1] := qr; + evs[evs.Length-1] := qr.ev; + + Result := new QueueResFunc(()-> + begin + Result := new TInp[qrs.Length]; + for var i := 0 to qrs.Length-1 do + Result[i] := qrs[i].GetRes; + end, EventList.Combine(evs, tsk, c.ntv, main_dvc, cq) ?? new EventList); + end; + + end; + +{$endregion Generic} + +{$region [2]} + +type + ConvQueueArrayBase2 = abstract class(HostQueue, TRes>) + protected q1: CommandQueue; + protected q2: CommandQueue; + protected f: (TInp1, TInp2, Context)->TRes; + + public constructor(q1: CommandQueue; q2: CommandQueue; f: (TInp1, TInp2, Context)->TRes); + begin + self.q1 := q1; + self.q2 := q2; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + self.q1.RegisterWaitables(tsk, prev_hubs); + self.q2.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + self.q1.ToString(sb, tabs, index, delayed); + self.q2.ToString(sb, tabs, index, delayed); + end; + + protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, c); + + end; + + ConvSyncQueueArray2 = sealed class(ConvQueueArrayBase2) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; + var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes()), prev_ev); + end; + + end; + ConvAsyncQueueArray2 = sealed class(ConvQueueArrayBase2) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop 1 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev), tsk, c.Native, main_dvc, cq)); + end; + + end; + +{$endregion [2]} + +{$region [3]} + +type + ConvQueueArrayBase3 = abstract class(HostQueue, TRes>) + protected q1: CommandQueue; + protected q2: CommandQueue; + protected q3: CommandQueue; + protected f: (TInp1, TInp2, TInp3, Context)->TRes; + + public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; f: (TInp1, TInp2, TInp3, Context)->TRes); + begin + self.q1 := q1; + self.q2 := q2; + self.q3 := q3; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + self.q1.RegisterWaitables(tsk, prev_hubs); + self.q2.RegisterWaitables(tsk, prev_hubs); + self.q3.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + self.q1.ToString(sb, tabs, index, delayed); + self.q2.ToString(sb, tabs, index, delayed); + self.q3.ToString(sb, tabs, index, delayed); + end; + + protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, c); + + end; + + ConvSyncQueueArray3 = sealed class(ConvQueueArrayBase3) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; + var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; + var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes()), prev_ev); + end; + + end; + ConvAsyncQueueArray3 = sealed class(ConvQueueArrayBase3) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop 2 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev), tsk, c.Native, main_dvc, cq)); + end; + + end; + +{$endregion [3]} + +{$region [4]} + +type + ConvQueueArrayBase4 = abstract class(HostQueue, TRes>) + protected q1: CommandQueue; + protected q2: CommandQueue; + protected q3: CommandQueue; + protected q4: CommandQueue; + protected f: (TInp1, TInp2, TInp3, TInp4, Context)->TRes; + + public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, Context)->TRes); + begin + self.q1 := q1; + self.q2 := q2; + self.q3 := q3; + self.q4 := q4; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + self.q1.RegisterWaitables(tsk, prev_hubs); + self.q2.RegisterWaitables(tsk, prev_hubs); + self.q3.RegisterWaitables(tsk, prev_hubs); + self.q4.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + self.q1.ToString(sb, tabs, index, delayed); + self.q2.ToString(sb, tabs, index, delayed); + self.q3.ToString(sb, tabs, index, delayed); + self.q4.ToString(sb, tabs, index, delayed); + end; + + protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, c); + + end; + + ConvSyncQueueArray4 = sealed class(ConvQueueArrayBase4) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; + var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; + var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; + var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes()), prev_ev); + end; + + end; + ConvAsyncQueueArray4 = sealed class(ConvQueueArrayBase4) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop 3 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev), tsk, c.Native, main_dvc, cq)); + end; + + end; + +{$endregion [4]} + +{$region [5]} + +type + ConvQueueArrayBase5 = abstract class(HostQueue, TRes>) + protected q1: CommandQueue; + protected q2: CommandQueue; + protected q3: CommandQueue; + protected q4: CommandQueue; + protected q5: CommandQueue; + protected f: (TInp1, TInp2, TInp3, TInp4, TInp5, Context)->TRes; + + public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; q5: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, TInp5, Context)->TRes); + begin + self.q1 := q1; + self.q2 := q2; + self.q3 := q3; + self.q4 := q4; + self.q5 := q5; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + self.q1.RegisterWaitables(tsk, prev_hubs); + self.q2.RegisterWaitables(tsk, prev_hubs); + self.q3.RegisterWaitables(tsk, prev_hubs); + self.q4.RegisterWaitables(tsk, prev_hubs); + self.q5.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + self.q1.ToString(sb, tabs, index, delayed); + self.q2.ToString(sb, tabs, index, delayed); + self.q3.ToString(sb, tabs, index, delayed); + self.q4.ToString(sb, tabs, index, delayed); + self.q5.ToString(sb, tabs, index, delayed); + end; + + protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, t.Item5, c); + + end; + + ConvSyncQueueArray5 = sealed class(ConvQueueArrayBase5) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; + var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; + var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; + var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; + var qr5 := q5.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr5.ev; + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes()), prev_ev); + end; + + end; + ConvAsyncQueueArray5 = sealed class(ConvQueueArrayBase5) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop 4 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr5 := q5.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev, qr5.ev), tsk, c.Native, main_dvc, cq)); + end; + + end; + +{$endregion [5]} + +{$region [6]} + +type + ConvQueueArrayBase6 = abstract class(HostQueue, TRes>) + protected q1: CommandQueue; + protected q2: CommandQueue; + protected q3: CommandQueue; + protected q4: CommandQueue; + protected q5: CommandQueue; + protected q6: CommandQueue; + protected f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, Context)->TRes; + + public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; q5: CommandQueue; q6: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, Context)->TRes); + begin + self.q1 := q1; + self.q2 := q2; + self.q3 := q3; + self.q4 := q4; + self.q5 := q5; + self.q6 := q6; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + self.q1.RegisterWaitables(tsk, prev_hubs); + self.q2.RegisterWaitables(tsk, prev_hubs); + self.q3.RegisterWaitables(tsk, prev_hubs); + self.q4.RegisterWaitables(tsk, prev_hubs); + self.q5.RegisterWaitables(tsk, prev_hubs); + self.q6.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + self.q1.ToString(sb, tabs, index, delayed); + self.q2.ToString(sb, tabs, index, delayed); + self.q3.ToString(sb, tabs, index, delayed); + self.q4.ToString(sb, tabs, index, delayed); + self.q5.ToString(sb, tabs, index, delayed); + self.q6.ToString(sb, tabs, index, delayed); + end; + + protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, t.Item5, t.Item6, c); + + end; + + ConvSyncQueueArray6 = sealed class(ConvQueueArrayBase6) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; + var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; + var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; + var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; + var qr5 := q5.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr5.ev; + var qr6 := q6.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr6.ev; + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes()), prev_ev); + end; + + end; + ConvAsyncQueueArray6 = sealed class(ConvQueueArrayBase6) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop 5 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr5 := q5.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr6 := q6.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev, qr5.ev, qr6.ev), tsk, c.Native, main_dvc, cq)); + end; + + end; + +{$endregion [6]} + +{$region [7]} + +type + ConvQueueArrayBase7 = abstract class(HostQueue, TRes>) + protected q1: CommandQueue; + protected q2: CommandQueue; + protected q3: CommandQueue; + protected q4: CommandQueue; + protected q5: CommandQueue; + protected q6: CommandQueue; + protected q7: CommandQueue; + protected f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, TInp7, Context)->TRes; + + public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; q5: CommandQueue; q6: CommandQueue; q7: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, TInp7, Context)->TRes); + begin + self.q1 := q1; + self.q2 := q2; + self.q3 := q3; + self.q4 := q4; + self.q5 := q5; + self.q6 := q6; + self.q7 := q7; + self.f := f; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + self.q1.RegisterWaitables(tsk, prev_hubs); + self.q2.RegisterWaitables(tsk, prev_hubs); + self.q3.RegisterWaitables(tsk, prev_hubs); + self.q4.RegisterWaitables(tsk, prev_hubs); + self.q5.RegisterWaitables(tsk, prev_hubs); + self.q6.RegisterWaitables(tsk, prev_hubs); + self.q7.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + self.q1.ToString(sb, tabs, index, delayed); + self.q2.ToString(sb, tabs, index, delayed); + self.q3.ToString(sb, tabs, index, delayed); + self.q4.ToString(sb, tabs, index, delayed); + self.q5.ToString(sb, tabs, index, delayed); + self.q6.ToString(sb, tabs, index, delayed); + self.q7.ToString(sb, tabs, index, delayed); + end; + + protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, t.Item5, t.Item6, t.Item7, c); + + end; + + ConvSyncQueueArray7 = sealed class(ConvQueueArrayBase7) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; + var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; + var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; + var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; + var qr5 := q5.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr5.ev; + var qr6 := q6.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr6.ev; + var qr7 := q7.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr7.ev; + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes(), qr7.GetRes()), prev_ev); + end; + + end; + ConvAsyncQueueArray7 = sealed class(ConvQueueArrayBase7) + + protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; + begin + if (prev_ev<>nil) and (prev_ev.count<>0) then loop 6 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); + var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr5 := q5.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr6 := q6.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + var qr7 := q7.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); + Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes(), qr7.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev, qr5.ev, qr6.ev, qr7.ev), tsk, c.Native, main_dvc, cq)); + end; + + end; + +{$endregion [7]} + +{$endregion Conv} + +{$region Utils} + +type + QueueArrayUtils = static class + + public static function FlattenQueueArray(inp: sequence of CommandQueueBase): array of CommandQueueBase; where T: ISimpleQueueArray; + begin + var enmr := inp.GetEnumerator; + if not enmr.MoveNext then raise new InvalidOperationException('Функции CombineSyncQueue/CombineAsyncQueue не могут принимать 0 очередей'); + + var res := new List; + while true do + begin + var curr := enmr.Current; + var next := enmr.MoveNext; + + if next then + begin + if curr is IConstQueue then continue; + if curr is ICastQueue(var cq) then curr := cq.GetQ; + end; + + if curr is T(var sqa) then + res.AddRange(sqa.GetQS) else + res += curr; + + if not next then break; + end; + + Result := res.ToArray; + end; + + public static function FlattenSyncQueueArray(inp: sequence of CommandQueueBase) := FlattenQueueArray&< ISimpleSyncQueueArray>(inp); + public static function FlattenAsyncQueueArray(inp: sequence of CommandQueueBase) := FlattenQueueArray&(inp); + + end; + +{$endregion Utils} + +function CommandQueueBase. AfterQueueSyncBase(q: CommandQueueBase) := q + self.Cast&; +function CommandQueueBase.AfterQueueAsyncBase(q: CommandQueueBase) := q * self.Cast&; + +static function CommandQueue.operator+(q1: CommandQueueBase; q2: CommandQueue) := new SimpleSyncQueueArray(QueueArrayUtils. FlattenSyncQueueArray(|q1, q2|)); +static function CommandQueue.operator*(q1: CommandQueueBase; q2: CommandQueue) := new SimpleAsyncQueueArray(QueueArrayUtils.FlattenAsyncQueueArray(|q1, q2|)); + +{$endregion +/*} + +{$region Multiusable} + +type + MultiusableCommandQueueHub = sealed partial class(MultiusableCommandQueueHubBase) + public q: CommandQueue; + public constructor(q: CommandQueue) := self.q := q; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public function OnNodeInvoked(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean): QueueRes; + begin + + var res_o: QueueResBase; + if tsk.mu_res.TryGetValue(self, res_o) then + Result := QueueRes&( res_o ) else + begin + Result := self.q.InvokeNewQ(tsk, c, main_dvc, need_ptr_qr, nil); + Result.can_set_ev := false; + tsk.mu_res[self] := Result; + end; + + Result.ev.Retain({$ifdef EventDebug}$'for all mu branches'{$endif}); + end; + + end; + + MultiusableCommandQueueNode = sealed class(CommandQueue) + public hub: MultiusableCommandQueueHub; + public constructor(hub: MultiusableCommandQueueHub) := self.hub := hub; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + Result := hub.OnNodeInvoked(tsk, c, main_dvc, need_ptr_qr); + if prev_ev<>nil then Result := Result.TrySetEv( prev_ev + Result.ev ); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + if prev_hubs.Add(hub) then hub.q.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + if hub.q.ToStringHeader(sb, index) then + delayed.Add(hub.q); + sb += #10; + end; + + end; + + MultiusableCommandQueueHub = sealed partial class(MultiusableCommandQueueHubBase) + + public function MakeNode: CommandQueue := + new MultiusableCommandQueueNode(self); + + end; + +function CommandQueueBase.MultiusableBase := self.Cast&.Multiusable() as object as Func; //ToDo #2221 +function CommandQueue.Multiusable: ()->CommandQueue := MultiusableCommandQueueHub&.Create(self).MakeNode; + +{$endregion Multiusable} + +{$region Wait} + +{$region WCQWaiter} + +type + WCQWaiter = abstract class + private markers: array of WaitMarkerBase; + + public constructor(markers: array of WaitMarkerBase); + begin + if markers.Length = 0 then raise new System.ArgumentException($'Wait очереди должны ожидать хотя бы одну очередь'); + for var i := 0 to markers.Length-1 do + if markers[i] = nil then + raise new ArgumentNullException($'Очередь [{i}] очереди из списка маркеров была nil'); + self.markers := markers; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public procedure RegisterWaitables(tsk: CLTaskBase) := + foreach var marker in markers do marker.RegisterWaiterTask(tsk); + + public function GetWaitEv(tsk: CLTaskBase; c: Context): UserEvent; abstract; + + private procedure ToString(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); + begin + sb.Append(#9, tabs); + sb += self.GetType.Name; + + if markers.Length=1 then + begin + sb += ' => '; + + var marker := markers[0]; + if marker.ToStringHeader(sb, index) then + delayed.Add( marker ); + + sb += #10; + end else + begin + sb += #10; + + foreach var marker in markers.Cast& do + begin + sb.Append(#9, tabs+1); + if marker.ToStringHeader(sb, index) then + delayed.Add ( marker ); + sb += #10; + end; + + end; + + end; + + end; + + WCQWaiterAll = sealed class(WCQWaiter) + + public function GetWaitEv(tsk: CLTaskBase; c: Context): UserEvent; override; + begin + var uev := tsk.MakeUserEvent(c.ntv + {$ifdef EventDebug}, $'WCQWaiterAll[{waitables.Length}]'{$endif} + ); + + var done := 0; + var total := markers.Length; + var done_lock := new object; + + for var i := 0 to markers.Length-1 do + markers[i].AddMWHandler(tsk, ()-> + begin + if uev.CanRemove then exit; + + lock done_lock do + begin + done += 1; + if done=total then + // Если uev.Abort вызовет между .CanRemove и этой строчкой - значит это было в отдельном потоке, + // т.е. в заведомо не_безопастном месте. А значит проверять тут - нет смысла + uev.SetStatus(CommandExecutionStatus.COMPLETE); + end; + + Result := true; + end); + + Result := uev; + end; + + end; + WCQWaiterAny = sealed class(WCQWaiter) + + public function GetWaitEv(tsk: CLTaskBase; c: Context): UserEvent; override; + begin + var uev := tsk.MakeUserEvent(c.ntv + {$ifdef EventDebug}, $'WCQWaiterAny[{waitables.Length}]'{$endif} + ); + + for var i := 0 to markers.Length-1 do + markers[i].AddMWHandler(tsk, ()->uev.SetStatus(CommandExecutionStatus.COMPLETE)); + + Result := uev; + end; + + end; + +{$endregion WCQWaiter} + +{$region ThenWait} + +type + CommandQueueThenWaitFor = sealed class(CommandQueue) + public q: CommandQueue; + public waiter: WCQWaiter; + + public constructor(q: CommandQueue; waiter: WCQWaiter); + begin + self.q := q; + self.waiter := waiter; + end; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + Result := q.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + Result := Result.TrySetEv( Result.ev + waiter.GetWaitEv(tsk, c) ); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + q.RegisterWaitables(tsk, prev_hubs); + waiter.RegisterWaitables(tsk); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + q.ToString(sb, tabs, index, delayed); + waiter.ToString(sb, tabs, index, delayed); + end; + + end; + +function CommandQueueBase.ThenWaitForAllBase(markers: sequence of WaitMarkerBase) := self.Cast&.ThenWaitForAll(markers); +function CommandQueueBase.ThenWaitForAnyBase(markers: sequence of WaitMarkerBase) := self.Cast&.ThenWaitForAny(markers); + +function CommandQueue.ThenWaitForAll(markers: sequence of WaitMarkerBase) := new CommandQueueThenWaitFor(self, new WCQWaiterAll(markers.ToArray)); +function CommandQueue.ThenWaitForAny(markers: sequence of WaitMarkerBase) := new CommandQueueThenWaitFor(self, new WCQWaiterAny(markers.ToArray)); + +{$endregion ThenWait} + +{$region WaitFor} + +type + CommandQueueWaitFor = sealed class(CommandQueue) + public waiter: WCQWaiter; + + public constructor(waiter: WCQWaiter) := + self.waiter := waiter; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + {$ifdef DEBUG} + if need_ptr_qr then raise new System.InvalidOperationException; + {$endif DEBUG} + var wait_ev := waiter.GetWaitEv(tsk, c); + Result := new QueueResConst(nil, prev_ev=nil ? wait_ev : prev_ev+wait_ev); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + waiter.RegisterWaitables(tsk); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + waiter.ToString(sb, tabs, index, delayed); + end; + + end; + +function WaitForAll(params markers: array of WaitMarkerBase) := WaitForAll(markers.AsEnumerable); +function WaitForAll( markers: sequence of WaitMarkerBase) := new CommandQueueWaitFor(new WCQWaiterAll(markers.ToArray)); + +function WaitForAny(params markers: array of WaitMarkerBase) := WaitForAny(markers.AsEnumerable); +function WaitForAny( markers: sequence of WaitMarkerBase) := new CommandQueueWaitFor(new WCQWaiterAny(markers.ToArray)); + +function WaitFor(marker: WaitMarkerBase) := WaitForAll(marker); + +{$endregion WaitFor} + +{$endregion Wait} + +{$endregion Queue converter's} + +{$region KernelArg} + +{$region Base} + +type + ISetableKernelArg = interface + procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); + end; + KernelArg = abstract partial class + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; abstract; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; + + end; + +{$endregion Base} + +{$region Const} + +{$region Base} + +type + ConstKernelArg = abstract class(KernelArg, ISetableKernelArg) + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override := + new QueueResConst(self, new EventList); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); abstract; + + end; + +{$endregion Base} + +{$region Buffer} + +type + KernelArgBuffer = sealed class(ConstKernelArg) + private b: Buffer; + + public constructor(b: Buffer) := self.b := b; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); override; + begin + b.InitIfNeed(c); + cl.SetKernelArg(k, ind, new UIntPtr(cl_mem.Size), b.ntv).RaiseIfError; + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(b); + sb += #10; + end; + + end; + +static function KernelArg.FromBuffer(b: Buffer) := new KernelArgBuffer(b); + +{$endregion Buffer} + +{$region Record} + +type + KernelArgRecord = sealed class(ConstKernelArg) + where TRecord: record; + private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); + + public constructor(val: TRecord) := self.val^ := val; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected procedure Finalize; override := + Marshal.FreeHGlobal(new IntPtr(val)); + + public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); override := + cl.SetKernelArg(k, ind, new UIntPtr(Marshal.SizeOf&), pointer(self.val)).RaiseIfError; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(val^); + sb += #10; + end; + + end; + +static function KernelArg.FromRecord(val: TRecord) := new KernelArgRecord(val); + +{$endregion Record} + +{$region Ptr} + +type + KernelArgPtr = sealed class(ConstKernelArg) + private ptr: IntPtr; + private sz: UIntPtr; + + public constructor(ptr: IntPtr; sz: UIntPtr); + begin + self.ptr := ptr; + self.sz := sz; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); override := + cl.SetKernelArg(k, ind, sz, pointer(ptr)).RaiseIfError; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(ptr); + sb += '['; + sb.Append(sz); + sb += ']'#10; + end; + + end; + +static function KernelArg.FromPtr(ptr: IntPtr; sz: UIntPtr) := new KernelArgPtr(ptr, sz); + +{$endregion Ptr} + +{$endregion Const} + +{$region Invokeable} + +{$region Base} + +type + InvokeableKernelArg = abstract class(KernelArg) end; + +{$endregion Base} + +{$region Buffer} + +type + KernelArgBufferCQ = sealed class(InvokeableKernelArg) + public q: CommandQueue; + public constructor(q: CommandQueue) := self.q := q; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override := + q.InvokeNewQ(tsk, c, main_dvc, false, nil).LazyQuickTransform(b->new KernelArgBuffer(b) as ISetableKernelArg); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + q.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + q.ToString(sb, tabs, index, delayed); + end; + + end; + +static function KernelArg.FromBufferCQ(bq: CommandQueue) := +new KernelArgBufferCQ(bq); + +{$endregion Buffer} + +{$region Record} + +type + KernelArgRecordQR = sealed class(ISetableKernelArg) + where TRecord: record; + public qr: QueueRes; + public constructor(qr: QueueRes) := self.qr := qr; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); + begin + var sz := new UIntPtr(Marshal.SizeOf&); + if qr is QueueResDelayedPtr(var pqr) then + cl.SetKernelArg(k, ind, sz, pointer(pqr.ptr)).RaiseIfError else + begin + var val := qr.GetRes; + cl.SetKernelArg(k, ind, sz, val).RaiseIfError; + end; + end; + + end; + KernelArgRecordCQ = sealed class(InvokeableKernelArg) + where TRecord: record; + public q: CommandQueue; + public constructor(q: CommandQueue) := self.q := q; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override; + begin + var prev_qr := q.InvokeNewQ(tsk, c, main_dvc, true, nil); + Result := new QueueResConst(new KernelArgRecordQR(prev_qr), prev_qr.ev); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + q.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + q.ToString(sb, tabs, index, delayed); + end; + + end; + +static function KernelArg.FromRecordCQ(valq: CommandQueue) := +new KernelArgRecordCQ(valq); + +{$endregion Record} + +{$region Ptr} + +type + KernelArgPtrCQ = sealed class(InvokeableKernelArg) + public ptr_q: CommandQueue; + public sz_q: CommandQueue; + public constructor(ptr_q: CommandQueue; sz_q: CommandQueue); + begin + self.ptr_q := ptr_q; + self.sz_q := sz_q; + end; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override; + begin + var ptr_qr := ptr_q.InvokeNewQ(tsk, c, main_dvc, false, nil); + var sz_qr := sz_q.InvokeNewQ(tsk, c, main_dvc, false, nil); + Result := new QueueResFunc(()->new KernelArgPtr(ptr_qr.GetRes, sz_qr.GetRes), ptr_qr.ev+sz_qr.ev); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr_q.RegisterWaitables(tsk, prev_hubs); + sz_q.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + ptr_q.ToString(sb, tabs, index, delayed); + sz_q.ToString(sb, tabs, index, delayed); + end; + + end; + +static function KernelArg.FromPtrCQ(ptr_q: CommandQueue; sz_q: CommandQueue) := +new KernelArgPtrCQ(ptr_q, sz_q); + +{$endregion Ptr} + +{$endregion Invokeable} + +{$endregion KernelArg} + +{$region GPUCommand} + +{$region Base} + +type + GPUCommand = abstract class + + protected function InvokeObj (o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; abstract; + protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; abstract; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; + + private function DisplayName: string; virtual := CommandQueueBase.DisplayNameForType(self.GetType); + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); abstract; + + private procedure ToString(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); + begin + sb.Append(#9, tabs); + sb += DisplayName; + self.ToStringImpl(sb, tabs+1, index, delayed); + end; + + end; + + BasicGPUCommand = abstract class(GPUCommand) + + private function DisplayName: string; override; + begin + Result := self.GetType.Name; + Result := Result.Remove(Result.IndexOf('`')); + end; + + end; + +{$endregion Base} + +{$region Queue} + +type + QueueCommand = sealed class(BasicGPUCommand) + public q: CommandQueueBase; + + public constructor(q: CommandQueueBase) := self.q := q; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList) := q.InvokeBase(tsk, c, main_dvc, false, cq, prev_ev).ev; + + protected function InvokeObj (o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, main_dvc, cq, prev_ev); + protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, main_dvc, cq, prev_ev); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + q.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + q.ToString(sb, tabs, index, delayed); + end; + + end; + +{$endregion Queue} + +{$region Proc} + +type + ProcCommand = sealed class(BasicGPUCommand) + public p: (T,Context)->(); + + public constructor(p: (T,Context)->()) := self.p := p; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected function InvokeObj(o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := + UserEvent.StartBackgroundWork(prev_ev, ()->p(o, c), c.ntv, tsk + {$ifdef EventDebug}, $'const body of {self.GetType}'{$endif} + ); + + protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override; + begin + var o_q_res := o_q().Invoke(tsk, c, main_dvc, false, cq, prev_ev); + Result := UserEvent.StartBackgroundWork(o_q_res.ev, ()->p(o_q_res.GetRes(), c), c.ntv, tsk + {$ifdef EventDebug}, $'queue body of {self.GetType}'{$endif} + ); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(p); + sb += #10; + end; + + end; + +{$endregion Proc} + +{$region Wait} + +type + WaitCommand = sealed class(BasicGPUCommand) + public waiter: WCQWaiter; + + public constructor(waiter: WCQWaiter) := self.waiter := waiter; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + private function Invoke(tsk: CLTaskBase; c: Context; prev_ev: EventList): EventList; + begin + var res := waiter.GetWaitEv(tsk, c); + Result := if prev_ev=nil then + res else prev_ev+res; + end; + + protected function InvokeObj (o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, prev_ev); + protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, prev_ev); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + waiter.RegisterWaitables(tsk); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + waiter.ToString(sb, tabs, index, delayed); + end; + + end; + +{$endregion Wait} + +{$endregion GPUCommand} + +{$region GPUCommandContainer} + +{$region Base} + +type + GPUCommandContainer = abstract partial class + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + end; + GPUCommandContainerCore = abstract class + private cc: GPUCommandContainer; + protected constructor(cc: GPUCommandContainer) := self.cc := cc; + private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; abstract; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); abstract; + private procedure ToString(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); + begin + sb.Append(#9, tabs); + + var tn := self.GetType.Name; + sb += tn.Remove(tn.IndexOf('`')); + + self.ToStringImpl(sb, tabs+1, index, delayed); + end; + + end; + + GPUCommandContainer = abstract partial class(CommandQueue) + protected core: GPUCommandContainerCore; + protected commands := new List>; + + protected procedure InitObj(obj: T; c: Context); virtual := exit; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override := + core.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + core.RegisterWaitables(tsk, prev_hubs); + foreach var comm in commands do comm.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + core.ToString(sb, tabs, index, delayed); + foreach var comm in commands do + comm.ToString(sb, tabs, index, delayed); + end; + + end; + +function AddCommand(cc: TContainer; comm: GPUCommand): TContainer; where TContainer: GPUCommandContainer; +begin + cc.commands += comm; + Result := cc; +end; + +{$endregion Base} + +{$region Core} + +type + CCCObj = sealed class(GPUCommandContainerCore) + public o: T; + + public constructor(cc: GPUCommandContainer; o: T); + begin + inherited Create(cc); + self.o := o; + end; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + var res_obj := self.o; + cc.InitObj(res_obj, c); + + foreach var comm in cc.commands do + prev_ev := comm.InvokeObj(res_obj, tsk, c, main_dvc, cq, prev_ev); + + Result := new QueueResConst(res_obj, prev_ev ?? new EventList); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(o); + sb += #10; + end; + + end; + + CCCQueue = sealed class(GPUCommandContainerCore) + public hub: MultiusableCommandQueueHub; + + public constructor(cc: GPUCommandContainer; q: CommandQueue); + begin + inherited Create(cc); + self.hub := new MultiusableCommandQueueHub(q); + end; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + var new_plug: ()->CommandQueue := hub.MakeNode; + // new_plub всегда делает mu ноду, а она не использует prev_ev + // это тут, чтобы хаб передал need_ptr_qr. Он делает это при первом Invoke + Result := new_plug().Invoke(tsk, c, main_dvc, need_ptr_qr, cq, nil); + + foreach var comm in cc.commands do + prev_ev := comm.InvokeQueue(new_plug, tsk, c, main_dvc, cq, prev_ev); + + Result := Result.TrySetEv( prev_ev ?? new EventList ); + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := + hub.q.RegisterWaitables(tsk, prev_hubs); + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + hub.q.ToString(sb, tabs, index, delayed); + end; + + end; + + GPUCommandContainer = abstract partial class + + protected constructor(o: T) := + self.core := new CCCObj(self, o); + + protected constructor(q: CommandQueue) := + self.core := new CCCQueue(self, q); + + end; + +{$endregion Core} + +{$region BufferCommandQueue} + +type + BufferCommandQueue = sealed partial class(GPUCommandContainer) + + {$region constructor's} + + protected procedure InitObj(obj: Buffer; c: Context); override := obj.InitIfNeed(c); + protected static function InitBuffer(b: Buffer; c: Context): Buffer; + begin + b.InitIfNeed(c); + Result := b; + end; + + {$endregion constructor's} + + end; + +static function KernelArg.operator implicit(bq: BufferCommandQueue): KernelArg := FromBufferCQ(bq); + +constructor BufferCommandQueue.Create(o: Buffer) := inherited; +constructor BufferCommandQueue.Create(q: CommandQueue) := inherited Create(q.ThenConvert(InitBuffer)); +constructor BufferCommandQueue.Create := inherited; + +{$region Special .Add's} + +function BufferCommandQueue.AddQueue(q: CommandQueueBase): BufferCommandQueue; +begin + Result := self; + if q is IConstQueue then raise new System.ArgumentException($'В .AddQueue нельзя передавать константные очереди'); + if q is ICastQueue(var cq) then q := cq.GetQ; + commands.Add( new QueueCommand(q) ); +end; + +function BufferCommandQueue.AddProc(p: Buffer->()) := AddCommand(self, new ProcCommand((o,c)->p(o))); +function BufferCommandQueue.AddProc(p: (Buffer, Context)->()) := AddCommand(self, new ProcCommand(p)); + +function BufferCommandQueue.AddWaitAll(params markers: array of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAll(markers.ToArray))); +function BufferCommandQueue.AddWaitAll(markers: sequence of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAll(markers.ToArray))); + +function BufferCommandQueue.AddWaitAny(params markers: array of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAny(markers.ToArray))); +function BufferCommandQueue.AddWaitAny(markers: sequence of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAny(markers.ToArray))); + +function BufferCommandQueue.AddWait(marker: WaitMarkerBase) := AddWaitAll(marker); + +{$endregion Special .Add's} + +{$endregion BufferCommandQueue} + +{$region KernelCommandQueue} + +type + KernelCommandQueue = sealed partial class(GPUCommandContainer) + + end; + +constructor KernelCommandQueue.Create(o: Kernel) := inherited; +constructor KernelCommandQueue.Create(q: CommandQueue) := inherited; +constructor KernelCommandQueue.Create := inherited; + +{$region Special .Add's} + +function KernelCommandQueue.AddQueue(q: CommandQueueBase): KernelCommandQueue; +begin + Result := self; + if q is IConstQueue then raise new System.ArgumentException($'В .AddQueue нельзя передавать константные очереди'); + if q is ICastQueue(var cq) then q := cq.GetQ; + commands.Add( new QueueCommand(q) ); +end; + +function KernelCommandQueue.AddProc(p: Kernel->()) := AddCommand(self, new ProcCommand((o,c)->p(o))); +function KernelCommandQueue.AddProc(p: (Kernel, Context)->()) := AddCommand(self, new ProcCommand(p)); + +function KernelCommandQueue.AddWaitAll(params markers: array of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAll(markers.ToArray))); +function KernelCommandQueue.AddWaitAll(markers: sequence of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAll(markers.ToArray))); + +function KernelCommandQueue.AddWaitAny(params markers: array of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAny(markers.ToArray))); +function KernelCommandQueue.AddWaitAny(markers: sequence of WaitMarkerBase) := AddCommand(self, new WaitCommand(new WCQWaiterAny(markers.ToArray))); + +function KernelCommandQueue.AddWait(marker: WaitMarkerBase) := AddWaitAll(marker); + +{$endregion Special .Add's} + +{$endregion KernelCommandQueue} + +{$endregion GPUCommandContainer} + +{$region Enqueueable's} + +{$region Core} + +type + IEnqueueable = interface + + function NeedThread: boolean; + + function ParamCountL1: integer; + function ParamCountL2: integer; + + function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (cl_command_queue, EventList, TInvData)->cl_event; + + end; + EnqueueableCore = static class + + private static function MakeEvList(exp_size: integer; start_ev: EventList): List; + begin + var need_start_ev := (start_ev<>nil) and (start_ev.count<>0); + Result := new List(exp_size + integer(need_start_ev)); + if need_start_ev then Result += start_ev; + end; + + public static function Invoke(q: TEnq; inv_data: TInvData; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; l1_start_ev, l2_start_ev: EventList): EventList; where TEnq: IEnqueueable; + begin + var need_thread := q.NeedThread; + + var evs_l1 := MakeEvList(q.ParamCountL1, l1_start_ev); // Ожидание, перед вызовом cl.Enqueue* + var evs_l2 := MakeEvList(q.ParamCountL2, l2_start_ev); // Ожидание, передаваемое в cl.Enqueue* + + var enq_f := q.InvokeParams(tsk, c, main_dvc, cq, evs_l1, evs_l2); + var ev_l1 := EventList.Combine(evs_l1, tsk, c.ntv, main_dvc, cq); + var ev_l2 := EventList.Combine(evs_l2, tsk, c.ntv, main_dvc, cq) ?? new EventList; + + NativeUtils.FixCQ(c.ntv, main_dvc, cq); + + if not need_thread and (ev_l1=nil) then + begin + var enq_ev := enq_f(cq, ev_l2, inv_data); + {$ifdef EventDebug} + EventDebug.RegisterEventRetain(enq_ev, $'Enq by {q.GetType}, waiting on [{ev_l2.evs?.JoinToString}]'); + {$endif EventDebug} + // 1. ev_l2 можно освобождать только после выполнения команды, ожидающей его + // 2. Если ивент из ev_l2 завершится с ошибкой - enq_ev скажет только что была ошибка в ev_l2, но не скажет какая + Result := ev_l2 + enq_ev; + end else + begin + var res_ev: UserEvent; + + // Асинхронное Enqueue, придётся пересоздать cq + var lcq := cq; + cq := cl_command_queue.Zero; + + if need_thread then + res_ev := UserEvent.StartBackgroundWork(ev_l1, ()-> + begin + enq_f(lcq, ev_l2, inv_data); + ev_l2.Release({$ifdef EventDebug}$'after using in blocking enq of {q.GetType}'{$endif}); + end, c.ntv, tsk{$ifdef EventDebug}, $'blocking enq of {q.GetType}, ev_l2 = [{ev_l2.evs?.JoinToString}]'{$endif}) else + begin + res_ev := tsk.MakeUserEvent(c.ntv + {$ifdef EventDebug}, $'{q.GetType}, temp for nested AttachCallback: [{ev_l1?.evs.JoinToString}], then [{ev_l2.evs?.JoinToString}]'{$endif} + ); + + //ВНИМАНИЕ "ev_l1=nil" не может случится, из за условий выше + ev_l1.AttachCallback(()-> + begin + ev_l1.Release({$ifdef EventDebug}$'after waiting before Enq of {q.GetType}'{$endif}); + var enq_ev := enq_f(lcq, ev_l2, inv_data); + {$ifdef EventDebug} + EventDebug.RegisterEventRetain(enq_ev, $'Enq by {q.GetType}, waiting on [{ev_l2.evs?.JoinToString}]'); + {$endif EventDebug} + var final_ev := ev_l2+enq_ev; + final_ev.AttachCallback(()-> + begin + final_ev.Release({$ifdef EventDebug}$'after waiting to set {res_ev.uev} of nested AttachCallback in Enq of {q.GetType}'{$endif}); + res_ev.SetStatus(CommandExecutionStatus.COMPLETE); + end, tsk, c.ntv, main_dvc, lcq{$ifdef EventDebug}, $'propagating Enq ev of {q.GetType} to res_ev: {res_ev.uev}'{$endif}); + end, tsk, c.ntv, main_dvc, lcq{$ifdef EventDebug}, $'calling Enq of {q.GetType}'{$endif}); + + end; + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + System.Threading.Tasks.Task.Run(()->tsk.AddErr(cl.ReleaseCommandQueue(lcq))); + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + Result := res_ev; + end; + + end; + + end; + +{$endregion Core} + +{$region GPUCommand} + +type + EnqueueableGPUCommandInvData = record + qr: QueueRes; + tsk: CLTaskBase; + c: Context; + end; + EnqueueableGPUCommand = abstract class(GPUCommand, IEnqueueable>) + + // Если это True - InvokeParamsImpl должен возращать (...)->cl_event.Zero + // Иначе останется ивент, который никто не удалил + public function NeedThread: boolean; virtual := false; + + public function ParamCountL1: integer; abstract; + public function ParamCountL2: integer; abstract; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (T, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; abstract; + public function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (cl_command_queue, EventList, EnqueueableGPUCommandInvData)->cl_event; + begin + var enq_f := InvokeParamsImpl(tsk, c, main_dvc, cq, evs_l1, evs_l2); + Result := (lcq, ev, data)->enq_f(data.qr.GetRes, lcq, data.tsk, data.c, ev); + end; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_qr: QueueRes; l2_start_ev: EventList): EventList; + begin + var inv_data: EnqueueableGPUCommandInvData; + inv_data.qr := prev_qr; + inv_data.tsk := tsk; + inv_data.c := c; + + Result := EnqueueableCore.Invoke(self, inv_data, tsk, c, main_dvc, cq, prev_qr.ev, l2_start_ev); + end; + + protected function InvokeObj(o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := + Invoke(tsk, c, main_dvc, cq, new QueueResConst(o, nil), prev_ev); + + protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := + Invoke(tsk, c, main_dvc, cq, o_q().Invoke(tsk, c, main_dvc, false, cq, prev_ev), nil); + + end; + +{$endregion GPUCommand} + +{$region GetCommand} + +type + EnqueueableGetCommandInvData = record + prev_qr: QueueRes; + tsk: CLTaskBase; + res_qr: QueueResDelayedBase; + end; + EnqueueableGetCommand = abstract class(CommandQueue, IEnqueueable>) + protected prev_commands: GPUCommandContainer; + + public constructor(prev_commands: GPUCommandContainer) := + self.prev_commands := prev_commands; + + // Если это True - InvokeParamsImpl должен возращать (...)->cl_event.Zero + // Иначе останется ивент, который никто не удалил + public function NeedThread: boolean; virtual := false; + + public function ParamCountL1: integer; abstract; + public function ParamCountL2: integer; abstract; + + public function ForcePtrQr: boolean; virtual := false; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (TObj, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; abstract; + public function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (cl_command_queue, EventList, EnqueueableGetCommandInvData)->cl_event; + begin + var enq_f := InvokeParamsImpl(tsk, c, main_dvc, cq, evs_l1, evs_l2); + Result := (lcq, ev, data)->enq_f(data.prev_qr.GetRes, lcq, data.tsk, ev, data.res_qr); + end; + + protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; + begin + var prev_qr := prev_commands.Invoke(tsk, c, main_dvc, false, cq, prev_ev); + + var inv_data: EnqueueableGetCommandInvData; + inv_data.prev_qr := prev_qr; + inv_data.tsk := tsk; + inv_data.res_qr := QueueResDelayedBase&.MakeNew(need_ptr_qr or ForcePtrQr); + + Result := inv_data.res_qr; + Result.ev := EnqueueableCore.Invoke(self, inv_data, tsk, c, main_dvc, cq, prev_qr.ev, nil); + end; + + end; + +{$endregion GetCommand} + +{$region Buffer} + +{$region Implicit} + +{$region 1#Write&Read} + +function Buffer.WriteData(ptr: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteData(ptr) as CommandQueue); + +function Buffer.ReadData(ptr: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadData(ptr) as CommandQueue); + +function Buffer.WriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteData(ptr, buff_offset, len) as CommandQueue); + +function Buffer.ReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadData(ptr, buff_offset, len) as CommandQueue); + +function Buffer.WriteData(ptr: pointer): Buffer := +WriteData(IntPtr(ptr)); + +function Buffer.ReadData(ptr: pointer): Buffer := +ReadData(IntPtr(ptr)); + +function Buffer.WriteData(ptr: pointer; buff_offset, len: CommandQueue): Buffer := +WriteData(IntPtr(ptr), buff_offset, len); + +function Buffer.ReadData(ptr: pointer; buff_offset, len: CommandQueue): Buffer := +ReadData(IntPtr(ptr), buff_offset, len); + +function Buffer.WriteValue(val: TRecord): Buffer := +WriteValue(val, 0); + +function Buffer.WriteValue(val: TRecord; buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteValue&(val, buff_offset) as CommandQueue); + +function Buffer.WriteValue(val: CommandQueue): Buffer := +WriteValue(val, 0); + +function Buffer.WriteValue(val: CommandQueue; buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteValue&(val, buff_offset) as CommandQueue); + +function Buffer.WriteArray1(a: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteArray1&(a) as CommandQueue); + +function Buffer.WriteArray2(a: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteArray2&(a) as CommandQueue); + +function Buffer.WriteArray3(a: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteArray3&(a) as CommandQueue); + +function Buffer.ReadArray1(a: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadArray1&(a) as CommandQueue); + +function Buffer.ReadArray2(a: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadArray2&(a) as CommandQueue); + +function Buffer.ReadArray3(a: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadArray3&(a) as CommandQueue); + +function Buffer.WriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteArray1&(a, a_offset, len, buff_offset) as CommandQueue); + +function Buffer.WriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteArray2&(a, a_offset1, a_offset2, len, buff_offset) as CommandQueue); + +function Buffer.WriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddWriteArray3&(a, a_offset1, a_offset2, a_offset3, len, buff_offset) as CommandQueue); + +function Buffer.ReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadArray1&(a, a_offset, len, buff_offset) as CommandQueue); + +function Buffer.ReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadArray2&(a, a_offset1, a_offset2, len, buff_offset) as CommandQueue); + +function Buffer.ReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddReadArray3&(a, a_offset1, a_offset2, a_offset3, len, buff_offset) as CommandQueue); + +{$endregion 1#Write&Read} + +{$region 2#Fill} + +function Buffer.FillData(ptr: CommandQueue; pattern_len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddFillData(ptr, pattern_len) as CommandQueue); + +function Buffer.FillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddFillData(ptr, pattern_len, buff_offset, len) as CommandQueue); + +function Buffer.FillValue(val: TRecord): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val) as CommandQueue); + +function Buffer.FillValue(val: TRecord; buff_offset, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val, buff_offset, len) as CommandQueue); + +function Buffer.FillValue(val: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val) as CommandQueue); + +function Buffer.FillValue(val: CommandQueue; buff_offset, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val, buff_offset, len) as CommandQueue); + +{$endregion 2#Fill} + +{$region 3#Copy} + +function Buffer.CopyTo(b: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddCopyTo(b) as CommandQueue); + +function Buffer.CopyForm(b: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddCopyForm(b) as CommandQueue); + +function Buffer.CopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddCopyTo(b, from_pos, to_pos, len) as CommandQueue); + +function Buffer.CopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer := +Context.Default.SyncInvoke(self.NewQueue.AddCopyForm(b, from_pos, to_pos, len) as CommandQueue); + +{$endregion 3#Copy} + +{$region Get} + +function Buffer.GetData: IntPtr := +Context.Default.SyncInvoke(self.NewQueue.AddGetData as CommandQueue); + +function Buffer.GetData(buff_offset, len: CommandQueue): IntPtr := +Context.Default.SyncInvoke(self.NewQueue.AddGetData(buff_offset, len) as CommandQueue); + +function Buffer.GetValue: TRecord := +GetValue&(0); + +function Buffer.GetValue(buff_offset: CommandQueue): TRecord := +Context.Default.SyncInvoke(self.NewQueue.AddGetValue&(buff_offset) as CommandQueue); + +function Buffer.GetArray1: array of TRecord := +Context.Default.SyncInvoke(self.NewQueue.AddGetArray1& as CommandQueue); + +function Buffer.GetArray1(len: CommandQueue): array of TRecord := +Context.Default.SyncInvoke(self.NewQueue.AddGetArray1&(len) as CommandQueue); + +function Buffer.GetArray2(len1,len2: CommandQueue): array[,] of TRecord := +Context.Default.SyncInvoke(self.NewQueue.AddGetArray2&(len1, len2) as CommandQueue); + +function Buffer.GetArray3(len1,len2,len3: CommandQueue): array[,,] of TRecord := +Context.Default.SyncInvoke(self.NewQueue.AddGetArray3&(len1, len2, len3) as CommandQueue); + +{$endregion Get} + +{$endregion Implicit} + +{$region Explicit} + +{$region 1#Write&Read} + +{$region WriteDataAutoSize} + +type + BufferCommandWriteDataAutoSize = sealed class(EnqueueableGPUCommand) + private ptr: CommandQueue; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(ptr: CommandQueue); + begin + self.ptr := ptr; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(ptr_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var ptr := ptr_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.NON_BLOCKING, + UIntPtr.Zero, o.Size, + ptr, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'ptr: '; + ptr.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteDataAutoSize} + +function BufferCommandQueue.AddWriteData(ptr: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteDataAutoSize(ptr)); + +{$region ReadDataAutoSize} + +type + BufferCommandReadDataAutoSize = sealed class(EnqueueableGPUCommand) + private ptr: CommandQueue; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(ptr: CommandQueue); + begin + self.ptr := ptr; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(ptr_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var ptr := ptr_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.NON_BLOCKING, + UIntPtr.Zero, o.Size, + ptr, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'ptr: '; + ptr.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadDataAutoSize} + +function BufferCommandQueue.AddReadData(ptr: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadDataAutoSize(ptr)); + +{$region WriteData} + +type + BufferCommandWriteData = sealed class(EnqueueableGPUCommand) + private ptr: CommandQueue; + private buff_offset: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 3; + public function ParamCountL2: integer; override := 0; + + public constructor(ptr: CommandQueue; buff_offset, len: CommandQueue); + begin + self. ptr := ptr; + self.buff_offset := buff_offset; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(ptr_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var ptr := ptr_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.NON_BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len), + ptr, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'ptr: '; + ptr.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteData} + +function BufferCommandQueue.AddWriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteData(ptr, buff_offset, len)); + +{$region ReadData} + +type + BufferCommandReadData = sealed class(EnqueueableGPUCommand) + private ptr: CommandQueue; + private buff_offset: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 3; + public function ParamCountL2: integer; override := 0; + + public constructor(ptr: CommandQueue; buff_offset, len: CommandQueue); + begin + self. ptr := ptr; + self.buff_offset := buff_offset; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(ptr_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var ptr := ptr_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.NON_BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len), + ptr, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'ptr: '; + ptr.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadData} + +function BufferCommandQueue.AddReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadData(ptr, buff_offset, len)); + +function BufferCommandQueue.AddWriteData(ptr: pointer): BufferCommandQueue := +AddWriteData(IntPtr(ptr)); + +function BufferCommandQueue.AddReadData(ptr: pointer): BufferCommandQueue := +AddReadData(IntPtr(ptr)); + +function BufferCommandQueue.AddWriteData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue := +AddWriteData(IntPtr(ptr), buff_offset, len); + +function BufferCommandQueue.AddReadData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue := +AddReadData(IntPtr(ptr), buff_offset, len); + +function BufferCommandQueue.AddWriteValue(val: TRecord): BufferCommandQueue := +AddWriteValue(val, 0); + +{$region WriteValue} + +type + BufferCommandWriteValue = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); + private buff_offset: CommandQueue; + + protected procedure Finalize; override; + begin + Marshal.FreeHGlobal(new IntPtr(val)); + end; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(val: TRecord; buff_offset: CommandQueue); + begin + self. val^ := val; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var buff_offset := buff_offset_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.NON_BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(Marshal.SizeOf&), + new IntPtr(val), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'val: '; + sb.Append(val^); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteValue} + +function BufferCommandQueue.AddWriteValue(val: TRecord; buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteValue(val, buff_offset)); + +function BufferCommandQueue.AddWriteValue(val: CommandQueue): BufferCommandQueue := +AddWriteValue(val, 0); + +{$region WriteValueQ} + +type + BufferCommandWriteValueQ = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private val: CommandQueue; + private buff_offset: CommandQueue; + + public function ParamCountL1: integer; override := 2; + public function ParamCountL2: integer; override := 1; + + public constructor(val: CommandQueue; buff_offset: CommandQueue); + begin + self. val := val; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var val_qr := val.Invoke (tsk, c, main_dvc, True, cq, nil); (val_qr is QueueResDelayedPtr&?evs_l2:evs_l1).Add(val_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var val := val_qr.ToPtr; + var buff_offset := buff_offset_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.NON_BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(Marshal.SizeOf&), + new IntPtr(val.GetPtr), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + var val_hnd := GCHandle.Alloc(val); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + val_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + val.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'val: '; + val.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteValueQ} + +function BufferCommandQueue.AddWriteValue(val: CommandQueue; buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteValueQ(val, buff_offset)); + +{$region WriteArray1AutoSize} + +type + BufferCommandWriteArray1AutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue); + begin + self.a := a; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.BLOCKING, + UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), + a[0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteArray1AutoSize} + +function BufferCommandQueue.AddWriteArray1(a: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteArray1AutoSize(a)); + +{$region WriteArray2AutoSize} + +type + BufferCommandWriteArray2AutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue); + begin + self.a := a; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.BLOCKING, + UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), + a[0,0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteArray2AutoSize} + +function BufferCommandQueue.AddWriteArray2(a: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteArray2AutoSize(a)); + +{$region WriteArray3AutoSize} + +type + BufferCommandWriteArray3AutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue); + begin + self.a := a; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.BLOCKING, + UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), + a[0,0,0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteArray3AutoSize} + +function BufferCommandQueue.AddWriteArray3(a: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteArray3AutoSize(a)); + +{$region ReadArray1AutoSize} + +type + BufferCommandReadArray1AutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue); + begin + self.a := a; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), + a[0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadArray1AutoSize} + +function BufferCommandQueue.AddReadArray1(a: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadArray1AutoSize(a)); + +{$region ReadArray2AutoSize} + +type + BufferCommandReadArray2AutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue); + begin + self.a := a; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), + a[0,0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadArray2AutoSize} + +function BufferCommandQueue.AddReadArray2(a: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadArray2AutoSize(a)); + +{$region ReadArray3AutoSize} + +type + BufferCommandReadArray3AutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue); + begin + self.a := a; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), + a[0,0,0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadArray3AutoSize} + +function BufferCommandQueue.AddReadArray3(a: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadArray3AutoSize(a)); + +{$region WriteArray1} + +type + BufferCommandWriteArray1 = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + private a_offset: CommandQueue; + private len: CommandQueue; + private buff_offset: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue; a_offset, len, buff_offset: CommandQueue); + begin + self. a := a; + self. a_offset := a_offset; + self. len := len; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + var a_offset_qr := a_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + var a_offset := a_offset_qr.GetRes; + var len := len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), + a[a_offset], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + a_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset: '; + a_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteArray1} + +function BufferCommandQueue.AddWriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteArray1(a, a_offset, len, buff_offset)); + +{$region WriteArray2} + +type + BufferCommandWriteArray2 = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + private a_offset1: CommandQueue; + private a_offset2: CommandQueue; + private len: CommandQueue; + private buff_offset: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 5; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue); + begin + self. a := a; + self. a_offset1 := a_offset1; + self. a_offset2 := a_offset2; + self. len := len; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset1_qr.ev); + var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset2_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + var a_offset1 := a_offset1_qr.GetRes; + var a_offset2 := a_offset2_qr.GetRes; + var len := len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), + a[a_offset1,a_offset2], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + a_offset1.RegisterWaitables(tsk, prev_hubs); + a_offset2.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset1: '; + a_offset1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset2: '; + a_offset2.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteArray2} + +function BufferCommandQueue.AddWriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteArray2(a, a_offset1, a_offset2, len, buff_offset)); + +{$region WriteArray3} + +type + BufferCommandWriteArray3 = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + private a_offset1: CommandQueue; + private a_offset2: CommandQueue; + private a_offset3: CommandQueue; + private len: CommandQueue; + private buff_offset: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 6; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue); + begin + self. a := a; + self. a_offset1 := a_offset1; + self. a_offset2 := a_offset2; + self. a_offset3 := a_offset3; + self. len := len; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset1_qr.ev); + var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset2_qr.ev); + var a_offset3_qr := a_offset3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset3_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + var a_offset1 := a_offset1_qr.GetRes; + var a_offset2 := a_offset2_qr.GetRes; + var a_offset3 := a_offset3_qr.GetRes; + var len := len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + + cl.EnqueueWriteBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), + a[a_offset1,a_offset2,a_offset3], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + a_offset1.RegisterWaitables(tsk, prev_hubs); + a_offset2.RegisterWaitables(tsk, prev_hubs); + a_offset3.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset1: '; + a_offset1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset2: '; + a_offset2.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset3: '; + a_offset3.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion WriteArray3} + +function BufferCommandQueue.AddWriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandWriteArray3(a, a_offset1, a_offset2, a_offset3, len, buff_offset)); + +{$region ReadArray1} + +type + BufferCommandReadArray1 = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + private a_offset: CommandQueue; + private len: CommandQueue; + private buff_offset: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue; a_offset, len, buff_offset: CommandQueue); + begin + self. a := a; + self. a_offset := a_offset; + self. len := len; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + var a_offset_qr := a_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + var a_offset := a_offset_qr.GetRes; + var len := len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), + a[a_offset], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + a_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset: '; + a_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadArray1} + +function BufferCommandQueue.AddReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadArray1(a, a_offset, len, buff_offset)); + +{$region ReadArray2} + +type + BufferCommandReadArray2 = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + private a_offset1: CommandQueue; + private a_offset2: CommandQueue; + private len: CommandQueue; + private buff_offset: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 5; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue); + begin + self. a := a; + self. a_offset1 := a_offset1; + self. a_offset2 := a_offset2; + self. len := len; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset1_qr.ev); + var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset2_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + var a_offset1 := a_offset1_qr.GetRes; + var a_offset2 := a_offset2_qr.GetRes; + var len := len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), + a[a_offset1,a_offset2], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + a_offset1.RegisterWaitables(tsk, prev_hubs); + a_offset2.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset1: '; + a_offset1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset2: '; + a_offset2.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadArray2} + +function BufferCommandQueue.AddReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadArray2(a, a_offset1, a_offset2, len, buff_offset)); + +{$region ReadArray3} + +type + BufferCommandReadArray3 = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private a: CommandQueue; + private a_offset1: CommandQueue; + private a_offset2: CommandQueue; + private a_offset3: CommandQueue; + private len: CommandQueue; + private buff_offset: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 6; + public function ParamCountL2: integer; override := 0; + + public constructor(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue); + begin + self. a := a; + self. a_offset1 := a_offset1; + self. a_offset2 := a_offset2; + self. a_offset3 := a_offset3; + self. len := len; + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(a_qr.ev); + var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset1_qr.ev); + var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset2_qr.ev); + var a_offset3_qr := a_offset3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(a_offset3_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var a := a_qr.GetRes; + var a_offset1 := a_offset1_qr.GetRes; + var a_offset2 := a_offset2_qr.GetRes; + var a_offset3 := a_offset3_qr.GetRes; + var len := len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), + a[a_offset1,a_offset2,a_offset3], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + a.RegisterWaitables(tsk, prev_hubs); + a_offset1.RegisterWaitables(tsk, prev_hubs); + a_offset2.RegisterWaitables(tsk, prev_hubs); + a_offset3.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'a: '; + a.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset1: '; + a_offset1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset2: '; + a_offset2.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'a_offset3: '; + a_offset3.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion ReadArray3} + +function BufferCommandQueue.AddReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandReadArray3(a, a_offset1, a_offset2, a_offset3, len, buff_offset)); + +{$endregion 1#Write&Read} + +{$region 2#Fill} + +{$region FillDataAutoSize} + +type + BufferCommandFillDataAutoSize = sealed class(EnqueueableGPUCommand) + private ptr: CommandQueue; + private pattern_len: CommandQueue; + + public function ParamCountL1: integer; override := 2; + public function ParamCountL2: integer; override := 0; + + public constructor(ptr: CommandQueue; pattern_len: CommandQueue); + begin + self. ptr := ptr; + self.pattern_len := pattern_len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(ptr_qr.ev); + var pattern_len_qr := pattern_len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(pattern_len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var ptr := ptr_qr.GetRes; + var pattern_len := pattern_len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueFillBuffer( + cq, o.ntv, + ptr, new UIntPtr(pattern_len), + UIntPtr.Zero, o.Size, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr.RegisterWaitables(tsk, prev_hubs); + pattern_len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'ptr: '; + ptr.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'pattern_len: '; + pattern_len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion FillDataAutoSize} + +function BufferCommandQueue.AddFillData(ptr: CommandQueue; pattern_len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandFillDataAutoSize(ptr, pattern_len)); + +{$region FillData} + +type + BufferCommandFillData = sealed class(EnqueueableGPUCommand) + private ptr: CommandQueue; + private pattern_len: CommandQueue; + private buff_offset: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue); + begin + self. ptr := ptr; + self.pattern_len := pattern_len; + self.buff_offset := buff_offset; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(ptr_qr.ev); + var pattern_len_qr := pattern_len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(pattern_len_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var ptr := ptr_qr.GetRes; + var pattern_len := pattern_len_qr.GetRes; + var buff_offset := buff_offset_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueFillBuffer( + cq, o.ntv, + ptr, new UIntPtr(pattern_len), + new UIntPtr(buff_offset), new UIntPtr(len), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + ptr.RegisterWaitables(tsk, prev_hubs); + pattern_len.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'ptr: '; + ptr.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'pattern_len: '; + pattern_len.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion FillData} + +function BufferCommandQueue.AddFillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandFillData(ptr, pattern_len, buff_offset, len)); + +{$region FillValueAutoSize} + +type + BufferCommandFillValueAutoSize = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); + + protected procedure Finalize; override; + begin + Marshal.FreeHGlobal(new IntPtr(val)); + end; + + public function ParamCountL1: integer; override := 0; + public function ParamCountL2: integer; override := 0; + + public constructor(val: TRecord); + begin + self.val^ := val; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + + Result := (o, cq, tsk, c, evs)-> + begin + var res_ev: cl_event; + + cl.EnqueueFillBuffer( + cq, o.ntv, + new IntPtr(val), new UIntPtr(Marshal.SizeOf&), + UIntPtr.Zero, o.Size, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'val: '; + sb.Append(val^); + + end; + + end; + +{$endregion FillValueAutoSize} + +function BufferCommandQueue.AddFillValue(val: TRecord): BufferCommandQueue := +AddCommand(self, new BufferCommandFillValueAutoSize(val)); + +{$region FillValue} + +type + BufferCommandFillValue = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); + private buff_offset: CommandQueue; + private len: CommandQueue; + + protected procedure Finalize; override; + begin + Marshal.FreeHGlobal(new IntPtr(val)); + end; + + public function ParamCountL1: integer; override := 2; + public function ParamCountL2: integer; override := 0; + + public constructor(val: TRecord; buff_offset, len: CommandQueue); + begin + self. val^ := val; + self.buff_offset := buff_offset; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(buff_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var buff_offset := buff_offset_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueFillBuffer( + cq, o.ntv, + new IntPtr(val), new UIntPtr(Marshal.SizeOf&), + new UIntPtr(buff_offset), new UIntPtr(len), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + buff_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'val: '; + sb.Append(val^); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion FillValue} + +function BufferCommandQueue.AddFillValue(val: TRecord; buff_offset, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandFillValue(val, buff_offset, len)); + +{$region FillValueAutoSizeQ} + +type + BufferCommandFillValueAutoSizeQ = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private val: CommandQueue; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 1; + + public constructor(val: CommandQueue); + begin + self.val := val; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var val_qr := val.Invoke (tsk, c, main_dvc, True, cq, nil); (val_qr is QueueResDelayedPtr&?evs_l2:evs_l1).Add(val_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var val := val_qr.ToPtr; + var res_ev: cl_event; + + cl.EnqueueFillBuffer( + cq, o.ntv, + new IntPtr(val.GetPtr), new UIntPtr(Marshal.SizeOf&), + UIntPtr.Zero, o.Size, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + var val_hnd := GCHandle.Alloc(val); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + val_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + val.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'val: '; + val.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion FillValueAutoSizeQ} + +function BufferCommandQueue.AddFillValue(val: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandFillValueAutoSizeQ(val)); + +{$region FillValueQ} + +type + BufferCommandFillValueQ = sealed class(EnqueueableGPUCommand) + where TRecord: record; + private val: CommandQueue; + private buff_offset: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 3; + public function ParamCountL2: integer; override := 1; + + public constructor(val: CommandQueue; buff_offset, len: CommandQueue); + begin + self. val := val; + self.buff_offset := buff_offset; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var val_qr := val.Invoke (tsk, c, main_dvc, True, cq, nil); (val_qr is QueueResDelayedPtr&?evs_l2:evs_l1).Add(val_qr.ev); + var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(buff_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var val := val_qr.ToPtr; + var buff_offset := buff_offset_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueFillBuffer( + cq, o.ntv, + new IntPtr(val.GetPtr), new UIntPtr(Marshal.SizeOf&), + new UIntPtr(buff_offset), new UIntPtr(len), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + var val_hnd := GCHandle.Alloc(val); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + val_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + val.RegisterWaitables(tsk, prev_hubs); + buff_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'val: '; + val.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion FillValueQ} + +function BufferCommandQueue.AddFillValue(val: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandFillValueQ(val, buff_offset, len)); + +{$endregion 2#Fill} + +{$region 3#Copy} + +{$region CopyToAutoSize} + +type + BufferCommandCopyToAutoSize = sealed class(EnqueueableGPUCommand) + private b: CommandQueue; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(b: CommandQueue); + begin + self.b := b; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(b_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var b := b_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueCopyBuffer( + cq, o.ntv,b.ntv, + UIntPtr.Zero, UIntPtr.Zero, + o.Size64); override; + begin + b.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'b: '; + b.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion CopyToAutoSize} + +function BufferCommandQueue.AddCopyTo(b: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandCopyToAutoSize(b)); + +{$region CopyFormAutoSize} + +type + BufferCommandCopyFormAutoSize = sealed class(EnqueueableGPUCommand) + private b: CommandQueue; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(b: CommandQueue); + begin + self.b := b; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(b_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var b := b_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueCopyBuffer( + cq, b.ntv,o.ntv, + UIntPtr.Zero, UIntPtr.Zero, + o.Size64); override; + begin + b.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'b: '; + b.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion CopyFormAutoSize} + +function BufferCommandQueue.AddCopyForm(b: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandCopyFormAutoSize(b)); + +{$region CopyTo} + +type + BufferCommandCopyTo = sealed class(EnqueueableGPUCommand) + private b: CommandQueue; + private from_pos: CommandQueue; + private to_pos: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(b: CommandQueue; from_pos, to_pos, len: CommandQueue); + begin + self. b := b; + self.from_pos := from_pos; + self. to_pos := to_pos; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(b_qr.ev); + var from_pos_qr := from_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(from_pos_qr.ev); + var to_pos_qr := to_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(to_pos_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var b := b_qr.GetRes; + var from_pos := from_pos_qr.GetRes; + var to_pos := to_pos_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueCopyBuffer( + cq, o.ntv,b.ntv, + new UIntPtr(from_pos), new UIntPtr(to_pos), + new UIntPtr(len), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + b.RegisterWaitables(tsk, prev_hubs); + from_pos.RegisterWaitables(tsk, prev_hubs); + to_pos.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'b: '; + b.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'from_pos: '; + from_pos.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'to_pos: '; + to_pos.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion CopyTo} + +function BufferCommandQueue.AddCopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandCopyTo(b, from_pos, to_pos, len)); + +{$region CopyForm} + +type + BufferCommandCopyForm = sealed class(EnqueueableGPUCommand) + private b: CommandQueue; + private from_pos: CommandQueue; + private to_pos: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(b: CommandQueue; from_pos, to_pos, len: CommandQueue); + begin + self. b := b; + self.from_pos := from_pos; + self. to_pos := to_pos; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(b_qr.ev); + var from_pos_qr := from_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(from_pos_qr.ev); + var to_pos_qr := to_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(to_pos_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, c, evs)-> + begin + var b := b_qr.GetRes; + var from_pos := from_pos_qr.GetRes; + var to_pos := to_pos_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueCopyBuffer( + cq, b.ntv,o.ntv, + new UIntPtr(from_pos), new UIntPtr(to_pos), + new UIntPtr(len), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + b.RegisterWaitables(tsk, prev_hubs); + from_pos.RegisterWaitables(tsk, prev_hubs); + to_pos.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'b: '; + b.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'from_pos: '; + from_pos.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'to_pos: '; + to_pos.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion CopyForm} + +function BufferCommandQueue.AddCopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue := +AddCommand(self, new BufferCommandCopyForm(b, from_pos, to_pos, len)); + +{$endregion 3#Copy} + +{$region Get} + +{$region GetDataAutoSize} + +type + BufferCommandGetDataAutoSize = sealed class(EnqueueableGetCommand) + + public function ParamCountL1: integer; override := 0; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue); + begin + inherited Create(ccq); + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + + Result := (o, cq, tsk, evs, own_qr)-> + begin + var res_ev: cl_event; + + var res := Marshal.AllocHGlobal(IntPtr(pointer(o.Size))); own_qr.SetRes(res); + //ToDo А что если результат уже получен и освобождёт сдедующей .ThenConvert + // - Вообще .WhenError тут (и в +1 месте) - говнокод + tsk.WhenError((tsk,err)->Marshal.FreeHGlobal(res)); + cl.EnqueueReadBuffer( + cq, o.Native, Bool.NON_BLOCKING, + UIntPtr.Zero, o.Size, + res, + evs.count, evs.evs, res_ev + ); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override := sb += #10; + + end; + +{$endregion GetDataAutoSize} + +function BufferCommandQueue.AddGetData: CommandQueue := +new BufferCommandGetDataAutoSize(self) as CommandQueue; + +{$region GetData} + +type + BufferCommandGetData = sealed class(EnqueueableGetCommand) + private buff_offset: CommandQueue; + private len: CommandQueue; + + public function ParamCountL1: integer; override := 2; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue; buff_offset, len: CommandQueue); + begin + inherited Create(ccq); + self.buff_offset := buff_offset; + self. len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(buff_offset_qr.ev); + var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, evs, own_qr)-> + begin + var buff_offset := buff_offset_qr.GetRes; + var len := len_qr.GetRes; + var res_ev: cl_event; + + var res := Marshal.AllocHGlobal(IntPtr(pointer(o.Size))); own_qr.SetRes(res); + tsk.WhenError((tsk,err)->Marshal.FreeHGlobal(res)); + cl.EnqueueReadBuffer( + cq, o.Native, Bool.NON_BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(len), + res, + evs.count, evs.evs, res_ev + ).RaiseIfError; + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + buff_offset.RegisterWaitables(tsk, prev_hubs); + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion GetData} + +function BufferCommandQueue.AddGetData(buff_offset, len: CommandQueue): CommandQueue := +new BufferCommandGetData(self, buff_offset, len) as CommandQueue; + +function BufferCommandQueue.AddGetValue: CommandQueue := +AddGetValue&(0); + +{$region GetValue} + +type + BufferCommandGetValue = sealed class(EnqueueableGetCommand) + where TRecord: record; + private buff_offset: CommandQueue; + + public function ForcePtrQr: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue; buff_offset: CommandQueue); + begin + inherited Create(ccq); + self.buff_offset := buff_offset; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(buff_offset_qr.ev); + + Result := (o, cq, tsk, evs, own_qr)-> + begin + var buff_offset := buff_offset_qr.GetRes; + var res_ev: cl_event; + + cl.EnqueueReadBuffer( + cq, o.Native, Bool.NON_BLOCKING, + new UIntPtr(buff_offset), new UIntPtr(Marshal.SizeOf&), + new IntPtr((own_qr as QueueResDelayedPtr).ptr), + evs.count, evs.evs, res_ev + ).RaiseIfError; + + var own_qr_hnd := GCHandle.Alloc(own_qr); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + own_qr_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + buff_offset.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'buff_offset: '; + buff_offset.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion GetValue} + +function BufferCommandQueue.AddGetValue(buff_offset: CommandQueue): CommandQueue := +new BufferCommandGetValue(self, buff_offset) as CommandQueue; + +{$region GetArray1AutoSize} + +type + BufferCommandGetArray1AutoSize = sealed class(EnqueueableGetCommand) + where TRecord: record; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 0; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue); + begin + inherited Create(ccq); + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + + Result := (o, cq, tsk, evs, own_qr)-> + begin + + var len := o.Size64 div Marshal.SizeOf&; + var res := new TRecord[len]; own_qr.SetRes(res); + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(0), new UIntPtr(len * Marshal.SizeOf&), + res[0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override := sb += #10; + + end; + +{$endregion GetArray1AutoSize} + +function BufferCommandQueue.AddGetArray1: CommandQueue := +new BufferCommandGetArray1AutoSize(self) as CommandQueue; + +{$region GetArray1} + +type + BufferCommandGetArray1 = sealed class(EnqueueableGetCommand) + where TRecord: record; + private len: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 1; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue; len: CommandQueue); + begin + inherited Create(ccq); + self.len := len; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + var len_qr := len.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(len_qr.ev); + + Result := (o, cq, tsk, evs, own_qr)-> + begin + var len := len_qr.GetRes; + + var res := new TRecord[len]; own_qr.SetRes(res); + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(0), new UIntPtr(int64(len) * Marshal.SizeOf&), + res[0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + len.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'len: '; + len.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion GetArray1} + +function BufferCommandQueue.AddGetArray1(len: CommandQueue): CommandQueue := +new BufferCommandGetArray1(self, len) as CommandQueue; + +{$region GetArray2} + +type + BufferCommandGetArray2 = sealed class(EnqueueableGetCommand) + where TRecord: record; + private len1: CommandQueue; + private len2: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 2; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue; len1,len2: CommandQueue); + begin + inherited Create(ccq); + self.len1 := len1; + self.len2 := len2; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + var len1_qr := len1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(len1_qr.ev); + var len2_qr := len2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len2_qr.ev); + + Result := (o, cq, tsk, evs, own_qr)-> + begin + var len1 := len1_qr.GetRes; + var len2 := len2_qr.GetRes; + + var res := new TRecord[len1,len2]; own_qr.SetRes(res); + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(0), new UIntPtr(int64(len1)*len2 * Marshal.SizeOf&), + res[0,0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + len1.RegisterWaitables(tsk, prev_hubs); + len2.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'len1: '; + len1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len2: '; + len2.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion GetArray2} + +function BufferCommandQueue.AddGetArray2(len1,len2: CommandQueue): CommandQueue := +new BufferCommandGetArray2(self, len1, len2) as CommandQueue; + +{$region GetArray3} + +type + BufferCommandGetArray3 = sealed class(EnqueueableGetCommand) + where TRecord: record; + private len1: CommandQueue; + private len2: CommandQueue; + private len3: CommandQueue; + + public function NeedThread: boolean; override := true; + + public function ParamCountL1: integer; override := 3; + public function ParamCountL2: integer; override := 0; + + public constructor(ccq: BufferCommandQueue; len1,len2,len3: CommandQueue); + begin + inherited Create(ccq); + self.len1 := len1; + self.len2 := len2; + self.len3 := len3; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; + begin + var len1_qr := len1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(len1_qr.ev); + var len2_qr := len2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len2_qr.ev); + var len3_qr := len3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(len3_qr.ev); + + Result := (o, cq, tsk, evs, own_qr)-> + begin + var len1 := len1_qr.GetRes; + var len2 := len2_qr.GetRes; + var len3 := len3_qr.GetRes; + + var res := new TRecord[len1,len2,len3]; own_qr.SetRes(res); + cl.EnqueueReadBuffer( + cq, o.Native, Bool.BLOCKING, + new UIntPtr(0), new UIntPtr(int64(len1)*len2*len3 * Marshal.SizeOf&), + res[0,0,0], + evs.count, evs.evs, IntPtr.Zero + ).RaiseIfError; + + Result := cl_event.Zero; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + len1.RegisterWaitables(tsk, prev_hubs); + len2.RegisterWaitables(tsk, prev_hubs); + len3.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'len1: '; + len1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len2: '; + len2.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'len3: '; + len3.ToString(sb, tabs, index, delayed, false); + + end; + + end; + +{$endregion GetArray3} + +function BufferCommandQueue.AddGetArray3(len1,len2,len3: CommandQueue): CommandQueue := +new BufferCommandGetArray3(self, len1, len2, len3) as CommandQueue; + +{$endregion Get} + +{$endregion Explicit} + +{$endregion Buffer} + +{$region Kernel} + +{$region Implicit} + +{$region 1#Exec} + +function Kernel.Exec1(sz1: CommandQueue; params args: array of KernelArg): Kernel := +Context.Default.SyncInvoke(self.NewQueue.AddExec1(sz1, args) as CommandQueue); + +function Kernel.Exec2(sz1,sz2: CommandQueue; params args: array of KernelArg): Kernel := +Context.Default.SyncInvoke(self.NewQueue.AddExec2(sz1, sz2, args) as CommandQueue); + +function Kernel.Exec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): Kernel := +Context.Default.SyncInvoke(self.NewQueue.AddExec3(sz1, sz2, sz3, args) as CommandQueue); + +function Kernel.Exec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): Kernel := +Context.Default.SyncInvoke(self.NewQueue.AddExec(global_work_offset, global_work_size, local_work_size, args) as CommandQueue); + +{$endregion 1#Exec} + +{$endregion Implicit} + +{$region Explicit} + +{$region 1#Exec} + +{$region Exec1} + +type + KernelCommandExec1 = sealed class(EnqueueableGPUCommand) + private sz1: CommandQueue; + private args: array of KernelArg; + + public function ParamCountL1: integer; override := 2; + public function ParamCountL2: integer; override := 0; + + public constructor(sz1: CommandQueue; params args: array of KernelArg); + begin + self. sz1 := sz1; + self.args := args; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var sz1_qr := sz1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(sz1_qr.ev); + var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1.Add(Result.ev); end); + + Result := (o, cq, tsk, c, evs)-> + begin + var sz1 := sz1_qr.GetRes; + var args := args_qr.ConvertAll(temp1->temp1.GetRes); + var res_ev: cl_event; + + o.UseExclusiveNative(ntv-> + begin + + for var i := 0 to args.Length-1 do + args[i].SetArg(ntv, i, c); + + cl.EnqueueNDRangeKernel( + cq, ntv, 1, + nil, + new UIntPtr[](new UIntPtr(sz1)), + nil, + evs.count, evs.evs, res_ev + ); + + cl.RetainKernel(ntv).RaiseIfError; + var args_hnd := GCHandle.Alloc(args); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + cl.ReleaseKernel(ntv).RaiseIfError(); + args_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + end); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + sz1.RegisterWaitables(tsk, prev_hubs); + foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'sz1: '; + sz1.ToString(sb, tabs, index, delayed, false); + + for var i := 0 to args.Length-1 do + begin + sb.Append(#9, tabs); + sb += 'args['; + sb.Append(i); + sb += ']: '; + args[i].ToString(sb, tabs, index, delayed, false); + end; + + end; + + end; + +{$endregion Exec1} + +function KernelCommandQueue.AddExec1(sz1: CommandQueue; params args: array of KernelArg): KernelCommandQueue := +AddCommand(self, new KernelCommandExec1(sz1, args)); + +{$region Exec2} + +type + KernelCommandExec2 = sealed class(EnqueueableGPUCommand) + private sz1: CommandQueue; + private sz2: CommandQueue; + private args: array of KernelArg; + + public function ParamCountL1: integer; override := 3; + public function ParamCountL2: integer; override := 0; + + public constructor(sz1,sz2: CommandQueue; params args: array of KernelArg); + begin + self. sz1 := sz1; + self. sz2 := sz2; + self.args := args; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var sz1_qr := sz1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(sz1_qr.ev); + var sz2_qr := sz2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(sz2_qr.ev); + var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1.Add(Result.ev); end); + + Result := (o, cq, tsk, c, evs)-> + begin + var sz1 := sz1_qr.GetRes; + var sz2 := sz2_qr.GetRes; + var args := args_qr.ConvertAll(temp1->temp1.GetRes); + var res_ev: cl_event; + + o.UseExclusiveNative(ntv-> + begin + + for var i := 0 to args.Length-1 do + args[i].SetArg(ntv, i, c); + + cl.EnqueueNDRangeKernel( + cq, ntv, 2, + nil, + new UIntPtr[](new UIntPtr(sz1),new UIntPtr(sz2)), + nil, + evs.count, evs.evs, res_ev + ); + + cl.RetainKernel(ntv).RaiseIfError; + var args_hnd := GCHandle.Alloc(args); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + cl.ReleaseKernel(ntv).RaiseIfError(); + args_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + end); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + sz1.RegisterWaitables(tsk, prev_hubs); + sz2.RegisterWaitables(tsk, prev_hubs); + foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'sz1: '; + sz1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'sz2: '; + sz2.ToString(sb, tabs, index, delayed, false); + + for var i := 0 to args.Length-1 do + begin + sb.Append(#9, tabs); + sb += 'args['; + sb.Append(i); + sb += ']: '; + args[i].ToString(sb, tabs, index, delayed, false); + end; + + end; + + end; + +{$endregion Exec2} + +function KernelCommandQueue.AddExec2(sz1,sz2: CommandQueue; params args: array of KernelArg): KernelCommandQueue := +AddCommand(self, new KernelCommandExec2(sz1, sz2, args)); + +{$region Exec3} + +type + KernelCommandExec3 = sealed class(EnqueueableGPUCommand) + private sz1: CommandQueue; + private sz2: CommandQueue; + private sz3: CommandQueue; + private args: array of KernelArg; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg); + begin + self. sz1 := sz1; + self. sz2 := sz2; + self. sz3 := sz3; + self.args := args; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var sz1_qr := sz1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(sz1_qr.ev); + var sz2_qr := sz2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(sz2_qr.ev); + var sz3_qr := sz3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(sz3_qr.ev); + var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1.Add(Result.ev); end); + + Result := (o, cq, tsk, c, evs)-> + begin + var sz1 := sz1_qr.GetRes; + var sz2 := sz2_qr.GetRes; + var sz3 := sz3_qr.GetRes; + var args := args_qr.ConvertAll(temp1->temp1.GetRes); + var res_ev: cl_event; + + o.UseExclusiveNative(ntv-> + begin + + for var i := 0 to args.Length-1 do + args[i].SetArg(ntv, i, c); + + cl.EnqueueNDRangeKernel( + cq, ntv, 3, + nil, + new UIntPtr[](new UIntPtr(sz1),new UIntPtr(sz2),new UIntPtr(sz3)), + nil, + evs.count, evs.evs, res_ev + ); + + cl.RetainKernel(ntv).RaiseIfError; + var args_hnd := GCHandle.Alloc(args); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + cl.ReleaseKernel(ntv).RaiseIfError(); + args_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + end); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + sz1.RegisterWaitables(tsk, prev_hubs); + sz2.RegisterWaitables(tsk, prev_hubs); + sz3.RegisterWaitables(tsk, prev_hubs); + foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'sz1: '; + sz1.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'sz2: '; + sz2.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'sz3: '; + sz3.ToString(sb, tabs, index, delayed, false); + + for var i := 0 to args.Length-1 do + begin + sb.Append(#9, tabs); + sb += 'args['; + sb.Append(i); + sb += ']: '; + args[i].ToString(sb, tabs, index, delayed, false); + end; + + end; + + end; + +{$endregion Exec3} + +function KernelCommandQueue.AddExec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): KernelCommandQueue := +AddCommand(self, new KernelCommandExec3(sz1, sz2, sz3, args)); + +{$region Exec} + +type + KernelCommandExec = sealed class(EnqueueableGPUCommand) + private global_work_offset: CommandQueue; + private global_work_size: CommandQueue; + private local_work_size: CommandQueue; + private args: array of KernelArg; + + public function ParamCountL1: integer; override := 4; + public function ParamCountL2: integer; override := 0; + + public constructor(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg); + begin + self.global_work_offset := global_work_offset; + self. global_work_size := global_work_size; + self. local_work_size := local_work_size; + self. args := args; + end; + private constructor := raise new System.InvalidOperationException; + + protected function InvokeParamsImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; + begin + var global_work_offset_qr := global_work_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1.Add(global_work_offset_qr.ev); + var global_work_size_qr := global_work_size.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(global_work_size_qr.ev); + var local_work_size_qr := local_work_size.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1.Add(local_work_size_qr.ev); + var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1.Add(Result.ev); end); + + Result := (o, cq, tsk, c, evs)-> + begin + var global_work_offset := global_work_offset_qr.GetRes; + var global_work_size := global_work_size_qr.GetRes; + var local_work_size := local_work_size_qr.GetRes; + var args := args_qr.ConvertAll(temp1->temp1.GetRes); + var res_ev: cl_event; + + o.UseExclusiveNative(ntv-> + begin + + for var i := 0 to args.Length-1 do + args[i].SetArg(ntv, i, c); + + cl.EnqueueNDRangeKernel( + cq, ntv, global_work_size.Length, + global_work_offset, + global_work_size, + local_work_size, + evs.count, evs.evs, res_ev + ); + + cl.RetainKernel(ntv).RaiseIfError; + var args_hnd := GCHandle.Alloc(args); + + EventList.AttachFinallyCallback(res_ev, ()-> + begin + cl.ReleaseKernel(ntv).RaiseIfError(); + args_hnd.Free; + end, tsk, false{$ifdef EventDebug}, nil{$endif}); + end); + + Result := res_ev; + end; + + end; + + protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; + begin + global_work_offset.RegisterWaitables(tsk, prev_hubs); + global_work_size.RegisterWaitables(tsk, prev_hubs); + local_work_size.RegisterWaitables(tsk, prev_hubs); + foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); + end; + + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += #10; + + sb.Append(#9, tabs); + sb += 'global_work_offset: '; + global_work_offset.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'global_work_size: '; + global_work_size.ToString(sb, tabs, index, delayed, false); + + sb.Append(#9, tabs); + sb += 'local_work_size: '; + local_work_size.ToString(sb, tabs, index, delayed, false); + + for var i := 0 to args.Length-1 do + begin + sb.Append(#9, tabs); + sb += 'args['; + sb.Append(i); + sb += ']: '; + args[i].ToString(sb, tabs, index, delayed, false); + end; + + end; + + end; + +{$endregion Exec} + +function KernelCommandQueue.AddExec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): KernelCommandQueue := +AddCommand(self, new KernelCommandExec(global_work_offset, global_work_size, local_work_size, args)); + +{$endregion 1#Exec} + +{$endregion Explicit} + +{$endregion Kernel} + +{$endregion Enqueueable's} + +{$region Global subprograms} + {$region HFQ/HPQ} type @@ -390,6 +9553,13 @@ type protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; + private procedure ToStringImpl(sb: StringBuilder; tabs: integer; index: Dictionary; delayed: HashSet); override; + begin + sb += ' => '; + sb.Append(f); + sb += #10; + end; + end; CommandQueueHostFunc = sealed class(CommandQueueHostQueueBaseT>) @@ -419,37 +9589,6 @@ new CommandQueueHostProc(p); {$endregion HFQ/HPQ} -{$region WaitFor} - -type - CommandQueueWaitFor = sealed class(CommandQueue) - public waiter: WCQWaiter; - - public constructor(waiter: WCQWaiter) := - self.waiter := waiter; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - if need_ptr_qr then new System.InvalidOperationException; - var wait_ev := waiter.GetWaitEv(tsk, c); - Result := new QueueResConst(nil, prev_ev=nil ? wait_ev : prev_ev+wait_ev); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - waiter.RegisterWaitables(tsk); - - end; - -function WaitForAll(params qs: array of CommandQueueBase) := WaitForAll(qs.AsEnumerable); -function WaitForAll(qs: sequence of CommandQueueBase) := new CommandQueueWaitFor(new WCQWaiterAll(qs.ToArray)); - -function WaitForAny(params qs: array of CommandQueueBase) := WaitForAny(qs.AsEnumerable); -function WaitForAny(qs: sequence of CommandQueueBase) := new CommandQueueWaitFor(new WCQWaiterAny(qs.ToArray)); - -function WaitFor(q: CommandQueueBase) := WaitForAll(q); - -{$endregion WaitFor} - {$region CombineQueue's} {$region Sync} @@ -562,4 +9701,6 @@ function CombineAsyncQueue7 - -//ToDo Подумать как об этом можно написать в справке (или не в справке): -// - ReadValue отсутствует -// --- В объяснении KernelArg из указателя всё уже сказано -// --- Надо только как то объединить, чтоб текст был не только про KernelArg... -// - FillArray отсутствует -// --- Проблема в том, что нет блокирующего варианта FillArray -// --- Вообще в теории можно написать отдельную мелкую неуправляемую .dll и $resource её -// --- Но это жесть сколько усложнений ради 1 метода... - -//ToDo А что если вещи, которые могут привести к утечкам памяти при ThreadAbortException (как конструктор контекста) сувать в finally пустого try? -// - Вообще, поидее, должен быть более красивый способ добиться того же... Что то с контрактами? -// - Обязательно сравнить скорость, перед тем как применять... - -//ToDo Buffer переименовать в GPUMem -//ToDo И добавить типы как GPUArray - наверное с методом вроде .Flush, для более эффективной записи -// -//ToDo Инициалию буфера из BufferCommandQueue перенести в, собственно, вызовы GPUCommand.Invoke -// - И там же вызывать GPUArray.Flush - -//ToDo Можно же сохранять неуправляемые очереди в список внутри CLTask, и затем использовать несколько раз -// - И почему я раньше об этом не подумал... - -//ToDo В тестеровщике, в тестах ошибок, в текстах ошибок - постоянно меняются номера лямбд... -// - Наверное стоит захардкодить в тестировщик игнор числа после "<>lambda", и так же для контейнера лямбды - -//ToDo Заполнение Platform.All сейчас вылетит на компе с 0 платформ... -// - Сразу не забыть исправить описание - -//ToDo Всё же стоит добавить .ThenUse - аналог .ThenConvert, не изменяющий значение, а только использующий - -//ToDo IWaitQueue.CancelWait -//ToDo WaitAny(aborter, WaitAll(...)); -// - Что случится с WaitAll если aborter будет первым? -// - Очереди переданные в Wait - вообще не запускаются так -// - Поэтому я и думал про что то типа CancelWait -// - А вообще лучше разрешить выполнять Wait внутри другого Wait -// - И заодно проверить чтобы Abort работало на Wait-ы -// - А вообще всё не то - это костыли -// - Надо специально разрешить передавать какой то маркер аборта -// - И только в WaitAll, другим Wait-ам это не нужно -// - Или можно забыть про всё это и сделать+использовать AbortQueue чтоб убивать и Wait-ы, и всё остальное - -//ToDo Проверки и кидания исключений перед всеми cl.*, чтобы выводить норм сообщения об ошибках -// - В том числе проверки с помощью BlittableHelper - -//ToDo Создание SubDevice из cl_device_id - -//ToDo Очереди-маркеры для Wait-очередей -// - чтобы не приходилось использовать константные для этого - -//ToDo Очередь-обработчик ошибок -// - .HandleExceptions -// - Сделать легко, надо только вставить свой промежуточный CLTaskBase -// - Единственное - для Wait очереди надо хранить так же оригинальный CLTaskBase -//ToDo И какой то аналог try-finally -// - .ThenFinally ? -//ToDo Раздел справки про обработку ошибок -// - Написать что аналог try-finally стоит использовать на Wait-маркерах для потоко-безопастности -// -//ToDo Когда будут очереди-обработчики - удалить ивенты CLTask-ов. Они, по сути, ограниченная версия. -// - И использование их тут изнутри - в целом говнокод... - -//ToDo Синхронные (с припиской Fast, а может Quick) варианты всего работающего по принципу HostQueue -// -//ToDo И асинхронные умнее запускать - помнить значение, указывающее можно ли выполнить их синхронно -// - Может даже можно синхронно выполнить "HPQ(...)+HPQ(...)", в некоторых случаях? -//ToDo Enqueueabl-ы вызывают .Invoke для первого параметра и .InvokeNewQ для остальных -// - А что если все параметры кроме последнего - константы? -// - Надо как то умнее это обрабатывать -//ToDo И сделать наконец нормальный класс-контейнер состояния очереди, параметрами всё не передашь - -//ToDo CommmandQueueBase.ToString для дебага -// - так же дублирующий protected метод (tabs: integer; index: Dictionary) - -//ToDo .Cycle(integer) -//ToDo .Cycle // бесконечность циклов -//ToDo .CycleWhile(***->boolean) -// - Возможность передать свой обработчик ошибок как Exception->Exception -//ToDo В продолжение Cycle: Однако всё ещё остаётся проблема - как сделать ветвление? -// - И если уже делать - стоит сделать и метод CQ.ThenIf(res->boolean; if_true, if_false: CQ) -//ToDo И ещё - AbortQueue, который, по сути, может использоваться как exit, continue или break, если с обработчиками ошибок -// - Или может метод MarkerQueue.Abort? - -//ToDo Интегрировать профайлинг очередей - -//ToDo Перепродумать SubBuffer, в случае перевыделения основного буфера - он плохо себя ведёт... - -//ToDo Может всё же сделать защиту от дурака для "q.AddQueue(q)"? -// - И в справке тогда убрать параграф... - -//=================================== -// Сделать когда-нибуть: - -//ToDo Пройтись по всем функциям OpenCL, посмотреть функционал каких не доступен из OpenCLABC -// - clGetKernelWorkGroupInfo - свойства кернела на определённом устройстве - -{$endregion ToDo} - -{$region Bugs} - -//ToDo Issue компилятора: -//ToDo https://github.com/pascalabcnet/pascalabcnet/issues/{id} -// - #1981 -// - #2145 -// - #2221 -// - #2289 -// - #2290 - -//ToDo Баги NVidia -//ToDo https://developer.nvidia.com/nvidia_bug/{id} -// - NV#3035203 - -{$endregion} - -{$region Debug}{$ifdef DEBUG} - -{ $define EventDebug} // регистрация всех cl.RetainEvent и cl.ReleaseEvent - -{$endif DEBUG}{$endregion Debug} - -interface - -uses System; -uses System.Threading; -uses System.Runtime.InteropServices; -uses System.Collections.ObjectModel; - -uses OpenCL; - -type - - {$region Properties} - - {$region Base} - - NtvPropertiesBase = abstract class - protected ntv: TNtv; - public constructor(ntv: TNtv) := self.ntv := ntv; - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure GetSizeImpl(id: TInfo; var sz: UIntPtr); abstract; - protected procedure GetValImpl(id: TInfo; sz: UIntPtr; var res: byte); abstract; - - protected function GetSize(id: TInfo): UIntPtr; - begin GetSizeImpl(id, Result); end; - - protected procedure FillPtr(id: TInfo; sz: UIntPtr; ptr: IntPtr) := - GetValImpl(id, sz, PByte(pointer(ptr))^); - protected procedure FillVal(id: TInfo; sz: UIntPtr; var res: T) := - GetValImpl(id, sz, PByte(pointer(@res))^); - - protected function GetVal(id: TInfo): T; - begin FillVal(id, new UIntPtr(Marshal.SizeOf&), Result); end; - protected function GetValArr(id: TInfo): array of T; - begin - var sz := GetSize(id); - Result := new T[uint64(sz) div Marshal.SizeOf&]; - - if Result.Length<>0 then - FillVal(id, sz, Result[0]); - - end; - protected function GetValArrArr(id: TInfo; szs: array of UIntPtr): array of array of T; - type PT = ^T; - begin - if szs.Length=0 then - begin - SetLength(Result,0); - exit; - end; - - var res := new IntPtr[szs.Length]; - SetLength(Result, szs.Length); - - for var i := 0 to szs.Length-1 do res[i] := Marshal.AllocHGlobal(IntPtr(pointer(szs[i]))); - try - - FillVal(id, new UIntPtr(szs.Length*Marshal.SizeOf&), res[0]); - - var tsz := Marshal.SizeOf&; - for var i := 0 to szs.Length-1 do - begin - Result[i] := new T[uint64(szs[i]) div tsz]; - //ToDo более эффективное копирование - for var i2 := 0 to Result[i].Length-1 do - Result[i][i2] := PT(pointer(res[i]+tsz*i2))^; - end; - - finally - for var i := 0 to szs.Length-1 do Marshal.FreeHGlobal(res[i]); - end; - - end; - - {$region GetInt} - - private function GetIntPtr(id: TInfo) := GetVal&(id); - - private function GetUInt32(id: TInfo) := GetVal&(id); - private function GetUInt64(id: TInfo) := GetVal&(id); - private function GetUIntPtr(id: TInfo) := GetVal&(id); - - {$endregion GetInt} - - {$region GetIntArr} - - private function GetByteArr(id: TInfo) := GetValArr&(id); - private function GetUIntPtrArr(id: TInfo) := GetValArr&(id); - - private function GetByteArrArr(id: TInfo; szs: array of UIntPtr) := GetValArrArr&(id, szs); - - {$endregion GetIntArr} - - {$region GetString} - - private function GetString(id: TInfo): string; - begin - var sz := GetSize(id); - - var str_ptr := Marshal.AllocHGlobal(IntPtr(pointer(sz))); - try - FillPtr(id, sz, str_ptr); - Result := Marshal.PtrToStringAnsi(str_ptr); - finally - Marshal.FreeHGlobal(str_ptr); - end; - - end; - - {$endregion GetString} - - {$region GetBoolean} - - private function GetBoolean(id: TInfo) := GetVal&(id).val <> 0; - - {$endregion GetBoolean} - - end; - - {$endregion Base} - - {$region Platform} - - PlatformProperties = sealed class(NtvPropertiesBase) - - private static function clGetSize(platform: cl_platform_id; param_name: PlatformInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; - external 'opencl.dll' name 'clGetPlatformInfo'; - private static function clGetVal(platform: cl_platform_id; param_name: PlatformInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; - external 'opencl.dll' name 'clGetPlatformInfo'; - - protected procedure GetSizeImpl(id: PlatformInfo; var sz: UIntPtr); override := - clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; - protected procedure GetValImpl(id: PlatformInfo; sz: UIntPtr; var res: byte); override := - clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; - - public property Profile: String read GetString(PlatformInfo.PLATFORM_PROFILE); - public property Version: String read GetString(PlatformInfo.PLATFORM_VERSION); - public property Name: String read GetString(PlatformInfo.PLATFORM_NAME); - public property Vendor: String read GetString(PlatformInfo.PLATFORM_VENDOR); - public property Extensions: String read GetString(PlatformInfo.PLATFORM_EXTENSIONS); - public property HostTimerResolution: UInt64 read GetUInt64(PlatformInfo.PLATFORM_HOST_TIMER_RESOLUTION); - - end; - - {$endregion Platform} - - {$region Device} - - DeviceProperties = sealed class(NtvPropertiesBase) - - private static function clGetSize(device: cl_device_id; param_name: DeviceInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; - external 'opencl.dll' name 'clGetDeviceInfo'; - private static function clGetVal(device: cl_device_id; param_name: DeviceInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; - external 'opencl.dll' name 'clGetDeviceInfo'; - - protected procedure GetSizeImpl(id: DeviceInfo; var sz: UIntPtr); override := - clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; - protected procedure GetValImpl(id: DeviceInfo; sz: UIntPtr; var res: byte); override := - clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; - - private function GetDeviceType(id: DeviceInfo) := GetVal&(id); - private function GetDeviceFPConfig(id: DeviceInfo) := GetVal&(id); - private function GetDeviceMemCacheType(id: DeviceInfo) := GetVal&(id); - private function GetDeviceLocalMemType(id: DeviceInfo) := GetVal&(id); - private function GetDeviceExecCapabilities(id: DeviceInfo) := GetVal&(id); - private function GetCommandQueueProperties(id: DeviceInfo) := GetVal&(id); - private function GetDeviceAffinityDomain(id: DeviceInfo) := GetVal&(id); - private function GetDeviceSVMCapabilities(id: DeviceInfo) := GetVal&(id); - - private function GetDevicePartitionPropertyArr(id: DeviceInfo) := GetValArr&(id); - - public property &Type: DeviceType read GetDeviceType (DeviceInfo.DEVICE_TYPE); - public property VendorId: UInt32 read GetUInt32 (DeviceInfo.DEVICE_VENDOR_ID); - public property MaxComputeUnits: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_COMPUTE_UNITS); - public property MaxWorkItemDimensions: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_WORK_ITEM_DIMENSIONS); - public property MaxWorkItemSizes: array of UIntPtr read GetUIntPtrArr (DeviceInfo.DEVICE_MAX_WORK_ITEM_SIZES); - public property MaxWorkGroupSize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_MAX_WORK_GROUP_SIZE); - public property PreferredVectorWidthChar: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_CHAR); - public property PreferredVectorWidthShort: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_SHORT); - public property PreferredVectorWidthInt: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_INT); - public property PreferredVectorWidthLong: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_LONG); - public property PreferredVectorWidthFloat: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_FLOAT); - public property PreferredVectorWidthDouble: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE); - public property PreferredVectorWidthHalf: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_VECTOR_WIDTH_HALF); - public property NativeVectorWidthChar: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_CHAR); - public property NativeVectorWidthShort: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_SHORT); - public property NativeVectorWidthInt: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_INT); - public property NativeVectorWidthLong: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_LONG); - public property NativeVectorWidthFloat: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_FLOAT); - public property NativeVectorWidthDouble: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_DOUBLE); - public property NativeVectorWidthHalf: UInt32 read GetUInt32 (DeviceInfo.DEVICE_NATIVE_VECTOR_WIDTH_HALF); - public property MaxClockFrequency: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_CLOCK_FREQUENCY); - public property AddressBits: UInt32 read GetUInt32 (DeviceInfo.DEVICE_ADDRESS_BITS); - public property MaxMemAllocSize: UInt64 read GetUInt64 (DeviceInfo.DEVICE_MAX_MEM_ALLOC_SIZE); - public property ImageSupport: Boolean read GetBoolean (DeviceInfo.DEVICE_IMAGE_SUPPORT); - public property MaxReadImageArgs: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_READ_IMAGE_ARGS); - public property MaxWriteImageArgs: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_WRITE_IMAGE_ARGS); - public property MaxReadWriteImageArgs: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_READ_WRITE_IMAGE_ARGS); - public property IlVersion: String read GetString (DeviceInfo.DEVICE_IL_VERSION); - public property Image2dMaxWidth: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE2D_MAX_WIDTH); - public property Image2dMaxHeight: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE2D_MAX_HEIGHT); - public property Image3dMaxWidth: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE3D_MAX_WIDTH); - public property Image3dMaxHeight: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE3D_MAX_HEIGHT); - public property Image3dMaxDepth: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE3D_MAX_DEPTH); - public property ImageMaxBufferSize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE_MAX_BUFFER_SIZE); - public property ImageMaxArraySize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_IMAGE_MAX_ARRAY_SIZE); - public property MaxSamplers: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_SAMPLERS); - public property ImagePitchAlignment: UInt32 read GetUInt32 (DeviceInfo.DEVICE_IMAGE_PITCH_ALIGNMENT); - public property ImageBaseAddressAlignment: UInt32 read GetUInt32 (DeviceInfo.DEVICE_IMAGE_BASE_ADDRESS_ALIGNMENT); - public property MaxPipeArgs: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_PIPE_ARGS); - public property PipeMaxActiveReservations: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PIPE_MAX_ACTIVE_RESERVATIONS); - public property PipeMaxPacketSize: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PIPE_MAX_PACKET_SIZE); - public property MaxParameterSize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_MAX_PARAMETER_SIZE); - public property MemBaseAddrAlign: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MEM_BASE_ADDR_ALIGN); - public property SingleFpConfig: DeviceFPConfig read GetDeviceFPConfig (DeviceInfo.DEVICE_SINGLE_FP_CONFIG); - public property DoubleFpConfig: DeviceFPConfig read GetDeviceFPConfig (DeviceInfo.DEVICE_DOUBLE_FP_CONFIG); - public property GlobalMemCacheType: DeviceMemCacheType read GetDeviceMemCacheType (DeviceInfo.DEVICE_GLOBAL_MEM_CACHE_TYPE); - public property GlobalMemCachelineSize: UInt32 read GetUInt32 (DeviceInfo.DEVICE_GLOBAL_MEM_CACHELINE_SIZE); - public property GlobalMemCacheSize: UInt64 read GetUInt64 (DeviceInfo.DEVICE_GLOBAL_MEM_CACHE_SIZE); - public property GlobalMemSize: UInt64 read GetUInt64 (DeviceInfo.DEVICE_GLOBAL_MEM_SIZE); - public property MaxConstantBufferSize: UInt64 read GetUInt64 (DeviceInfo.DEVICE_MAX_CONSTANT_BUFFER_SIZE); - public property MaxConstantArgs: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_CONSTANT_ARGS); - public property MaxGlobalVariableSize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_MAX_GLOBAL_VARIABLE_SIZE); - public property GlobalVariablePreferredTotalSize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_GLOBAL_VARIABLE_PREFERRED_TOTAL_SIZE); - public property LocalMemType: DeviceLocalMemType read GetDeviceLocalMemType (DeviceInfo.DEVICE_LOCAL_MEM_TYPE); - public property LocalMemSize: UInt64 read GetUInt64 (DeviceInfo.DEVICE_LOCAL_MEM_SIZE); - public property ErrorCorrectionSupport: Boolean read GetBoolean (DeviceInfo.DEVICE_ERROR_CORRECTION_SUPPORT); - public property ProfilingTimerResolution: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_PROFILING_TIMER_RESOLUTION); - public property EndianLittle: Boolean read GetBoolean (DeviceInfo.DEVICE_ENDIAN_LITTLE); - public property Available: Boolean read GetBoolean (DeviceInfo.DEVICE_AVAILABLE); - public property CompilerAvailable: Boolean read GetBoolean (DeviceInfo.DEVICE_COMPILER_AVAILABLE); - public property LinkerAvailable: Boolean read GetBoolean (DeviceInfo.DEVICE_LINKER_AVAILABLE); - public property ExecutionCapabilities: DeviceExecCapabilities read GetDeviceExecCapabilities (DeviceInfo.DEVICE_EXECUTION_CAPABILITIES); - public property QueueOnHostProperties: CommandQueueProperties read GetCommandQueueProperties (DeviceInfo.DEVICE_QUEUE_ON_HOST_PROPERTIES); - public property QueueOnDeviceProperties: CommandQueueProperties read GetCommandQueueProperties (DeviceInfo.DEVICE_QUEUE_ON_DEVICE_PROPERTIES); - public property QueueOnDevicePreferredSize: UInt32 read GetUInt32 (DeviceInfo.DEVICE_QUEUE_ON_DEVICE_PREFERRED_SIZE); - public property QueueOnDeviceMaxSize: UInt32 read GetUInt32 (DeviceInfo.DEVICE_QUEUE_ON_DEVICE_MAX_SIZE); - public property MaxOnDeviceQueues: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_ON_DEVICE_QUEUES); - public property MaxOnDeviceEvents: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_ON_DEVICE_EVENTS); - public property BuiltInKernels: String read GetString (DeviceInfo.DEVICE_BUILT_IN_KERNELS); - public property Name: String read GetString (DeviceInfo.DEVICE_NAME); - public property Vendor: String read GetString (DeviceInfo.DEVICE_VENDOR); - public property Profile: String read GetString (DeviceInfo.DEVICE_PROFILE); - public property Version: String read GetString (DeviceInfo.DEVICE_VERSION); - public property OpenclCVersion: String read GetString (DeviceInfo.DEVICE_OPENCL_C_VERSION); - public property Extensions: String read GetString (DeviceInfo.DEVICE_EXTENSIONS); - public property PrintfBufferSize: UIntPtr read GetUIntPtr (DeviceInfo.DEVICE_PRINTF_BUFFER_SIZE); - public property PreferredInteropUserSync: Boolean read GetBoolean (DeviceInfo.DEVICE_PREFERRED_INTEROP_USER_SYNC); - public property PartitionMaxSubDevices: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PARTITION_MAX_SUB_DEVICES); - public property PartitionProperties: array of DevicePartitionProperty read GetDevicePartitionPropertyArr(DeviceInfo.DEVICE_PARTITION_PROPERTIES); - public property PartitionAffinityDomain: DeviceAffinityDomain read GetDeviceAffinityDomain (DeviceInfo.DEVICE_PARTITION_AFFINITY_DOMAIN); - public property PartitionType: array of DevicePartitionProperty read GetDevicePartitionPropertyArr(DeviceInfo.DEVICE_PARTITION_TYPE); - public property ReferenceCount: UInt32 read GetUInt32 (DeviceInfo.DEVICE_REFERENCE_COUNT); - public property SvmCapabilities: DeviceSVMCapabilities read GetDeviceSVMCapabilities (DeviceInfo.DEVICE_SVM_CAPABILITIES); - public property PreferredPlatformAtomicAlignment: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_PLATFORM_ATOMIC_ALIGNMENT); - public property PreferredGlobalAtomicAlignment: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_GLOBAL_ATOMIC_ALIGNMENT); - public property PreferredLocalAtomicAlignment: UInt32 read GetUInt32 (DeviceInfo.DEVICE_PREFERRED_LOCAL_ATOMIC_ALIGNMENT); - public property MaxNumSubGroups: UInt32 read GetUInt32 (DeviceInfo.DEVICE_MAX_NUM_SUB_GROUPS); - public property SubGroupIndependentForwardProgress: Boolean read GetBoolean (DeviceInfo.DEVICE_SUB_GROUP_INDEPENDENT_FORWARD_PROGRESS); - - end; - - {$endregion Device} - - {$region Context} - - ContextProperties = sealed class(NtvPropertiesBase) - - private static function clGetSize(context: cl_context; param_name: ContextInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; - external 'opencl.dll' name 'clGetContextInfo'; - private static function clGetVal(context: cl_context; param_name: ContextInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; - external 'opencl.dll' name 'clGetContextInfo'; - - protected procedure GetSizeImpl(id: ContextInfo; var sz: UIntPtr); override := - clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; - protected procedure GetValImpl(id: ContextInfo; sz: UIntPtr; var res: byte); override := - clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; - - private function GetContextPropertiesArr(id: ContextInfo) := GetValArr&(id); - - public property ReferenceCount: UInt32 read GetUInt32 (ContextInfo.CONTEXT_REFERENCE_COUNT); - public property NumDevices: UInt32 read GetUInt32 (ContextInfo.CONTEXT_NUM_DEVICES); - public property Properties: array of ContextProperties read GetContextPropertiesArr(ContextInfo.CONTEXT_PROPERTIES); - - end; - - {$endregion Context} - - {$region Buffer} - - BufferProperties = sealed class(NtvPropertiesBase) - - private static function clGetSize(memobj: cl_mem; param_name: MemInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; - external 'opencl.dll' name 'clGetMemObjectInfo'; - private static function clGetVal(memobj: cl_mem; param_name: MemInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; - external 'opencl.dll' name 'clGetMemObjectInfo'; - - protected procedure GetSizeImpl(id: MemInfo; var sz: UIntPtr); override := - clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; - protected procedure GetValImpl(id: MemInfo; sz: UIntPtr; var res: byte); override := - clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; - - private function GetMemObjectType(id: MemInfo) := GetVal&(id); - private function GetMemFlags(id: MemInfo) := GetVal&(id); - - public property &Type: MemObjectType read GetMemObjectType(MemInfo.MEM_TYPE); - public property Flags: MemFlags read GetMemFlags (MemInfo.MEM_FLAGS); - public property Size: UIntPtr read GetUIntPtr (MemInfo.MEM_SIZE); - public property HostPtr: IntPtr read GetIntPtr (MemInfo.MEM_HOST_PTR); - public property MapCount: UInt32 read GetUInt32 (MemInfo.MEM_MAP_COUNT); - public property ReferenceCount: UInt32 read GetUInt32 (MemInfo.MEM_REFERENCE_COUNT); - public property UsesSvmPointer: Boolean read GetBoolean (MemInfo.MEM_USES_SVM_POINTER); - public property Offset: UIntPtr read GetUIntPtr (MemInfo.MEM_OFFSET); - - end; - - {$endregion Buffer} - - {$region Kernel} - - KernelProperties = sealed class(NtvPropertiesBase) - - private static function clGetSize(kernel: cl_kernel; param_name: KernelInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; - external 'opencl.dll' name 'clGetKernelInfo'; - private static function clGetVal(kernel: cl_kernel; param_name: KernelInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; - external 'opencl.dll' name 'clGetKernelInfo'; - - protected procedure GetSizeImpl(id: KernelInfo; var sz: UIntPtr); override := - clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; - protected procedure GetValImpl(id: KernelInfo; sz: UIntPtr; var res: byte); override := - clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; - - public property FunctionName: String read GetString(KernelInfo.KERNEL_FUNCTION_NAME); - public property NumArgs: UInt32 read GetUInt32(KernelInfo.KERNEL_NUM_ARGS); - public property ReferenceCount: UInt32 read GetUInt32(KernelInfo.KERNEL_REFERENCE_COUNT); - public property Attributes: String read GetString(KernelInfo.KERNEL_ATTRIBUTES); - - end; - - {$endregion Kernel} - - {$region Program} - - ProgramProperties = sealed class(NtvPropertiesBase) - - private static function clGetSize(&program: cl_program; param_name: ProgramInfo; param_value_size: UIntPtr; param_value: IntPtr; var param_value_size_ret: UIntPtr): ErrorCode; - external 'opencl.dll' name 'clGetProgramInfo'; - private static function clGetVal(&program: cl_program; param_name: ProgramInfo; param_value_size: UIntPtr; var param_value: byte; param_value_size_ret: IntPtr): ErrorCode; - external 'opencl.dll' name 'clGetProgramInfo'; - - protected procedure GetSizeImpl(id: ProgramInfo; var sz: UIntPtr); override := - clGetSize(ntv, id, UIntPtr.Zero, IntPtr.Zero, sz).RaiseIfError; - protected procedure GetValImpl(id: ProgramInfo; sz: UIntPtr; var res: byte); override := - clGetVal(ntv, id, sz, res, IntPtr.Zero).RaiseIfError; - - public property ReferenceCount: UInt32 read GetUInt32 (ProgramInfo.PROGRAM_REFERENCE_COUNT); - public property Source: String read GetString (ProgramInfo.PROGRAM_SOURCE); - public property Il: array of Byte read GetByteArr (ProgramInfo.PROGRAM_IL); - public property BinarySizes: array of UIntPtr read GetUIntPtrArr(ProgramInfo.PROGRAM_BINARY_SIZES); - public property Binaries: array of array of Byte read GetByteArrArr(ProgramInfo.PROGRAM_BINARIES, BinarySizes); - public property NumKernels: UIntPtr read GetUIntPtr (ProgramInfo.PROGRAM_NUM_KERNELS); - public property KernelNames: String read GetString (ProgramInfo.PROGRAM_KERNEL_NAMES); - public property ScopeGlobalCtorsPresent: Boolean read GetBoolean (ProgramInfo.PROGRAM_SCOPE_GLOBAL_CTORS_PRESENT); - public property ScopeGlobalDtorsPresent: Boolean read GetBoolean (ProgramInfo.PROGRAM_SCOPE_GLOBAL_DTORS_PRESENT); - - end; - - {$endregion Program} - - {$endregion Properties} - - {$region Wrappers} - - {$region Base} - - WrapperBase = abstract class - where TProp: class; - private ntv: TNtv; - - private _properties: TProp; - protected function GetProperties: TProp; - begin - if _properties=nil then _properties := CreateProp; - Result := _properties; - end; - private function CreateProp: TProp; abstract; - - ///-- - public function Equals(obj: object): boolean; override := - (obj is WrapperBase(var wr)) and (self.ntv=wr.ntv); - - end; - - {$endregion Base} - - {$region Platform} - - ///Представляет платформу OpenCL, объединяющую одно или несколько устройств - Platform = sealed class(WrapperBase) - private function CreateProp: PlatformProperties; override := new PlatformProperties(ntv); - - ///Возвращает имя (дескриптор) неуправляемого объекта - public property Native: cl_platform_id read ntv; - ///Возвращает контейнер свойств неуправляемого объекта - public property Properties: PlatformProperties read GetProperties; - - {$region constructor's} - - ///Создаёт обёртку для указанного неуправляемого объекта - public constructor(pl: cl_platform_id) := - self.ntv := pl; - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - private static _all: IList; - private static function MakePlatformList: IList; - begin - if _all=nil then - begin - var c: UInt32; - cl.GetPlatformIDs(0, IntPtr.Zero, c).RaiseIfError; - - var all_arr := new cl_platform_id[c]; - cl.GetPlatformIDs(c, all_arr[0], IntPtr.Zero).RaiseIfError; - - _all := new ReadOnlyCollection(all_arr.ConvertAll(pl->new Platform(pl))); - end; - Result := _all; - end; - ///Возвращает список всех доступных платформ OpenCL - ///Данный список создаётся 1 раз, при первом обращении - public static property All: IList read MakePlatformList; - - {$endregion constructor's} - - {$region operator's} - - public static function operator=(pl1, pl2: Platform): boolean := pl1.ntv = pl2.ntv; - public static function operator<>(pl1, pl2: Platform): boolean := pl1.ntv <> pl2.ntv; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}]'; - - {$endregion operator's} - - end; - - {$endregion Platform} - - {$region Device} - - SubDevice = class; - ///Представляет устройство, поддерживающее OpenCL - Device = class(WrapperBase) - private function CreateProp: DeviceProperties; override := new DeviceProperties(ntv); - - ///Возвращает имя (дескриптор) неуправляемого объекта - public property Native: cl_device_id read ntv; - ///Возвращает контейнер свойств неуправляемого объекта - public property Properties: DeviceProperties read GetProperties; - - ///Возвращает платформу данного устройства - public property BasePlatform: Platform read new Platform(Properties.GetVal&(DeviceInfo.DEVICE_PLATFORM)); - - {$region constructor's} - - ///Создаёт обёртку для указанного неуправляемого объекта - public constructor(dvc: cl_device_id) := - self.ntv := dvc; - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - ///Собирает массив устройств указанного типа для указанной платформы - ///Возвращает nil, если ни одно устройство не найдено - public static function GetAllFor(pl: Platform; t: DeviceType): array of Device; - begin - - var c: UInt32; - var ec := cl.GetDeviceIDs(pl.Native, t, 0, IntPtr.Zero, c); - if ec=ErrorCode.DEVICE_NOT_FOUND then exit; - ec.RaiseIfError; - - var all := new cl_device_id[c]; - cl.GetDeviceIDs(pl.Native, t, c, all[0], IntPtr.Zero).RaiseIfError; - - Result := all.ConvertAll(dvc->new Device(dvc)); - end; - ///Собирает массив устройств GPU для указанной платформы - ///Возвращает nil, если ни одно устройство не найдено - public static function GetAllFor(pl: Platform) := GetAllFor(pl, DeviceType.DEVICE_TYPE_GPU); - - private static supported_split_modes: array of DevicePartitionProperty := nil; - private function Split(props: array of DevicePartitionProperty): array of SubDevice; - - ///Создаёт максимальное возможное количество виртуальных устройств, - ///каждое из которых содержит CUCount ядер данного устройства - public function SplitEqually(CUCount: integer): array of SubDevice; - begin - if CUCount <= 0 then raise new ArgumentException($'Количество ядер должно быть положительным числом, а не {CUCount}'); - Result := Split( - new DevicePartitionProperty[]( - DevicePartitionProperty.DEVICE_PARTITION_EQUALLY, - DevicePartitionProperty.Create(CUCount), - DevicePartitionProperty.Create(0) - ) - ); - end; - - - ///Создаёт массив виртуальных устройств, каждое из которых содержит указанное кол-во ядер - public function SplitByCounts(params CUCounts: array of integer): array of SubDevice; - begin - foreach var CUCount in CUCounts do - if CUCount <= 0 then raise new ArgumentException($'Количество ядер должно быть положительным числом, а не {CUCount}'); - - var props := new DevicePartitionProperty[CUCounts.Length+2]; - props[0] := DevicePartitionProperty.DEVICE_PARTITION_BY_COUNTS; - for var i := 0 to CUCounts.Length-1 do - props[i+1] := new DevicePartitionProperty(CUCounts[i]); - props[props.Length-1] := DevicePartitionProperty.DEVICE_PARTITION_BY_COUNTS_LIST_END; - - Result := Split(props); - end; - - ///Разделяет данное устройство на отдельные группы ядер так, - ///чтобы у каждой группы ядер был общий кэш указанного уровня - public function SplitByAffinityDomain(affinity_domain: DeviceAffinityDomain) := - Split( - new DevicePartitionProperty[]( - DevicePartitionProperty.DEVICE_PARTITION_EQUALLY, - DevicePartitionProperty.Create(new IntPtr(affinity_domain.val)), - DevicePartitionProperty.Create(0) - ) - ); - - {$endregion constructor's} - - {$region operator's} - - public static function operator=(dvc1, dvc2: Device): boolean := dvc1.ntv = dvc2.ntv; - public static function operator<>(dvc1, dvc2: Device): boolean := dvc1.ntv <> dvc2.ntv; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}]'; - - {$endregion operator's} - - end; - ///Представляет виртуальное устройство, использующее часть ядер другого устройства - ///Объекты данного типа обычно создаются методами "Device.Split*" - SubDevice = sealed class(Device) - private _parent: Device; - ///Возвращает родительское устройство, часть ядер которого использует данное устройство - public property Parent: Device read _parent; - - {$region constructor's} - - private constructor(dvc: cl_device_id; parent: Device); - begin - inherited Create(dvc); - self._parent := parent; - end; - private constructor := inherited; - - protected procedure Finalize; override := - cl.ReleaseDevice(ntv).RaiseIfError; - - {$endregion constructor's} - - {$region operator's} - - public static function operator in(sub_dvc: SubDevice; dvc: Device): boolean := sub_dvc.Parent=dvc; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}] of {Parent}'; - - {$endregion operator's} - - end; - - {$endregion Device} - - {$region Context} - - CommandQueueBase = class; - CommandQueue = class; - CLTaskBase = class; - CLTask = class; - ///Представляет контекст для хранения данных и выполнения команд на GPU - Context = sealed class(WrapperBase, IDisposable) - private dvcs: IList; - private main_dvc: Device; - - private function CreateProp: ContextProperties; override := new ContextProperties(ntv); - - ///Возвращает имя (дескриптор) неуправляемого объекта - public property Native: cl_context read ntv; - ///Возвращает список устройств, используемых данным контекстом - public property AllDevices: IList read dvcs; - ///Возвращает главное устройство контекста, на котором выделяется память под буферы и внутренние объекты очередей - public property MainDevice: Device read main_dvc; - - ///Возвращает контейнер свойств неуправляемого объекта - public property Properties: ContextProperties read GetProperties; - - private function GetAllNtvDevices: array of cl_device_id; - begin - Result := new cl_device_id[dvcs.Count]; - for var i := 0 to Result.Length-1 do - Result[i] := dvcs[i].Native; - end; - - {$region Default} - - private static default_need_init := true; - private static default_init_lock := new object; - private static _default: Context; - - private static function GetDefault: Context; - begin - - if default_need_init then lock default_init_lock do if default_need_init then - begin - default_need_init := false; - _default := MakeNewDefaultContext; - end; - - Result := _default; - end; - private static procedure SetDefault(new_default: Context); - begin - default_need_init := false; - _default := new_default; - end; - ///Возвращает или задаёт главный контекст, используемый там, где контекст не указывается явно (как неявные очереди) - ///При первом обращении к данному свойству OpenCLABC пытается создать новый контекст - ///При создании главного контекста приоритет отдаётся полноценным GPU, но если таких нет - берётся любое устройство, поддерживающее OpenCL - /// - ///Если устройств поддерживающих OpenCL нет, то Context.Default изначально будет nil - ///Но это свидетельствует скорее об отсутствии драйверов, чем отстутсвии устройств - public static property &Default: Context read GetDefault write SetDefault; - - private static function MakeNewDefaultContext: Context; - begin - var pls := Platform.All; - if pls=nil then exit; - - foreach var pl in pls do - begin - var dvcs := Device.GetAllFor(pl); - if dvcs=nil then continue; - Result := new Context(dvcs); - exit; - end; - - foreach var pl in pls do - begin - var dvcs := Device.GetAllFor(pl, DeviceType.DEVICE_TYPE_ALL); - if dvcs=nil then continue; - Result := new Context(dvcs); - exit; - end; - - Result := nil; - end; - - {$endregion Default} - - {$region constructor's} - - private static procedure CheckMainDevice(main_dvc: Device; dvc_lst: IList) := - if not dvc_lst.Contains(main_dvc) then raise new ArgumentException($'main_dvc должен быть в списке устройств контекста'); - - ///Создаёт контекст с указанными AllDevices и MainDevice - public constructor(dvcs: IList; main_dvc: Device); - begin - CheckMainDevice(main_dvc, dvcs); - - var ntv_dvcs := new cl_device_id[dvcs.Count]; - for var i := 0 to ntv_dvcs.Length-1 do - ntv_dvcs[i] := dvcs[i].Native; - - var ec: ErrorCode; - //ToDo позволить использовать CL_CONTEXT_INTEROP_USER_SYNC в свойствах - self.ntv := cl.CreateContext(nil, ntv_dvcs.Count, ntv_dvcs, nil, IntPtr.Zero, ec); - ec.RaiseIfError; - - self.dvcs := new ReadOnlyCollection(dvcs); - self.main_dvc := main_dvc; - end; - ///Создаёт контекст с указанными AllDevices - ///В качестве MainDevice берётся первое устройство из массива - public constructor(params dvcs: array of Device) := Create(dvcs, dvcs[0]); - - private static function GetContextDevices(ntv: cl_context): array of Device; - begin - - var sz: UIntPtr; - cl.GetContextInfo(ntv, ContextInfo.CONTEXT_DEVICES, UIntPtr.Zero, nil, sz).RaiseIfError; - - var res := new cl_device_id[uint64(sz) div Marshal.SizeOf&]; - cl.GetContextInfo(ntv, ContextInfo.CONTEXT_DEVICES, sz, res[0], IntPtr.Zero).RaiseIfError; - - Result := res.ConvertAll(dvc->new Device(dvc)); - end; - private procedure InitFromNtv(ntv: cl_context; dvcs: IList; main_dvc: Device); - begin - CheckMainDevice(main_dvc, dvcs); - cl.RetainContext(ntv).RaiseIfError; - self.ntv := ntv; - self.dvcs := new ReadOnlyCollection(dvcs); - self.main_dvc := main_dvc; - end; - ///Создаёт обёртку для указанного неуправляемого объекта - ///При успешном создании обёртки вызывается cl.Retain - ///А во время вызова .Dispose - cl.Release - public constructor(ntv: cl_context; main_dvc: Device) := - InitFromNtv(ntv, GetContextDevices(ntv), main_dvc); - - ///Создаёт обёртку для указанного неуправляемого объекта - ///При успешном создании обёртки вызывается cl.Retain - ///А во время вызова .Dispose - cl.Release - public constructor(ntv: cl_context); - begin - var dvcs := GetContextDevices(ntv); - InitFromNtv(ntv, dvcs, dvcs[0]); - end; - - private constructor(c: Context; main_dvc: Device) := - InitFromNtv(c.ntv, c.dvcs, main_dvc); - ///Создаёт совместимый контекст, равный данному с одним отличием - MainDevice заменён на dvc - public function MakeSibling(new_main_dvc: Device) := new Context(self, new_main_dvc); - - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - ///Позволяет OpenCL удалить неуправляемый объект - ///Данный метод вызывается автоматически во время сборки мусора, если объект ещё не удалён - public procedure Dispose := - if ntv<>cl_context.Zero then lock self do - begin - cl.ReleaseContext(ntv).RaiseIfError; - ntv := cl_context.Zero; - end; - protected procedure Finalize; override := Dispose; - - {$endregion constructor's} - - {$region operator's} - - public static function operator=(c1, c2: Context): boolean := c1.ntv = c2.ntv; - public static function operator<>(c1, c2: Context): boolean := c1.ntv <> c2.ntv; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}] on devices: {AllDevices.JoinToString('', '')}; Main device: {MainDevice}'; - - {$endregion operator's} - - {$region Invoke} - - ///Запускает данную очередь и все её подочереди - ///Как только всё запущено: возвращает объект типа CLTask<>, через который можно следить за процессом выполнения - public function BeginInvoke(q: CommandQueue): CLTask; - ///Запускает данную очередь и все её подочереди - ///Как только всё запущено: возвращает объект типа CLTask<>, через который можно следить за процессом выполнения - public function BeginInvoke(q: CommandQueueBase): CLTaskBase; - - ///Запускает данную очередь и все её подочереди - ///Затем ожидает окончания выполнения и возвращает полученный результат - public function SyncInvoke(q: CommandQueue): T; - ///Запускает данную очередь и все её подочереди - ///Затем ожидает окончания выполнения и возвращает полученный результат - public function SyncInvoke(q: CommandQueueBase): Object; - - {$endregion Invoke} - - end; - - {$endregion Context} - - {$region Buffer} - - BufferCommandQueue = class; - ///Представляет область памяти устройства OpenCL - Buffer = class(WrapperBase, IDisposable) - private sz: UIntPtr; - - ///Возвращает имя (дескриптор) неуправляемого объекта - public property Native: cl_mem read ntv; - - private function CreateProp: BufferProperties; override; - begin - if ntv=cl_mem.Zero then raise new InvalidOperationException($'Ожидался инициализированный буфер. Используйте .Init, или конструктор принимающий контекст'); - Result := new BufferProperties(ntv); - end; - ///Возвращает контейнер свойств неуправляемого объекта - public property Properties: BufferProperties read GetProperties; - - ///Возвращает размер буфера в байтах - public property Size: UIntPtr read sz; - ///Возвращает размер буфера в байтах - public property Size32: UInt32 read sz.ToUInt32; - ///Возвращает размер буфера в байтах - public property Size64: UInt64 read sz.ToUInt64; - - ///Создаёт новую очередь-контейнер для команд GPU, применяемых к данному буферу - public function NewQueue: BufferCommandQueue; - - {$region constructor's} - - ///Создаёт буфер указанного в байтах размера - ///Память на GPU не выделяется до вызова метода .Init - public constructor(size: UIntPtr) := self.sz := size; - ///Создаёт буфер указанного в байтах размера - ///Память на GPU не выделяется до вызова метода .Init - public constructor(size: integer) := Create(new UIntPtr(size)); - ///Создаёт буфер указанного в байтах размера - ///Память на GPU не выделяется до вызова метода .Init - public constructor(size: int64) := Create(new UIntPtr(size)); - - ///Создаёт буфер указанного в байтах размера - ///Память на GPU выделяется сразу, на явно указанном контексте - public constructor(size: UIntPtr; c: Context); - begin - Create(size); - Init(c); - end; - ///Создаёт буфер указанного в байтах размера - ///Память на GPU выделяется сразу, на явно указанном контексте - public constructor(size: integer; c: Context) := Create(new UIntPtr(size), c); - ///Создаёт буфер указанного в байтах размера - ///Память на GPU выделяется сразу, на явно указанном контексте - public constructor(size: int64; c: Context) := Create(new UIntPtr(size), c); - - ///Создаёт обёртку для указанного неуправляемого объекта - ///При успешном создании обёртки вызывается cl.Retain - ///А во время вызова .Dispose - cl.Release - protected constructor(ntv: cl_mem); - begin - cl.RetainMemObject(ntv).RaiseIfError; - self.ntv := ntv; - - cl.GetMemObjectInfo(ntv, MemInfo.MEM_SIZE, new UIntPtr(Marshal.SizeOf&), self.sz, IntPtr.Zero).RaiseIfError; - GC.AddMemoryPressure(Size64); - - end; - - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - ///Выделяет память для данного буфера в указанном контексте - ///Если память уже выделена, то она освобождается и выделяется заново - public procedure Init(c: Context); virtual := - lock self do - begin - - var ec: ErrorCode; - var new_ntv := cl.CreateBuffer(c.Native, MemFlags.MEM_READ_WRITE, sz, IntPtr.Zero, ec); - ec.RaiseIfError; - - if self.ntv=cl_mem.Zero then - GC.AddMemoryPressure(Size64) else - cl.ReleaseMemObject(self.ntv).RaiseIfError; - - self.ntv := new_ntv; - end; - - ///Выделяет память для данного буфера в указанном контексте - ///Если память уже выделена, то данный методы ничего не делает - public procedure InitIfNeed(c: Context); virtual := - if self.ntv=cl_mem.Zero then lock self do - begin - if self.ntv<>cl_mem.Zero then exit; // Во время ожидания lock могли инициализировать - - var ec: ErrorCode; - var new_ntv := cl.CreateBuffer(c.Native, MemFlags.MEM_READ_WRITE, sz, IntPtr.Zero, ec); - ec.RaiseIfError; - - GC.AddMemoryPressure(Size64); - self.ntv := new_ntv; - end; - - ///Освобождает память, выделенную под данный буфер, если она выделена - ///Внимание, если снова использовать данный буфер - память выделится заново - public procedure Dispose; virtual := - if ntv<>cl_mem.Zero then lock self do - begin - if self.ntv=cl_mem.Zero then exit; // Во время ожидания lock могли удалить - self._properties := nil; - GC.RemoveMemoryPressure(Size64); - cl.ReleaseMemObject(ntv).RaiseIfError; - ntv := cl_mem.Zero; - end; - protected procedure Finalize; override := Dispose; - - {$endregion constructor's} - - {$region operator's} - - public static function operator=(b1, b2: Buffer): boolean := b1.ntv = b2.ntv; - public static function operator<>(b1, b2: Buffer): boolean := b1.ntv <> b2.ntv; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}] of size {Size}'; - - {$endregion operator's} - - {$region 1#Write&Read} - - ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM - public function WriteData(ptr: CommandQueue): Buffer; - - ///Копирует всё содержимое буфера в RAM, по указанному адресу - public function ReadData(ptr: CommandQueue): Buffer; - - ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function WriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer; - - ///Копирует часть содержимого буфера в RAM, по указанному адресу - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function ReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer; - - ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM - public function WriteData(ptr: pointer): Buffer; - - ///Копирует всё содержимое буфера в RAM, по указанному адресу - public function ReadData(ptr: pointer): Buffer; - - ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function WriteData(ptr: pointer; buff_offset, len: CommandQueue): Buffer; - - ///Копирует часть содержимого буфера в RAM, по указанному адресу - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function ReadData(ptr: pointer; buff_offset, len: CommandQueue): Buffer; - - ///Записывает указанное значение размерного типа в начало буфера - public function WriteValue(val: TRecord): Buffer; where TRecord: record; - - ///Записывает указанное значение размерного типа в буфер - ///buff_offset указывает отступ от начала буфера, в байтах - public function WriteValue(val: TRecord; buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Записывает указанное значение размерного типа в начало буфера - public function WriteValue(val: CommandQueue): Buffer; where TRecord: record; - - ///Записывает указанное значение размерного типа в буфер - ///buff_offset указывает отступ от начала буфера, в байтах - public function WriteValue(val: CommandQueue; buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Записывает весь массив в начало буфера - public function WriteArray1(a: CommandQueue): Buffer; where TRecord: record; - - ///Записывает весь массив в начало буфера - public function WriteArray2(a: CommandQueue): Buffer; where TRecord: record; - - ///Записывает весь массив в начало буфера - public function WriteArray3(a: CommandQueue): Buffer; where TRecord: record; - - ///Читает из буфера достаточно байт чтоб заполнить весь массив - public function ReadArray1(a: CommandQueue): Buffer; where TRecord: record; - - ///Читает из буфера достаточно байт чтоб заполнить весь массив - public function ReadArray2(a: CommandQueue): Buffer; where TRecord: record; - - ///Читает из буфера достаточно байт чтоб заполнить весь массив - public function ReadArray3(a: CommandQueue): Buffer; where TRecord: record; - - ///Записывает указанный участок массива в буфер - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - public function WriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Записывает указанный участок массива в буфер - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function WriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Записывает указанный участок массива в буфер - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function WriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Читает в буфер указанный участок массива - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - public function ReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Читает в буфер указанный участок массива - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function ReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer; where TRecord: record; - - ///Читает в буфер указанный участок массива - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function ReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer; where TRecord: record; - - {$endregion 1#Write&Read} - - {$region 2#Fill} - - ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями весь буфер - public function FillData(ptr: CommandQueue; pattern_len: CommandQueue): Buffer; - - ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями часть буфера - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function FillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): Buffer; - - ///Заполняет весь буфер копиями указанного значения размерного типа - public function FillValue(val: TRecord): Buffer; where TRecord: record; - - ///Заполняет часть буфера копиями указанного значения размерного типа - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function FillValue(val: TRecord; buff_offset, len: CommandQueue): Buffer; where TRecord: record; - - ///Заполняет весь буфер копиями указанного значения размерного типа - public function FillValue(val: CommandQueue): Buffer; where TRecord: record; - - ///Заполняет часть буфера копиями указанного значения размерного типа - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function FillValue(val: CommandQueue; buff_offset, len: CommandQueue): Buffer; where TRecord: record; - - {$endregion 2#Fill} - - {$region 3#Copy} - - ///Копирует данные из текущего буфера в b - ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера - public function CopyTo(b: CommandQueue): Buffer; - - ///Копирует данные из b в текущий буфер - ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера - public function CopyForm(b: CommandQueue): Buffer; - - ///Копирует данные из текущего буфера в b - ///from_pos указывает отступ в байтах от начала буфера, из которого копируют - ///to_pos указывает отступ в байтах от начала буфера, в который копируют - ///len указывает кол-во копируемых байт - public function CopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer; - - ///Копирует данные из b в текущий буфер - ///from_pos указывает отступ в байтах от начала буфера, из которого копируют - ///to_pos указывает отступ в байтах от начала буфера, в который копируют - ///len указывает кол-во копируемых байт - public function CopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer; - - {$endregion 3#Copy} - - {$region Get} - - ///Выделяет область неуправляемой памяти и копирует в неё всё содержимое данного буфера - public function GetData: IntPtr; - - ///Выделяет область неуправляемой памяти и копирует в неё часть содержимого данного буфера - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function GetData(buff_offset, len: CommandQueue): IntPtr; - - ///Читает значение указанного размерного типа из начала буфера - public function GetValue: TRecord; where TRecord: record; - - ///Читает значение указанного размерного типа из буфера - ///buff_offset указывает отступ от начала буфера, в байтах - public function GetValue(buff_offset: CommandQueue): TRecord; where TRecord: record; - - ///Создаёт массив максимального размера (на сколько хватит байт буфера) и копирует в него содержимое буфера - public function GetArray1: array of TRecord; where TRecord: record; - - ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера - public function GetArray1(len: CommandQueue): array of TRecord; where TRecord: record; - - ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера - public function GetArray2(len1,len2: CommandQueue): array[,] of TRecord; where TRecord: record; - - ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера - public function GetArray3(len1,len2,len3: CommandQueue): array[,,] of TRecord; where TRecord: record; - - {$endregion Get} - - end; - ///Представляет область памяти внутри другого буфера - SubBuffer = sealed class(Buffer) - private _parent: Buffer; - ///Возвращает родительский буфер - public property Parent: Buffer read _parent; - - {$region operator's} - - public static function operator in(sub_b: SubBuffer; b: Buffer): boolean := sub_b.Parent=b; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}] of size {Size} inside {Parent}'; - - {$endregion operator's} - - {$region constructor's} - - protected constructor(parent: Buffer; reg: cl_buffer_region); - begin - inherited Create(reg.size); - - var parent_ntv := parent.Native; - if parent_ntv=cl_mem.Zero then raise new InvalidOperationException($'Ожидался инициализированный буфер. Используйте .Init, или конструктор принимающий контекст'); - - var ec: ErrorCode; - self.ntv := cl.CreateSubBuffer(parent_ntv, MemFlags.MEM_READ_WRITE, BufferCreateType.BUFFER_CREATE_TYPE_REGION, reg, ec); - ec.RaiseIfError; - - self._parent := parent; - end; - ///Создаёт буфер из области памяти родительского буфера parent - ///origin указывает отступ в байтах от начала parent - ///size указывает размер нового буфера - ///Память parent должна быть выделена перед вызовом данного конструктора, - ///потому что новый буфер будет использовать память parent, вместо создания новой области памяти - public constructor(parent: Buffer; origin, size: UIntPtr) := Create(parent, new cl_buffer_region(origin, size)); - - ///Создаёт буфер из области памяти родительского буфера parent - ///origin указывает отступ в байтах от начала parent - ///size указывает размер нового буфера - ///Память parent должна быть выделена перед вызовом данного конструктора, - ///потому что новый буфер будет использовать память parent, вместо создания новой области памяти - public constructor(parent: Buffer; origin, size: UInt32) := Create(parent, new UIntPtr(origin), new UIntPtr(size)); - ///Создаёт буфер из области памяти родительского буфера parent - ///origin указывает отступ в байтах от начала parent - ///size указывает размер нового буфера - ///Память parent должна быть выделена перед вызовом данного конструктора, - ///потому что новый буфер будет использовать память parent, вместо создания новой области памяти - public constructor(parent: Buffer; origin, size: UInt64) := Create(parent, new UIntPtr(origin), new UIntPtr(size)); - - private procedure InitIgnoreOrErr := - if self.ntv=cl_mem.Zero then raise new NotSupportedException($'SubBuffer нельзя инициализировать, потому что он использует память другого буфера'); - ///-- - public procedure Init(c: Context); override := InitIgnoreOrErr; - ///-- - public procedure InitIfNeed(c: Context); override := InitIgnoreOrErr; - - ///-- - public procedure Dispose; override := - if ntv<>cl_mem.Zero then lock self do - begin - if self.ntv=cl_mem.Zero then exit; // Во время ожидания lock могли удалить - self._properties := nil; - cl.ReleaseMemObject(ntv).RaiseIfError; - ntv := cl_mem.Zero; - end; - - {$endregion constructor's} - - end; - - {$endregion Buffer} - - {$region Kernel} - - KernelCommandQueue = class; - KernelArg = class; - ///Представляет подпрограмму, выполняемую на GPU - Kernel = sealed class(WrapperBase, IDisposable) - private function CreateProp: KernelProperties; override := new KernelProperties(ntv); - - ///Возвращает имя (дескриптор) неуправляемого объекта - public property Native: cl_kernel read ntv; - ///Возвращает контейнер свойств неуправляемого объекта - public property Properties: KernelProperties read GetProperties; - - private _prog: cl_program; - private _name: string; - ///Возвращает имя данной подпрограммы - public property Name: string read _name; - - ///Создаёт новую очередь-контейнер для команд GPU, применяемых к данному kernel-у - public function NewQueue: KernelCommandQueue; - - {$region constructor's} - - private function MakeNewNtv: cl_kernel; - begin - var ec: ErrorCode; - Result := cl.CreateKernel(_prog, _name, ec); - ec.RaiseIfError; - end; - protected constructor(prog: cl_program; name: string); - begin - self._prog := prog; - self._name := name; - self.ntv := self.MakeNewNtv; - end; - - ///Создаёт обёртку для указанного неуправляемого объекта - ///При успешном создании обёртки вызывается cl.Retain - ///А во время вызова .Dispose - cl.Release - public constructor(ntv: cl_kernel; retain: boolean := true); - begin - - cl.GetKernelInfo(ntv, KernelInfo.KERNEL_PROGRAM, new UIntPtr(cl_program.Size), self._prog, IntPtr.Zero).RaiseIfError; - - var sz: UIntPtr; - cl.GetKernelInfo(ntv, KernelInfo.KERNEL_FUNCTION_NAME, UIntPtr.Zero, nil, sz).RaiseIfError; - var str_ptr := Marshal.AllocHGlobal(IntPtr(pointer(sz))); - try - cl.GetKernelInfo(ntv, KernelInfo.KERNEL_FUNCTION_NAME, sz, str_ptr, IntPtr.Zero).RaiseIfError; - self._name := Marshal.PtrToStringAnsi(str_ptr); - finally - Marshal.FreeHGlobal(str_ptr); - end; - - if retain then cl.RetainKernel(ntv).RaiseIfError; - self.ntv := ntv; - end; - - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - ///Позволяет OpenCL удалить неуправляемый объект - ///Данный метод вызывается автоматически во время сборки мусора, если объект ещё не удалён - public procedure Dispose := - if ntv<>cl_kernel.Zero then lock self do - begin - if ntv=cl_kernel.Zero then exit; - cl.ReleaseKernel(ntv).RaiseIfError; - ntv := cl_kernel.Zero; - end; - protected procedure Finalize; override := Dispose; - - {$endregion constructor's} - - {$region operator's} - - public static function operator=(k1, k2: Kernel): boolean := k1.ntv = k2.ntv; - public static function operator<>(k1, k2: Kernel): boolean := k1.ntv <> k2.ntv; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{Name}:{ntv.val}]'; - - {$endregion operator's} - - {$region UseExclusiveNative} - - private exclusive_ntv_lock := new object; - ///Гарантирует что неуправляемый объект будет использоваться только в 1 потоке одновременно - ///Если неуправляемый объект данного kernel-а используется другим потоком - в процедурную переменную передаётся его независимый клон - ///Внимание, клон неуправляемого объекта будет удалён сразу после выхода из вашей процедурной переменной, если не вызвать cl.RetainKernel - public procedure UseExclusiveNative(p: cl_kernel->()); - begin - var owned := Monitor.TryEnter(exclusive_ntv_lock); - var k: cl_kernel; - try - k := owned ? ntv : MakeNewNtv; - p(k); - finally - if owned then - Monitor.Exit(exclusive_ntv_lock) else - cl.ReleaseKernel(k).RaiseIfError; - end; - end; - ///Гарантирует что неуправляемый объект будет использоваться только в 1 потоке одновременно - ///Если неуправляемый объект данного kernel-а используется другим потоком - в процедурную переменную передаётся его независимый клон - ///Внимание, клон неуправляемого объекта будет удалён сразу после выхода из вашей процедурной переменной, если не вызвать cl.RetainKernel - public function UseExclusiveNative(f: cl_kernel->T): T; - begin - var owned := Monitor.TryEnter(exclusive_ntv_lock); - var k: cl_kernel; - try - k := owned ? ntv : MakeNewNtv; - Result := f(k); - finally - if owned then - Monitor.Exit(exclusive_ntv_lock) else - cl.ReleaseKernel(k).RaiseIfError; - end; - end; - - {$endregion UseExclusiveNative} - - {$region 1#Exec} - - ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы - public function Exec1(sz1: CommandQueue; params args: array of KernelArg): Kernel; - - ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы - public function Exec2(sz1,sz2: CommandQueue; params args: array of KernelArg): Kernel; - - ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы - public function Exec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): Kernel; - - ///Выполняет kernel с расширенным набором параметров - ///Данная перегрузка используется в первую очередь для тонких оптимизаций - ///Если она вам понадобилась по другой причина - пожалуйста, напишите в issue - public function Exec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): Kernel; - - {$endregion 1#Exec} - - end; - - {$endregion Kernel} - - {$region ProgramCode} - - ///Представляет контейнер с откомпилированным кодом для GPU, содержащим подпрограммы-kernel'ы - ProgramCode = sealed class(WrapperBase) - private function CreateProp: ProgramProperties; override := new ProgramProperties(ntv); - - ///Возвращает имя (дескриптор) неуправляемого объекта - public property Native: cl_program read ntv; - ///Возвращает контейнер свойств неуправляемого объекта - public property Properties: ProgramProperties read GetProperties; - - protected _c: Context; - ///Возвращает контекст, на котором компилировали данный код для GPU - public property BaseContext: Context read _c; - - {$region constructor's} - - private procedure Build; - begin - - var ec := cl.BuildProgram(self.ntv, _c.dvcs.Count,_c.GetAllNtvDevices, nil, nil,IntPtr.Zero); - if ec=ErrorCode.BUILD_PROGRAM_FAILURE then - begin - var sb := new StringBuilder($'Ошибка компиляции OpenCL программы:'); - - foreach var dvc in _c.AllDevices do - begin - sb += #10#10; - sb += dvc.ToString; - sb += ':'#10; - - var sz: UIntPtr; - cl.GetProgramBuildInfo(self.ntv, dvc.Native, ProgramBuildInfo.PROGRAM_BUILD_LOG, UIntPtr.Zero,IntPtr.Zero,sz).RaiseIfError; - - var str_ptr := Marshal.AllocHGlobal(IntPtr(pointer(sz))); - try - cl.GetProgramBuildInfo(self.ntv, dvc.Native, ProgramBuildInfo.PROGRAM_BUILD_LOG, sz,str_ptr,IntPtr.Zero).RaiseIfError; - sb += Marshal.PtrToStringAnsi(str_ptr); - finally - Marshal.FreeHGlobal(str_ptr); - end; - - end; - - raise new OpenCLException(ec, sb.ToString); - end else - ec.RaiseIfError; - - end; - - ///Компилирует указанные тексты программ на указанном контексте - ///Внимание! Именно тексты, Не имена файлов - public constructor(c: Context; params files_texts: array of string); - begin - - var ec: ErrorCode; - self.ntv := cl.CreateProgramWithSource(c.Native, files_texts.Length, files_texts, nil, ec); - ec.RaiseIfError; - - self._c := c; - self.Build; - - end; - - private constructor(ntv: cl_program; c: Context); - begin - cl.RetainProgram(ntv).RaiseIfError; - self._c := c; - self.ntv := ntv; - end; - - private static function GetProgContext(ntv: cl_program): Context; - begin - var c: cl_context; - cl.GetProgramInfo(ntv, ProgramInfo.PROGRAM_CONTEXT, new UIntPtr(Marshal.SizeOf&), c, IntPtr.Zero).RaiseIfError; - Result := new Context(c); - end; - ///Создаёт обёртку для указанного неуправляемого объекта - ///При успешном создании обёртки вызывается cl.Retain - ///А во время вызова .Dispose - cl.Release - public constructor(ntv: cl_program) := - Create(ntv, GetProgContext(ntv)); - - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - ///Позволяет OpenCL удалить неуправляемый объект - ///Данный метод вызывается автоматически во время сборки мусора, если объект ещё не удалён - public procedure Dispose := - if ntv<>cl_program.Zero then lock self do - begin - if ntv=cl_program.Zero then exit; - cl.ReleaseProgram(ntv).RaiseIfError; - ntv := cl_program.Zero; - end; - protected procedure Finalize; override := Dispose; - - {$endregion constructor's} - - {$region operator's} - - public static function operator=(code1, code2: ProgramCode): boolean := code1.ntv = code2.ntv; - public static function operator<>(code1, code2: ProgramCode): boolean := code1.ntv <> code2.ntv; - - ///Возвращает строку с основными данными о данном объекте - public function ToString: string; override := - $'{self.GetType.Name}[{ntv.val}]'; - - {$endregion operator's} - - {$region GetKernel} - - ///Находит в коде kernel с указанным именем - ///Регистр имени важен! - public property KernelByName[kname: string]: Kernel read new Kernel(ntv, kname); default; - - ///Создаёт массив из всех kernel-ов данного кода - public function GetAllKernels: array of Kernel; - begin - - var c: UInt32; - cl.CreateKernelsInProgram(ntv, 0, IntPtr.Zero, c).RaiseIfError; - - var res := new cl_kernel[c]; - cl.CreateKernelsInProgram(ntv, c, res[0], IntPtr.Zero).RaiseIfError; - - Result := res.ConvertAll(k->new Kernel(k, false)); - end; - - {$endregion GetKernel} - - {$region Serialize} - - ///Сохраняет прекомпилированную программу как набор байт - public function Serialize: array of array of byte := - self.Properties.Binaries; - - ///Сохраняет прекомпилированную программу в поток - public procedure SerializeTo(bw: System.IO.BinaryWriter); - begin - var bin := Serialize; - - bw.Write(bin.Length); - foreach var a in bin do - begin - bw.Write(a.Length); - bw.Write(a); - end; - - end; - ///Сохраняет прекомпилированную программу в поток - public procedure SerializeTo(str: System.IO.Stream) := - SerializeTo(new System.IO.BinaryWriter(str)); - - {$endregion Serialize} - - {$region Deserialize} - - ///Загружает прекомпилированную программу из набора байт - public static function Deserialize(c: Context; bin: array of array of byte): ProgramCode; - begin - var ntv: cl_program; - - var dvcs := c.GetAllNtvDevices; - - var ec: ErrorCode; - ntv := cl.CreateProgramWithBinary( - c.Native, c.AllDevices.Count, dvcs[0], - bin.ConvertAll(a->new UIntPtr(a.Length))[0], bin, - IntPtr.Zero, ec - ); - ec.RaiseIfError; - - Result := new ProgramCode(ntv, c); - Result.Build; - - end; - - ///Загружает прекомпилированную программу из потока - public static function DeserializeFrom(c: Context; br: System.IO.BinaryReader): ProgramCode; - begin - var bin: array of array of byte; - - SetLength(bin, br.ReadInt32); - for var i := 0 to bin.Length-1 do - begin - var len := br.ReadInt32; - bin[i] := br.ReadBytes(len); - if bin[i].Length<>len then raise new System.IO.EndOfStreamException; - end; - - Result := Deserialize(c, bin); - end; - ///Загружает прекомпилированную программу из потока - public static function DeserializeFrom(c: Context; str: System.IO.Stream) := - DeserializeFrom(c, new System.IO.BinaryReader(str)); - - {$endregion Deserialize} - - end; - - {$endregion ProgramCode} - - {$endregion Wrappers} - - {$region Util type's} - - {$region EventDebug}{$ifdef EventDebug} - - EventRetainReleaseData = record - private is_release: boolean; - private reason: string; - - private static debug_time_counter := Stopwatch.StartNew; - private time: TimeSpan; - - public constructor(is_release: boolean; reason: string); - begin - self.is_release := is_release; - self.reason := reason; - self.time := debug_time_counter.Elapsed; - end; - - private function GetActStr := is_release ? 'Released' : 'Retained'; - public function ToString: string; override := - $'{time} | {GetActStr} when: {reason}'; - - end; - EventDebug = static class - - {$region Retain/Release} - - private static RefCounter := new Dictionary>; - private static function RefCounterFor(ev: cl_event): List; - begin - lock RefCounter do - if not RefCounter.TryGetValue(ev, Result) then - begin - Result := new List; - RefCounter[ev] := Result; - end; - end; - - public static procedure RegisterEventRetain(ev: cl_event; reason: string); - begin - var lst := RefCounterFor(ev); - lock lst do lst += new EventRetainReleaseData(false, reason); - end; - public static procedure RegisterEventRelease(ev: cl_event; reason: string); - begin - var lst := RefCounterFor(ev); - lock lst do lst += new EventRetainReleaseData(true, reason); - end; - - public static procedure ReportRefCounterInfo := - lock output do lock RefCounter do - begin - - foreach var ev in RefCounter.Keys do - begin - $'Logging state change of {ev}'.Println; - var lst := RefCounter[ev]; - var c := 0; - lock lst do - foreach var act in lst do - begin - if act.is_release then - c -= 1 else - c += 1; - $'{c,3} | {act}'.Println; - end; - Writeln('-'*30); - end; - - Writeln('='*40); - end; - - {$endregion Retain/Release} - - end; - - {$endif EventDebug}{$endregion EventDebug} - - {$region CLTaskExt} - - UserEvent = class; - CLTaskExt = static class - - static procedure AddErr(tsk: CLTaskBase; e: Exception); - static function AddErr(tsk: CLTaskBase; ec: ErrorCode): boolean; - static function AddErr(tsk: CLTaskBase; st: CommandExecutionStatus): boolean; - - end; - - {$endregion CLTaskExt} - - {$region NativeUtils} - - NativeUtils = static class - public static AbortStatus := new CommandExecutionStatus(integer.MinValue); - - public static function CopyToUnm(a: TRecord): IntPtr; where TRecord: record; - begin - Result := Marshal.AllocHGlobal(Marshal.SizeOf&); - var res: ^TRecord := pointer(Result); - res^ := a; - end; - - public static function AsPtr(p: pointer): ^T := p; - public static function AsPtr(p: IntPtr) := AsPtr&(pointer(p)); - - public static function GCHndAlloc(o: object) := - CopyToUnm(GCHandle.Alloc(o)); - - public static procedure GCHndFree(gc_hnd_ptr: IntPtr); - begin - AsPtr&(gc_hnd_ptr)^.Free; - Marshal.FreeHGlobal(gc_hnd_ptr); - end; - - public static function StartNewThread(p: Action): Thread; - begin - Result := new Thread(p); - Result.IsBackground := true; - Result.Start; - end; - - protected static procedure FixCQ(c: cl_context; dvc: cl_device_id; var cq: cl_command_queue); - begin - if cq <> cl_command_queue.Zero then exit; - var ec: ErrorCode; - cq := cl.CreateCommandQueue(c, dvc, CommandQueueProperties.NONE, ec); - ec.RaiseIfError; - end; - - end; - - {$endregion NativeUtils} - - {$region Blittable} - - BlittableException = sealed class(Exception) - public constructor(t, blame: System.Type; source_name: string) := - inherited Create(t=blame ? $'Тип {t} нельзя использовать в {source_name}' : $'Тип {t} нельзя использовать в {source_name}, потому что он содержит тип {blame}' ); - end; - BlittableHelper = static class - - private static blittable_cache := new Dictionary; - public static function Blame(t: System.Type): System.Type; - begin - if t.IsPointer then exit; - if t.IsClass then - begin - Result := t; - exit; - end; - - //ToDo протестировать - может быстрее будет без blittable_cache, потому что всё заинлайнится? - if blittable_cache.TryGetValue(t, Result) then exit; - - foreach var fld in t.GetFields(System.Reflection.BindingFlags.Instance or System.Reflection.BindingFlags.Public or System.Reflection.BindingFlags.NonPublic) do - if fld.FieldType<>t then - begin - Result := Blame(fld.FieldType); - if Result<>nil then break; - end; - - blittable_cache[t] := Result; - end; - - public static function IsBlittable(t: System.Type) := Blame(t)=nil; - public static procedure RaiseIfNeed(t: System.Type; source_name: string); - begin - var blame := BlittableHelper.Blame(t); - if blame=nil then exit; - raise new BlittableException(t, blame, source_name); - end; - - end; - - {$endregion Blittable} - - {$region EventList} - - EventList = sealed class - public evs: array of cl_event; - public count := 0; - public abortable := false; // true только если можно моментально отменить - - {$region Misc} - - public property Item[i: integer]: cl_event read evs[i]; default; - - public static function operator=(l1, l2: EventList): boolean; - begin - if object.ReferenceEquals(l1, l2) then - begin - Result := true; - exit; - end; - if object.ReferenceEquals(l1, nil) then exit; - if object.ReferenceEquals(l2, nil) then exit; - if l1.count <> l2.count then exit; - for var i := 0 to l1.count-1 do - if l1[i]<>l2[i] then exit; - Result := true; - end; - public static function operator<>(l1, l2: EventList): boolean := not (l1=l2); - - {$endregion Misc} - - {$region constructor's} - - public constructor := exit; - public constructor(count: integer) := - if count<>0 then self.evs := new cl_event[count]; - - public static function operator implicit(ev: cl_event): EventList; - begin - if ev=cl_event.Zero then - Result := new EventList else - begin - Result := new EventList(1); - Result += ev; - end; - end; - - public constructor(params evs: array of cl_event); - begin - self.evs := evs; - self.count := evs.Length; - end; - - {$endregion constructor's} - - {$region operator+} - - public static procedure operator+=(l: EventList; ev: cl_event); - begin - l.evs[l.count] := ev; - l.count += 1; - end; - - public static procedure operator+=(l: EventList; ev: EventList); - begin - for var i := 0 to ev.count-1 do - l += ev[i]; - if ev.abortable then l.abortable := true; - end; - - public static function operator+(l1, l2: EventList): EventList; - begin - Result := new EventList(l1.count+l2.count); - Result += l1; - Result += l2; - Result.abortable := l1.abortable and l2.abortable; - end; - - public static function operator+(l: EventList; ev: cl_event): EventList; - begin - Result := new EventList(l.count+1); - Result += l; - Result += ev; - end; - - private static function Combine(evs: IList; tsk: CLTaskBase; c: cl_context; main_dvc: cl_device_id; var cq: cl_command_queue): EventList; - - {$endregion operator+} - - {$region cl_event.AttachCallback} - - public static procedure AttachNativeCallback(ev: cl_event; cb: EventCallback) := - cl.SetEventCallback(ev, CommandExecutionStatus.COMPLETE, cb, NativeUtils.GCHndAlloc(cb)).RaiseIfError; - - private static function DefaultStatusErr(tsk: CLTaskBase; st: CommandExecutionStatus; save_err: boolean): boolean := save_err ? CLTaskExt.AddErr(tsk, st) : st.IS_ERROR; - - public static procedure AttachCallback(ev: cl_event; work: Action; tsk: CLTaskBase; need_ev_release: boolean{$ifdef EventDebug}; reason: string{$endif}; st_err_handler: (CLTaskBase, CommandExecutionStatus, boolean)->boolean := DefaultStatusErr; save_err: boolean := true) := - AttachNativeCallback(ev, (ev,st,data)-> - begin - if need_ev_release then - begin - CLTaskExt.AddErr(tsk, cl.ReleaseEvent(ev)); - {$ifdef EventDebug} - EventDebug.RegisterEventRelease(ev, $'discarding after use in AttachCallback, working on {reason}'); - {$endif EventDebug} - end; - - if not st_err_handler(tsk, st, save_err) then - try - work; - except - on e: Exception do CLTaskExt.AddErr(tsk, e); - end; - - NativeUtils.GCHndFree(data); - end); - - public static procedure AttachFinallyCallback(ev: cl_event; work: Action; tsk: CLTaskBase; need_ev_release: boolean{$ifdef EventDebug}; reason: string{$endif}) := - AttachNativeCallback(ev, (ev,st,data)-> - begin - if need_ev_release then - begin - CLTaskExt.AddErr(tsk, cl.ReleaseEvent(ev)); - {$ifdef EventDebug} - if reason=nil then raise new InvalidOperationException; - EventDebug.RegisterEventRelease(ev, $'discarding after use in AttachFinallyCallback, working on {reason}'); - {$endif EventDebug} - end; - - try - work; - except - on e: Exception do CLTaskExt.AddErr(tsk, e); - end; - - NativeUtils.GCHndFree(data); - end); - - {$endregion cl_event.AttachCallback} - - {$region EventList.AttachCallback} - - private function ToMarker(c: cl_context; dvc: cl_device_id; var cq: cl_command_queue; expect_smart_status_err: boolean): cl_event; - begin - {$ifdef DEBUG} - if count <= 1 then raise new System.NotSupportedException; - {$endif DEBUG} - - NativeUtils.FixCQ(c, dvc, cq); - cl.EnqueueMarkerWithWaitList(cq, self.count, self.evs, Result).RaiseIfError; - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(Result, $'enq''ed marker for evs: {evs.JoinToString}'); - {$endif EventDebug} - if expect_smart_status_err then self.Retain( - {$ifdef EventDebug}$'making sure ev isn''t deleted until SmartStatusErr'{$endif} - ); - - end; - - private function SmartStatusErr(tsk: CLTaskBase; org_st: CommandExecutionStatus; save_err: boolean; need_release: boolean): boolean; - begin - //ToDo NV#3035203 - //ToDo И добавить использование save_err, когда раскомметирую -// if not org_st.IS_ERROR then exit; -// if org_st.val <> ErrorCode.EXEC_STATUS_ERROR_FOR_EVENTS_IN_WAIT_LIST.val then -// Result := CLTaskExt.AddErr(tsk, org_st) else - - {$ifdef DEBUG} - if count <= 1 then raise new System.NotSupportedException; - {$endif DEBUG} - - for var i := 0 to count-1 do - begin - var st: CommandExecutionStatus; - var ec := cl.GetEventInfo( - evs[i], EventInfo.EVENT_COMMAND_EXECUTION_STATUS, - new UIntPtr(sizeof(CommandExecutionStatus)), st, IntPtr.Zero - ); - - if save_err then - begin - if CLTaskExt.AddErr(tsk, ec) then continue; - if CLTaskExt.AddErr(tsk, st) then Result := true; - end else - begin - if ec.IS_ERROR then continue; - if st.IS_ERROR then Result := true; - end; - - end; - - if need_release then self.Release( - {$ifdef EventDebug}$'after use in SmartStatusErr'{$endif} - ); - - //ToDo NV#3035203 - без бага эта часть не нужна - if org_st.val <> ErrorCode.EXEC_STATUS_ERROR_FOR_EVENTS_IN_WAIT_LIST.val then - if save_err ? CLTaskExt.AddErr(tsk, org_st) : org_st.IS_ERROR then Result := true; - end; - - public procedure AttachCallback(work: Action; tsk: CLTaskBase; c: cl_context; dvc: cl_device_id; var cq: cl_command_queue{$ifdef EventDebug}; reason: string{$endif}; save_err: boolean := true) := - case self.count of - 0: work; - 1: AttachCallback(self.evs[0], work, tsk, false{$ifdef EventDebug}, nil{$endif}, DefaultStatusErr, save_err); - else AttachCallback(self.ToMarker(c, dvc, cq, true), work, tsk, true{$ifdef EventDebug}, reason{$endif}, (tsk,st,save_err)->SmartStatusErr(tsk,st,save_err,true), save_err); - end; - - public procedure AttachFinallyCallback(work: Action; tsk: CLTaskBase; c: cl_context; dvc: cl_device_id; var cq: cl_command_queue{$ifdef EventDebug}; reason: string{$endif}) := - case self.count of - 0: work; - 1: AttachFinallyCallback(self.evs[0], work, tsk, false{$ifdef EventDebug}, nil{$endif}); - else AttachFinallyCallback(self.ToMarker(c, dvc, cq, false), work, tsk, true{$ifdef EventDebug}, reason{$endif}); - end; - - {$endregion EventList.AttachCallback} - - {$region Retain/Release} - - public procedure Retain({$ifdef EventDebug}reason: string{$endif}) := - for var i := 0 to count-1 do - begin - cl.RetainEvent(evs[i]).RaiseIfError; - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(evs[i], $'{reason}, together with evs: {evs.JoinToString}'); - {$endif EventDebug} - end; - - public procedure Release({$ifdef EventDebug}reason: string{$endif}) := - for var i := 0 to count-1 do - begin - cl.ReleaseEvent(evs[i]).RaiseIfError; - {$ifdef EventDebug} - EventDebug.RegisterEventRelease(evs[i], $'{reason}, together with evs: {evs.JoinToString}'); - {$endif EventDebug} - end; - - /// True если возникла ошибка - public function WaitAndRelease(tsk: CLTaskBase): boolean; - begin - {$ifdef DEBUG} - if count=0 then raise new NotSupportedException; - {$endif DEBUG} - - var st := CommandExecutionStatus(cl.WaitForEvents(self.count, self.evs)); - if count=1 then - Result := DefaultStatusErr(tsk, st, true) else - Result := SmartStatusErr(tsk, st, true, false); - - self.Release({$ifdef EventDebug}$'discarding after being waited upon'{$endif EventDebug}); - end; - - {$endregion Retain/Release} - - end; - - {$endregion EventList} - - {$region UserEvent} - - UserEvent = sealed class - private uev: cl_event; - private done := false; - - {$region constructor's} - - private constructor(c: cl_context{$ifdef EventDebug}; reason: string{$endif}); - begin - var ec: ErrorCode; - self.uev := cl.CreateUserEvent(c, ec); - ec.RaiseIfError; - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(self.uev, $'Created for {reason}'); - {$endif EventDebug} - end; - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - public static function MakeUserEvent(tsk: CLTaskBase; c: cl_context{$ifdef EventDebug}; reason: string{$endif}): UserEvent; - - public static function StartBackgroundWork(after: EventList; work: Action; c: cl_context; tsk: CLTaskBase{$ifdef EventDebug}; reason: string{$endif}): UserEvent; - begin - var res := MakeUserEvent(tsk, c - {$ifdef EventDebug}, $'BackgroundWork, executing {reason}'{$endif} - ); - - var abort_thr_ev := new AutoResetEvent(false); - EventList.AttachFinallyCallback(res, ()->abort_thr_ev.Set(), tsk, false{$ifdef EventDebug}, nil{$endif}); - - var work_thr: Thread; - var abort_thr := NativeUtils.StartNewThread(()-> - begin - abort_thr_ev.WaitOne; // изначальная пауза, чтобы work_thr не убили до того как он успеет запуститься и выполнить after.Release - abort_thr_ev.WaitOne; - work_thr.Abort; - end); - - work_thr := NativeUtils.StartNewThread(()-> - try - var err := false; - try - if (after<>nil) and (after.count<>0) then - begin - if not after.abortable then - after := after + MakeUserEvent(tsk,c - {$ifdef EventDebug}, $'abortability of BackgroundWork wait on: {after.evs.JoinToString}'{$endif} - ); - err := after.WaitAndRelease(tsk); - end; - finally - abort_thr_ev.Set; - // Далее - в любом случае выполняется res.SetStatus, который вызывает - // содержимое res.AttachFinallyCallback выше - // Поэтому abort_thr никогда не застрянет - end; - - if err then - begin - abort_thr.Abort; - res.Abort; - end else - begin - work; - abort_thr.Abort; - res.SetStatus(CommandExecutionStatus.COMPLETE); - end; - - except - on e: Exception do - begin - CLTaskExt.AddErr(tsk, e); - // Первый .AddErr всегда сам вызывает .Abort на всех UserEvent - // А значит и abort_thr.Abort уже выполнило выше - // Единственное исключение - если "e is ThreadAbortException" - // Но это случится только если abort_thr уже доработало -// abort_thr.Abort; -// res.Abort; - end; - end); - - Result := res; - end; - - {$endregion constructor's} - - {$region Status} - - public property CanRemove: boolean read done; - - /// True если статус получилось изменить - public function SetStatus(st: CommandExecutionStatus): boolean; - begin - lock self do - begin - if done then exit; - cl.SetUserEventStatus(uev, st).RaiseIfError; - done := true; - Result := true; - end; - end; - /// True если статус получилось изменить - public function SetStatus(st: CommandExecutionStatus; tsk: CLTaskBase): boolean; - begin - lock self do - begin - if done then exit; - if CLTaskExt.AddErr(tsk, cl.SetUserEventStatus(uev, st)) then exit; - done := true; - Result := true; - end; - end; - public function Abort := SetStatus(NativeUtils.AbortStatus); - - {$endregion Status} - - {$region operator's} - - public static function operator implicit(ev: UserEvent): cl_event := ev.uev; - public static function operator implicit(ev: UserEvent): EventList; - begin - Result := ev.uev; - Result.abortable := true; - end; - - public static function operator+(ev1: EventList; ev2: UserEvent): EventList; - begin - Result := ev1 + ev2.uev; - Result.abortable := true; - end; - - {$endregion operator's} - - end; - - {$endregion UserEvent} - - {$region QueueRes} - - IPtrQueueRes = interface - function GetPtr: ^T; - end; - QRPtrWrap = sealed class(IPtrQueueRes) - private ptr: ^T := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); - - public constructor(val: T) := self.ptr^ := val; - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure Finalize; override := - Marshal.FreeHGlobal(new IntPtr(ptr)); - - public function GetPtr: ^T := ptr; - - end; - - QueueRes = class; - QueueResBase = abstract class - public ev: EventList; - public can_set_ev := true; - - public constructor(ev: EventList) := - self.ev := ev; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public function TrySetEvBase(new_ev: EventList): QueueResBase; abstract; - - public function GetResBase: object; abstract; - - public function LazyQuickTransformBase(f: object->T2): QueueRes; abstract; - - end; - - QueueResDelayedPtr = class; - QueueRes = abstract class(QueueResBase) - - public function GetRes: T; abstract; - public function GetResBase: object; override := GetRes; - - public function Clone: QueueRes; abstract; - - public function TrySetEv(new_ev: EventList): QueueRes; - begin - if self.ev=new_ev then - Result := self else - begin - Result := can_set_ev ? self : Clone; - Result.ev := new_ev; - end; - end; - public function TrySetEvBase(new_ev: EventList): QueueResBase; override := TrySetEv(new_ev); - - public function EnsureAbortability(tsk: CLTaskBase; c: Context): QueueRes; - begin - Result := self; - if (ev.count<>0) and not ev.abortable then - Result := Result.TrySetEv(ev + UserEvent.MakeUserEvent(tsk, c.Native - {$ifdef EventDebug}, $'abortability of QueueRes with .ev: {ev.evs.JoinToString}'{$endif} - )); - end; - - public function LazyQuickTransform(f: T->T2): QueueRes; abstract; - public function LazyQuickTransformBase(f: object->T2): QueueRes; override := - LazyQuickTransform(o->f(o)); - - /// Должно выполнятся только после ожидания ивентов - public function ToPtr: IPtrQueueRes; abstract; - - end; - - // Результат который просто есть - IQueueResConst = interface end; - QueueResConst = sealed class(QueueRes, IQueueResConst) - private res: T; - - public constructor(res: T; ev: EventList); - begin - inherited Create(ev); - self.res := res; - end; - private constructor := inherited; - - public function Clone: QueueRes; override := new QueueResConst(res, ev); - - public function GetRes: T; override := res; - - public function LazyQuickTransform(f: T->T2): QueueRes; override := - new QueueResConst(f(self.res), self.ev); - - public function ToPtr: IPtrQueueRes; override := new QRPtrWrap(res); - - end; - - // Результат который надо будет сначала дождаться, а потом ещё досчитать - IQueueResFunc = interface - function GetF: ()->object; - end; - QueueResFunc = sealed class(QueueRes, IQueueResFunc) - private f: ()->T; - - public constructor(f: ()->T; ev: EventList); - begin - inherited Create(ev); - self.f := f; - end; - private constructor := inherited; - - public function Clone: QueueRes; override := new QueueResFunc(f, ev); - - public function GetRes: T; override := f(); - public function IQueueResFunc.GetF: ()->object := ()->f(); - - public function LazyQuickTransform(f: T->T2): QueueRes; override := - new QueueResFunc(()->f(self.f()), self.ev); - - public function ToPtr: IPtrQueueRes; override := new QRPtrWrap(f()); - - end; - - // Результат который будет сохранён куда то, надо только дождаться - IQueueResDelayed = interface end; - QueueResDelayedBase = abstract class(QueueRes, IQueueResDelayed) - - public static function MakeNew(need_ptr_qr: boolean): QueueResDelayedBase; - - public procedure SetRes(value: T); abstract; - - public function Clone: QueueRes; override := new QueueResFunc(self.GetRes, ev); - - public function LazyQuickTransform(f: T->T2): QueueRes; override := - new QueueResFunc(()->f(self.GetRes()), self.ev); - - end; - QueueResDelayedObj = sealed class(QueueResDelayedBase) - private res := default(T); - - public constructor := - inherited Create(nil); - - public function GetRes: T; override := res; - public procedure SetRes(value: T); override := res := value; - - public function ToPtr: IPtrQueueRes; override := new QRPtrWrap(res); - - end; - QueueResDelayedPtr = sealed class(QueueResDelayedBase, IPtrQueueRes) - private ptr: ^T := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); - - public constructor := - inherited Create(nil); - - public constructor(res: T; ev: EventList); - begin - inherited Create(ev); - self.ptr^ := res; - end; - - public function GetPtr: ^T := ptr; - public function GetRes: T; override := ptr^; - public procedure SetRes(value: T); override := ptr^ := value; - - protected procedure Finalize; override := - Marshal.FreeHGlobal(new IntPtr(ptr)); - - public function ToPtr: IPtrQueueRes; override := self; - - end; - - {$endregion QueueRes} - - {$region MWEventContainer} - - MWEventContainer = sealed class // MW = Multi Wait - private curr_handlers := new Queue<()->boolean>; - private cached := 0; - - public procedure AddHandler(handler: ()->boolean) := - lock self do - if cached=0 then - curr_handlers += handler else - if handler() then - cached -= 1; - - public procedure ExecuteHandler := - lock self do - begin - while curr_handlers.Count<>0 do - if curr_handlers.Dequeue()() then - exit; - cached += 1; - end; - - end; - - {$endregion MWEventContainer} - - {$endregion Util type's} - - {$region Multiusable} - - MultiusableCommandQueueHubBase = abstract class - - end; - - {$endregion Multiusable} - - {$region CLTask} - - ///Представляет задачу выполнения очереди, создаваемую методом Context.BeginInvoke - CLTaskBase = abstract class - - protected wh := new ManualResetEvent(false); - protected wh_lock := new object; - - protected mu_res := new Dictionary; - - {$region property's} - - private function OrgQueueBase: CommandQueueBase; abstract; - ///Возвращает очередь, которую выполняет данный CLTask - public property OrgQueue: CommandQueueBase read OrgQueueBase; - - private org_c: Context; - ///Возвращает контекст, в котором выполняется данный CLTask - public property OrgContext: Context read org_c; - - {$endregion property's} - - {$region AddErr} - protected err_lst := new List; - - /// lock err_lst do err_lst.ToArray - private function GetErrArr: array of Exception; - begin - lock err_lst do - Result := err_lst.ToArray; - end; - - ///Возвращает исключение, полученное при выполнении очереди - ///Возвращает nil, если исключений не было - public property Error: AggregateException read err_lst.Count=0 ? nil : new AggregateException($'При выполнении очереди было вызвано {err_lst.Count} исключений. Используйте try чтоб получить больше информации', GetErrArr); - - protected procedure AddErr(e: Exception) := - begin - if e is ThreadAbortException then exit; - lock err_lst do err_lst += e; - lock user_events do - begin - for var i := user_events.Count-1 downto 0 do - user_events[i].Abort; - user_events.Clear; - end; - end; - - /// True если ошибка есть - protected function AddErr(ec: ErrorCode): boolean; - begin - if not ec.IS_ERROR then exit; - AddErr(new OpenCLException(ec, $'Внутренняя ошибка OpenCLABC: {ec}{#10}{Environment.StackTrace}')); - Result := true; - end; - /// True если ошибка есть - protected function AddErr(st: CommandExecutionStatus) := - (st=NativeUtils.AbortStatus) or (st.IS_ERROR and AddErr(ErrorCode(st))); - - {$endregion AddErr} - - {$region UserEvent's} - protected user_events := new List; - - protected function MakeUserEvent(c: cl_context{$ifdef EventDebug}; reason: string{$endif}): UserEvent; - begin - Result := new UserEvent(c{$ifdef EventDebug}, reason{$endif}); - - lock user_events do - begin - if err_lst.Count<>0 then - Result.Abort else - user_events += Result; - end; - - end; - - {$endregion UserEvent's} - - {$region CLTask event's} - - protected procedure WhenDoneBase(cb: Action); abstract; - ///Добавляет подпрограмму-обработчик, которая будет вызвана когда выполнение очереди завершится (успешно или с ошибой) - public procedure WhenDone(cb: Action) := WhenDoneBase(cb); - - protected procedure WhenCompleteBase(cb: Action); abstract; - ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если выполнение очереди завершится успешно - public procedure WhenComplete(cb: Action) := WhenCompleteBase(cb); - - protected procedure WhenErrorBase(cb: Action); abstract; - ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если при выполнении очереди будет вызвано исключение - public procedure WhenError(cb: Action) := WhenErrorBase(cb); - - /// True если очередь уже завершилась - private function AddEventHandler(ev: List; cb: T): boolean; where T: Delegate; - begin - lock wh_lock do - begin - Result := wh.WaitOne(0); - if not Result then ev += cb; - end; - end; - - {$endregion CLTask event's} - - {$region SyncRes} - - ///Ожидает окончания выполнения очереди (если оно ещё не завершилось) - ///Вызывает исключение, если оно было вызвано при выполнении очереди - public procedure Wait; - begin - wh.WaitOne; - var err := self.Error; - if err<>nil then raise err; - end; - - protected function WaitResBase: object; abstract; - ///Ожидает окончания выполнения очереди (если оно ещё не завершилось) - ///Вызывает исключение, если оно было вызвано при выполнении очереди - ///А затем возвращает результат выполнения - public function WaitRes := WaitResBase; - - {$endregion} - - end; - - ///Представляет задачу выполнения очереди, создаваемую методом Context.BeginInvoke - CLTask = sealed class(CLTaskBase) - protected q: CommandQueue; - protected q_res: T; - - ///Возвращает очередь, которую выполняет данный CLTask - public property OrgQueue: CommandQueue read q; reintroduce; - protected function OrgQueueBase: CommandQueueBase; override; - - private procedure RegisterWaitables(q: CommandQueue); - private function InvokeQueue(q: CommandQueue; c: Context; var cq: cl_command_queue): QueueRes; - protected constructor(q: CommandQueue; c: Context); - begin - self.q := q; - self.org_c := c; - RegisterWaitables(q); - - var cq: cl_command_queue; - var qr := InvokeQueue(q, c, cq); - - // mu выполняют лишний .Retain, чтобы ивент не удалился пока очередь ещё запускается - foreach var mu_qr in mu_res.Values do - mu_qr.ev.Release({$ifdef EventDebug}$'excessive mu ev'{$endif}); - mu_res := nil; - - {$ifdef DEBUG} - //CQ.Invoke всегда выполняет UserEvent.EnsureAbortability, поэтому тут оно не нужно - if (qr.ev.count<>0) and not qr.ev.abortable then raise new NotSupportedException; - {$endif DEBUG} - - //CQ.Invoke всегда выполняет UserEvent.EnsureAbortability, поэтому тут оно не нужно - qr.ev.AttachFinallyCallback(()-> - begin - qr.ev.Release({$ifdef EventDebug}$'last ev of CLTask'{$endif}); - if cq<>cl_command_queue.Zero then - System.Threading.Tasks.Task.Run(()->self.AddErr( cl.ReleaseCommandQueue(cq) )); - OnQDone(qr); - end, self, c.Native, c.MainDevice.Native, cq{$ifdef EventDebug}, $'CLTask.OnQDone'{$endif}); - - end; - - {$region CLTask event's} - - protected EvDone := new List>>; - ///Добавляет подпрограмму-обработчик, которая будет вызвана когда выполнение очереди завершится (успешно или с ошибой) - public procedure WhenDone(cb: Action>); reintroduce := - if AddEventHandler(EvDone, cb) then cb(self); - protected procedure WhenDoneBase(cb: Action); override := - WhenDone(cb as object as Action>); //ToDo #2221 - - protected EvComplete := new List, T>>; - ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если выполнение очереди завершится успешно - public procedure WhenComplete(cb: Action, T>); reintroduce := - if AddEventHandler(EvComplete, cb) then cb(self, q_res); - protected procedure WhenCompleteBase(cb: Action); override := - WhenComplete(cb as object as Action, T>); //ToDo #2221 - - protected EvError := new List, array of Exception>>; - ///Добавляет подпрограмму-обработчик, которая будет вызвана когда- и если при выполнении очереди будет вызвано исключение - public procedure WhenError(cb: Action, array of Exception>); reintroduce := - if AddEventHandler(EvError, cb) then cb(self, GetErrArr); - protected procedure WhenErrorBase(cb: Action); override := - WhenError(cb as object as Action, array of Exception>); //ToDo #2221 - - {$endregion CLTask event's} - - {$region Execution} - - private procedure OnQDone(qr: QueueRes); - begin - var l_EvDone: array of Action>; - var l_EvComplete: array of Action, T>; - var l_EvError: array of Action, array of Exception>; - - lock wh_lock do - try - - l_EvDone := EvDone.ToArray; - l_EvComplete := EvComplete.ToArray; - l_EvError := EvError.ToArray; - - if err_lst.Count=0 then self.q_res := qr.GetRes; - finally - wh.Set; - end; - - foreach var ev in l_EvDone do - try - ev(self); - except - on e: Exception do AddErr(e); - end; - - if err_lst.Count=0 then - begin - - foreach var ev in l_EvComplete do - try - ev(self, self.q_res); - except - on e: Exception do AddErr(e); - end; - - end else - if l_EvError.Length<>0 then - begin - var err_arr := GetErrArr; - - foreach var ev in l_EvError do - try - ev(self, err_arr); - except - on e: Exception do AddErr(e); - end; - - end; - - end; - - ///Ожидает окончания выполнения очереди (если оно ещё не завершилось) - ///Вызывает исключение, если оно было вызвано при выполнении очереди - ///А затем возвращает результат выполнения - public function WaitRes: T; reintroduce; - begin - Wait; - Result := self.q_res; - end; - protected function WaitResBase: object; override := WaitRes; - - {$endregion Execution} - - end; - - {$endregion CLTask} - - {$region CommandQueue} - - {$region Base} - - ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU - CommandQueueBase = abstract class - - {$region Invoke} - - protected function InvokeBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueResBase; abstract; - - protected function InvokeNewQBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; prev_ev: EventList): QueueResBase; abstract; - - {$endregion Invoke} - - {$region MW} - - /// добавляет tsk в качестве ключа для всех ожидаемых очередей - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; - - private mw_evs := new Dictionary; - private procedure RegisterWaiterTask(tsk: CLTaskBase) := - lock mw_evs do if not mw_evs.ContainsKey(tsk) then - begin - mw_evs[tsk] := new MWEventContainer; - tsk.WhenDone(tsk->lock mw_evs do mw_evs.Remove(tsk)); - end; - - private procedure AddMWHandler(tsk: CLTaskBase; handler: ()->boolean); - begin - var cont: MWEventContainer; - lock mw_evs do cont := mw_evs[tsk]; - cont.AddHandler(handler); - end; - - private procedure ExecuteMWHandlers; - begin - if mw_evs.Count=0 then exit; - var conts: array of MWEventContainer; - lock mw_evs do conts := mw_evs.Values.ToArray; - for var i := 0 to conts.Length-1 do conts[i].ExecuteHandler; - end; - - {$endregion MW} - - {$region ConstQueue} - - public static function operator implicit(o: object): CommandQueueBase; - - {$endregion ConstQueue} - - {$region Cast} - - ///Если данная очередь проходит по условию "... is CommandQueue" - возвращает себя же - ///Иначе возвращает очередь-обёртку, выполняющую "res := T(res)", где res - результат данной очереди - public function Cast: CommandQueue; - - {$endregion} - - {$region ThenConvert} - - protected function ThenConvertBase(f: (object, Context)->TOtp): CommandQueue; abstract; - - ///Создаёт очередь, которая выполнит данную - ///А затем выполнит на CPU функцию f, используя результат данной очереди - public function ThenConvert(f: object->TOtp ) := ThenConvertBase((o,c)->f(o)); - ///Создаёт очередь, которая выполнит данную - ///А затем выполнит на CPU функцию f, используя результат данной очереди и контекст выполнения - public function ThenConvert(f: (object, Context)->TOtp) := ThenConvertBase(f); - - {$endregion ThenConvert} - - {$region +/*} - - protected function AfterQueueSyncBase(q: CommandQueueBase): CommandQueueBase; abstract; - protected function AfterQueueAsyncBase(q: CommandQueueBase): CommandQueueBase; abstract; - - public static function operator+(q1, q2: CommandQueueBase): CommandQueueBase := q2.AfterQueueSyncBase(q1); - public static function operator*(q1, q2: CommandQueueBase): CommandQueueBase := q2.AfterQueueAsyncBase(q1); - - public static procedure operator+=(var q1: CommandQueueBase; q2: CommandQueueBase) := q1 := q1+q2; - public static procedure operator*=(var q1: CommandQueueBase; q2: CommandQueueBase) := q1 := q1*q2; - - {$endregion +/*} - - {$region Multiusable} - - protected function MultiusableBase: ()->CommandQueueBase; abstract; - - ///Создаёт функцию, вызывая которую можно создать любое кол-во очередей-удлинителей для данной очереди - ///Подробнее в справке: "Очередь>>Создание очередей>>Множественное использование очереди" - public function Multiusable := MultiusableBase; - - {$endregion Multiusable} - - {$region ThenWait} - - protected function ThenWaitForAllBase(qs: sequence of CommandQueueBase): CommandQueueBase; abstract; - protected function ThenWaitForAnyBase(qs: sequence of CommandQueueBase): CommandQueueBase; abstract; - - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждой из заданых очередей - public function ThenWaitForAll(params qs: array of CommandQueueBase) := ThenWaitForAllBase(qs); - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждой из заданых очередей - public function ThenWaitForAll(qs: sequence of CommandQueueBase ) := ThenWaitForAllBase(qs); - - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любой из заданных очередей - public function ThenWaitForAny(params qs: array of CommandQueueBase) := ThenWaitForAnyBase(qs); - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любой из заданных очередей - public function ThenWaitForAny(qs: sequence of CommandQueueBase ) := ThenWaitForAnyBase(qs); - - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от заданой очереди - public function ThenWaitFor(q: CommandQueueBase) := ThenWaitForAll(q); - - {$endregion ThenWait} - - end; - ///Представляет очередь, состоящую в основном из команд, выполняемых на GPU - CommandQueue = abstract class(CommandQueueBase) - - {$region Invoke} - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; abstract; - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; - begin - Result := InvokeImpl(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev).EnsureAbortability(tsk, c); - Result.ev.AttachCallback(self.ExecuteMWHandlers, tsk, c.Native, main_dvc, cq{$ifdef EventDebug}, $'ExecuteMWHandlers'{$endif}, false); - end; - protected function InvokeBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueResBase; override := - Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); - - protected function InvokeNewQ(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; prev_ev: EventList): QueueRes; - begin - var cq := cl_command_queue.Zero; - Result := Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); - - {$ifdef DEBUG} - // Result.ev.abortable уже true, потому что .EnsureAbortability в Invoke - if (Result.ev.count<>0) and not Result.ev.abortable then raise new System.NotSupportedException; - {$endif DEBUG} - - if cq<>cl_command_queue.Zero then - Result.ev.AttachFinallyCallback(()-> - begin - System.Threading.Tasks.Task.Run(()->tsk.AddErr(cl.ReleaseCommandQueue(cq))) - end, tsk, c.Native, main_dvc, cq{$ifdef EventDebug}, $'cl.ReleaseCommandQueue'{$endif}); - - end; - protected function InvokeNewQBase(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; prev_ev: EventList): QueueResBase; override := - InvokeNewQ(tsk, c, main_dvc, need_ptr_qr, prev_ev); - - {$endregion Invoke} - - {$region ConstQueue} - - public static function operator implicit(o: T): CommandQueue; - - {$endregion ConstQueue} - - {$region ThenConvert} - - ///Создаёт очередь, которая выполнит данную - ///А затем выполнит на CPU функцию f, используя результат данной очереди - public function ThenConvert(f: T->TOtp): CommandQueue := ThenConvert((o,c)->f(o)); - ///Создаёт очередь, которая выполнит данную - ///А затем выполнит на CPU функцию f, используя результат данной очереди и контекст выполнения - public function ThenConvert(f: (T, Context)->TOtp): CommandQueue; - - protected function ThenConvertBase(f: (object, Context)->TOtp): CommandQueue; override := - ThenConvert(f as object as Func2); - - {$endregion ThenConvert} - - {$region +/*} - - public static function operator+(q1: CommandQueueBase; q2: CommandQueue): CommandQueue; - public static function operator*(q1: CommandQueueBase; q2: CommandQueue): CommandQueue; - - protected function AfterQueueSyncBase (q: CommandQueueBase): CommandQueueBase; override := q+self; - protected function AfterQueueAsyncBase(q: CommandQueueBase): CommandQueueBase; override := q*self; - - public static procedure operator+=(var q1: CommandQueue; q2: CommandQueue) := q1 := q1+q2; - public static procedure operator*=(var q1: CommandQueue; q2: CommandQueue) := q1 := q1*q2; - - {$endregion +/*} - - {$region Multiusable} - - ///Создаёт функцию, вызывая которую можно создать любое кол-во очередей-удлинителей для данной очереди - ///Подробнее в справке: "Очередь>>Создание очередей>>Множественное использование очереди" - public function Multiusable: ()->CommandQueue; - - protected function MultiusableBase: ()->CommandQueueBase; override := Multiusable as object as Func; //ToDo #2221 - - {$endregion Multiusable} - - {$region ThenWait} - - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждой из заданых очередей - public function ThenWaitForAll(params qs: array of CommandQueueBase): CommandQueue := ThenWaitForAll(qs.AsEnumerable); - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от каждой из заданых очередей - public function ThenWaitForAll(qs: sequence of CommandQueueBase): CommandQueue; - - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любой из заданных очередей - public function ThenWaitForAny(params qs: array of CommandQueueBase): CommandQueue := ThenWaitForAny(qs.AsEnumerable); - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую первого сигнала выполненности от любой из заданных очередей - public function ThenWaitForAny(qs: sequence of CommandQueueBase): CommandQueue; - - ///Создаёт очередь, сначала выполняющую данную, а затем ожидающую сигнала выполненности от заданой очереди - public function ThenWaitFor(q: CommandQueueBase) := ThenWaitForAll(q); - - protected function ThenWaitForAllBase(qs: sequence of CommandQueueBase): CommandQueueBase; override := ThenWaitForAll(qs); - protected function ThenWaitForAnyBase(qs: sequence of CommandQueueBase): CommandQueueBase; override := ThenWaitForAny(qs); - - {$endregion ThenWait} - - end; - - {$endregion Base} - - {$region Host} - - /// очередь, выполняющая какую то работу на CPU, всегда в отдельном потоке - HostQueue = abstract class(CommandQueue) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; abstract; - - protected function ExecFunc(o: TInp; c: Context): TRes; abstract; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - var prev_qr := InvokeSubQs(tsk, c, main_dvc, cq, prev_ev); - - var qr := QueueResDelayedBase&.MakeNew(need_ptr_qr); - qr.ev := UserEvent.StartBackgroundWork(prev_qr.ev, ()->qr.SetRes( ExecFunc(prev_qr.GetRes(), c) ), c.Native, tsk - {$ifdef EventDebug}, $'body of {self.GetType}'{$endif} - ); - - Result := qr; - end; - - end; - - {$endregion Host} - - {$region Const} - - ///Интерфейс, который реализован только классом ConstQueue - ///Позволяет получить значение, из которого была создана константая очередь, не зная его типа - IConstQueue = interface - ///Возвращает значение из которого была создана данная константная очередь - function GetConstVal: Object; - end; - ///Представляет константную очередь - ///Константные очереди ничего не выполняют и возвращает заданное при создании значение - ConstQueue = sealed class(CommandQueue, IConstQueue) - private res: T; - - ///Создаёт новую константную очередь из заданного значения - public constructor(o: T) := - self.res := o; - private constructor := raise new System.InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public function IConstQueue.GetConstVal: object := self.res; - ///Возвращает значение из которого была создана данная константная очередь - public property Val: T read self.res; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - if prev_ev=nil then prev_ev := new EventList; - - if need_ptr_qr then - Result := new QueueResDelayedPtr (self.res, prev_ev) else - Result := new QueueResConst (self.res, prev_ev); - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; - - end; - - {$endregion Const} - - {$region Array} - - {$region Simple} - - ISimpleQueueArray = interface - function GetQS: array of CommandQueueBase; - end; - SimpleQueueArray = abstract class(CommandQueue, ISimpleQueueArray) - protected qs: array of CommandQueueBase; - - public constructor(params qs: array of CommandQueueBase) := self.qs := qs; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public function GetQS: array of CommandQueueBase := qs; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - foreach var q in qs do q.RegisterWaitables(tsk, prev_hubs); - - end; - - ISimpleSyncQueueArray = interface(ISimpleQueueArray) end; - SimpleSyncQueueArray = sealed class(SimpleQueueArray, ISimpleSyncQueueArray) - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - - for var i := 0 to qs.Length-2 do - prev_ev := qs[i].InvokeBase(tsk, c, main_dvc, false, cq, prev_ev).ev; - - Result := (qs[qs.Length-1] as CommandQueue).Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); - end; - - end; - - ISimpleAsyncQueueArray = interface(ISimpleQueueArray) end; - SimpleAsyncQueueArray = sealed class(SimpleQueueArray, ISimpleAsyncQueueArray) - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop qs.Length-1 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var evs := new EventList[qs.Length]; - - for var i := 0 to qs.Length-2 do - evs[i] := qs[i].InvokeNewQBase(tsk, c, main_dvc, false, prev_ev).ev; - - // Используем внешнюю cq, чтобы не создавать лишнюю - Result := (qs[qs.Length-1] as CommandQueue).Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); - evs[evs.Length-1] := Result.ev; - - Result := Result.TrySetEv( EventList.Combine(evs, tsk, c.Native, main_dvc, cq) ?? new EventList ); - end; - - end; - - {$endregion Simple} - - {$region Conv} - - {$region Generic} - - ConvQueueArrayBase = abstract class(HostQueue) - protected qs: array of CommandQueue; - protected f: Func; - - public constructor(qs: array of CommandQueue; f: Func); - begin - self.qs := qs; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - foreach var q in qs do q.RegisterWaitables(tsk, prev_hubs); - - protected function ExecFunc(o: array of TInp; c: Context): TRes; override := f(o, c); - - end; - - ConvSyncQueueArray = sealed class(ConvQueueArrayBase) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - var qrs := new QueueRes[qs.Length]; - - for var i := 0 to qs.Length-1 do - begin - var qr := qs[i].Invoke(tsk, c, main_dvc, false, cq, prev_ev); - prev_ev := qr.ev; - qrs[i] := qr; - end; - - Result := new QueueResFunc(()-> - begin - Result := new TInp[qrs.Length]; - for var i := 0 to qrs.Length-1 do - Result[i] := qrs[i].GetRes; - end, prev_ev); - end; - - end; - ConvAsyncQueueArray = sealed class(ConvQueueArrayBase) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop qs.Length-1 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qrs := new QueueRes[qs.Length]; - var evs := new EventList[qs.Length]; - - for var i := 0 to qs.Length-2 do - begin - var qr := qs[i].InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - qrs[i] := qr; - evs[i] := qr.ev; - end; - - // Отдельно, чтобы не создавать лишнюю cq - var qr := qs[qs.Length-1].Invoke(tsk, c, main_dvc, false, cq, prev_ev); - qrs[evs.Length-1] := qr; - evs[evs.Length-1] := qr.ev; - - Result := new QueueResFunc(()-> - begin - Result := new TInp[qrs.Length]; - for var i := 0 to qrs.Length-1 do - Result[i] := qrs[i].GetRes; - end, EventList.Combine(evs, tsk, c.Native, main_dvc, cq) ?? new EventList); - end; - - end; - - {$endregion Generic} - - {$region [2]} - - ConvQueueArrayBase2 = abstract class(HostQueue, TRes>) - protected q1: CommandQueue; - protected q2: CommandQueue; - protected f: (TInp1, TInp2, Context)->TRes; - - public constructor(q1: CommandQueue; q2: CommandQueue; f: (TInp1, TInp2, Context)->TRes); - begin - self.q1 := q1; - self.q2 := q2; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - self.q1.RegisterWaitables(tsk, prev_hubs); - self.q2.RegisterWaitables(tsk, prev_hubs); - end; - - protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, c); - - end; - - ConvSyncQueueArray2 = sealed class(ConvQueueArrayBase2) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; - var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes()), prev_ev); - end; - - end; - ConvAsyncQueueArray2 = sealed class(ConvQueueArrayBase2) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop 1 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev), tsk, c.Native, main_dvc, cq)); - end; - - end; - - {$endregion [2]} - - {$region [3]} - - ConvQueueArrayBase3 = abstract class(HostQueue, TRes>) - protected q1: CommandQueue; - protected q2: CommandQueue; - protected q3: CommandQueue; - protected f: (TInp1, TInp2, TInp3, Context)->TRes; - - public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; f: (TInp1, TInp2, TInp3, Context)->TRes); - begin - self.q1 := q1; - self.q2 := q2; - self.q3 := q3; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - self.q1.RegisterWaitables(tsk, prev_hubs); - self.q2.RegisterWaitables(tsk, prev_hubs); - self.q3.RegisterWaitables(tsk, prev_hubs); - end; - - protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, c); - - end; - - ConvSyncQueueArray3 = sealed class(ConvQueueArrayBase3) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; - var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; - var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes()), prev_ev); - end; - - end; - ConvAsyncQueueArray3 = sealed class(ConvQueueArrayBase3) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop 2 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev), tsk, c.Native, main_dvc, cq)); - end; - - end; - - {$endregion [3]} - - {$region [4]} - - ConvQueueArrayBase4 = abstract class(HostQueue, TRes>) - protected q1: CommandQueue; - protected q2: CommandQueue; - protected q3: CommandQueue; - protected q4: CommandQueue; - protected f: (TInp1, TInp2, TInp3, TInp4, Context)->TRes; - - public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, Context)->TRes); - begin - self.q1 := q1; - self.q2 := q2; - self.q3 := q3; - self.q4 := q4; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - self.q1.RegisterWaitables(tsk, prev_hubs); - self.q2.RegisterWaitables(tsk, prev_hubs); - self.q3.RegisterWaitables(tsk, prev_hubs); - self.q4.RegisterWaitables(tsk, prev_hubs); - end; - - protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, c); - - end; - - ConvSyncQueueArray4 = sealed class(ConvQueueArrayBase4) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; - var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; - var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; - var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes()), prev_ev); - end; - - end; - ConvAsyncQueueArray4 = sealed class(ConvQueueArrayBase4) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop 3 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev), tsk, c.Native, main_dvc, cq)); - end; - - end; - - {$endregion [4]} - - {$region [5]} - - ConvQueueArrayBase5 = abstract class(HostQueue, TRes>) - protected q1: CommandQueue; - protected q2: CommandQueue; - protected q3: CommandQueue; - protected q4: CommandQueue; - protected q5: CommandQueue; - protected f: (TInp1, TInp2, TInp3, TInp4, TInp5, Context)->TRes; - - public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; q5: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, TInp5, Context)->TRes); - begin - self.q1 := q1; - self.q2 := q2; - self.q3 := q3; - self.q4 := q4; - self.q5 := q5; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - self.q1.RegisterWaitables(tsk, prev_hubs); - self.q2.RegisterWaitables(tsk, prev_hubs); - self.q3.RegisterWaitables(tsk, prev_hubs); - self.q4.RegisterWaitables(tsk, prev_hubs); - self.q5.RegisterWaitables(tsk, prev_hubs); - end; - - protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, t.Item5, c); - - end; - - ConvSyncQueueArray5 = sealed class(ConvQueueArrayBase5) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; - var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; - var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; - var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; - var qr5 := q5.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr5.ev; - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes()), prev_ev); - end; - - end; - ConvAsyncQueueArray5 = sealed class(ConvQueueArrayBase5) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop 4 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr5 := q5.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev, qr5.ev), tsk, c.Native, main_dvc, cq)); - end; - - end; - - {$endregion [5]} - - {$region [6]} - - ConvQueueArrayBase6 = abstract class(HostQueue, TRes>) - protected q1: CommandQueue; - protected q2: CommandQueue; - protected q3: CommandQueue; - protected q4: CommandQueue; - protected q5: CommandQueue; - protected q6: CommandQueue; - protected f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, Context)->TRes; - - public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; q5: CommandQueue; q6: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, Context)->TRes); - begin - self.q1 := q1; - self.q2 := q2; - self.q3 := q3; - self.q4 := q4; - self.q5 := q5; - self.q6 := q6; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - self.q1.RegisterWaitables(tsk, prev_hubs); - self.q2.RegisterWaitables(tsk, prev_hubs); - self.q3.RegisterWaitables(tsk, prev_hubs); - self.q4.RegisterWaitables(tsk, prev_hubs); - self.q5.RegisterWaitables(tsk, prev_hubs); - self.q6.RegisterWaitables(tsk, prev_hubs); - end; - - protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, t.Item5, t.Item6, c); - - end; - - ConvSyncQueueArray6 = sealed class(ConvQueueArrayBase6) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; - var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; - var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; - var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; - var qr5 := q5.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr5.ev; - var qr6 := q6.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr6.ev; - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes()), prev_ev); - end; - - end; - ConvAsyncQueueArray6 = sealed class(ConvQueueArrayBase6) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop 5 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr5 := q5.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr6 := q6.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev, qr5.ev, qr6.ev), tsk, c.Native, main_dvc, cq)); - end; - - end; - - {$endregion [6]} - - {$region [7]} - - ConvQueueArrayBase7 = abstract class(HostQueue, TRes>) - protected q1: CommandQueue; - protected q2: CommandQueue; - protected q3: CommandQueue; - protected q4: CommandQueue; - protected q5: CommandQueue; - protected q6: CommandQueue; - protected q7: CommandQueue; - protected f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, TInp7, Context)->TRes; - - public constructor(q1: CommandQueue; q2: CommandQueue; q3: CommandQueue; q4: CommandQueue; q5: CommandQueue; q6: CommandQueue; q7: CommandQueue; f: (TInp1, TInp2, TInp3, TInp4, TInp5, TInp6, TInp7, Context)->TRes); - begin - self.q1 := q1; - self.q2 := q2; - self.q3 := q3; - self.q4 := q4; - self.q5 := q5; - self.q6 := q6; - self.q7 := q7; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - self.q1.RegisterWaitables(tsk, prev_hubs); - self.q2.RegisterWaitables(tsk, prev_hubs); - self.q3.RegisterWaitables(tsk, prev_hubs); - self.q4.RegisterWaitables(tsk, prev_hubs); - self.q5.RegisterWaitables(tsk, prev_hubs); - self.q6.RegisterWaitables(tsk, prev_hubs); - self.q7.RegisterWaitables(tsk, prev_hubs); - end; - - protected function ExecFunc(t: ValueTuple; c: Context): TRes; override := f(t.Item1, t.Item2, t.Item3, t.Item4, t.Item5, t.Item6, t.Item7, c); - - end; - - ConvSyncQueueArray7 = sealed class(ConvQueueArrayBase7) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr1.ev; - var qr2 := q2.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr2.ev; - var qr3 := q3.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr3.ev; - var qr4 := q4.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr4.ev; - var qr5 := q5.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr5.ev; - var qr6 := q6.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr6.ev; - var qr7 := q7.Invoke(tsk, c, main_dvc, false, cq, prev_ev); prev_ev := qr7.ev; - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes(), qr7.GetRes()), prev_ev); - end; - - end; - ConvAsyncQueueArray7 = sealed class(ConvQueueArrayBase7) - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes>; override; - begin - if (prev_ev<>nil) and (prev_ev.count<>0) then loop 6 do prev_ev.Retain({$ifdef EventDebug}$'for all async branches'{$endif}); - var qr1 := q1.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - var qr2 := q2.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr3 := q3.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr4 := q4.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr5 := q5.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr6 := q6.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - var qr7 := q7.InvokeNewQ(tsk, c, main_dvc, false, prev_ev); - Result := new QueueResFunc>(()->ValueTuple.Create(qr1.GetRes(), qr2.GetRes(), qr3.GetRes(), qr4.GetRes(), qr5.GetRes(), qr6.GetRes(), qr7.GetRes()), EventList.Combine(new EventList[](qr1.ev, qr2.ev, qr3.ev, qr4.ev, qr5.ev, qr6.ev, qr7.ev), tsk, c.Native, main_dvc, cq)); - end; - - end; - - {$endregion [7]} - - {$endregion Conv} - - {$region Utils} - - QueueArrayUtils = static class - - public static function FlattenQueueArray(inp: sequence of CommandQueueBase): array of CommandQueueBase; where T: ISimpleQueueArray; - begin - var enmr := inp.GetEnumerator; - if not enmr.MoveNext then raise new InvalidOperationException('Функции CombineSyncQueue/CombineAsyncQueue не могут принимать 0 очередей'); - - var res := new List; - while true do - begin - var curr := enmr.Current; - var next := enmr.MoveNext; - - if not (curr is IConstQueue) or not next then - if curr as object is T(var sqa) then //ToDo #2290 - res.AddRange(sqa.GetQS) else - res += curr; - - if not next then break; - end; - - Result := res.ToArray; - end; - - public static function FlattenSyncQueueArray(inp: sequence of CommandQueueBase) := FlattenQueueArray&< ISimpleSyncQueueArray>(inp); - public static function FlattenAsyncQueueArray(inp: sequence of CommandQueueBase) := FlattenQueueArray&(inp); - - end; - - {$endregion} - - {$endregion Array} - - {$endregion CommandQueue} - - {$region WCQWaiter} - - WCQWaiter = abstract class - private waitables: array of CommandQueueBase; - - public constructor(waitables: array of CommandQueueBase) := self.waitables := waitables; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public procedure RegisterWaitables(tsk: CLTaskBase) := - foreach var q in waitables do q.RegisterWaiterTask(tsk); - - public function GetWaitEv(tsk: CLTaskBase; c: Context): UserEvent; abstract; - - end; - - WCQWaiterAll = sealed class(WCQWaiter) - - public function GetWaitEv(tsk: CLTaskBase; c: Context): UserEvent; override; - begin - var uev := tsk.MakeUserEvent(c.Native - {$ifdef EventDebug}, $'WCQWaiterAll[{waitables.Length}]'{$endif} - ); - - var done := 0; - var total := waitables.Length; - var done_lock := new object; - - for var i := 0 to waitables.Length-1 do - waitables[i].AddMWHandler(tsk, ()-> - begin - if uev.CanRemove then exit; - - lock done_lock do - begin - done += 1; - if done=total then - // Если uev.Abort вызовет между .CanRemove и этой строчкой - значит это было в отдельном потоке, - // т.е. в заведомо не_безопастном месте. А значит проверять тут - нет смысла - uev.SetStatus(CommandExecutionStatus.COMPLETE); - end; - - Result := true; - end); - - Result := uev; - end; - - end; - WCQWaiterAny = sealed class(WCQWaiter) - - public function GetWaitEv(tsk: CLTaskBase; c: Context): UserEvent; override; - begin - var uev := tsk.MakeUserEvent(c.Native - {$ifdef EventDebug}, $'WCQWaiterAny[{waitables.Length}]'{$endif} - ); - - for var i := 0 to waitables.Length-1 do - waitables[i].AddMWHandler(tsk, ()->uev.SetStatus(CommandExecutionStatus.COMPLETE)); - - Result := uev; - end; - - end; - - {$endregion WCQWaiter} - - {$region GPUCommand} - - {$region Base} - - GPUCommand = abstract class - - protected function InvokeObj (o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; abstract; - protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; abstract; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; - - end; - - {$endregion Base} - - {$region Queue} - - QueueCommand = sealed class(GPUCommand) - public q: CommandQueueBase; - - public constructor(q: CommandQueueBase) := self.q := q; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - private function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList) := q.InvokeBase(tsk, c, main_dvc, false, cq, prev_ev).ev; - - protected function InvokeObj (o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, main_dvc, cq, prev_ev); - protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, main_dvc, cq, prev_ev); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - q.RegisterWaitables(tsk, prev_hubs); - - end; - - {$endregion Queue} - - {$region Proc} - - ProcCommand = sealed class(GPUCommand) - public p: (T,Context)->(); - - public constructor(p: (T,Context)->()) := self.p := p; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected function InvokeObj(o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := - UserEvent.StartBackgroundWork(prev_ev, ()->p(o, c), c.Native, tsk - {$ifdef EventDebug}, $'const body of {self.GetType}'{$endif} - ); - - protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override; - begin - var o_q_res := o_q().Invoke(tsk, c, main_dvc, false, cq, prev_ev); - Result := UserEvent.StartBackgroundWork(o_q_res.ev, ()->p(o_q_res.GetRes(), c), c.Native, tsk - {$ifdef EventDebug}, $'queue body of {self.GetType}'{$endif} - ); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; - - end; - - {$endregion Proc} - - {$region Wait} - - WaitCommand = sealed class(GPUCommand) - public waiter: WCQWaiter; - - public constructor(waiter: WCQWaiter) := self.waiter := waiter; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - private function Invoke(tsk: CLTaskBase; c: Context; prev_ev: EventList): EventList; - begin - if prev_ev=nil then - Result := waiter.GetWaitEv(tsk, c) else - Result := prev_ev + waiter.GetWaitEv(tsk, c); - end; - - protected function InvokeObj (o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, prev_ev); - protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := Invoke(tsk, c, prev_ev); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - waiter.RegisterWaitables(tsk); - - end; - - {$endregion Wait} - - {$endregion GPUCommand} - - {$region GPUCommandContainer} - - {$region Base} - - GPUCommandContainer = class; - GPUCommandContainerBody = abstract class - private cc: GPUCommandContainer; - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; abstract; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; - - end; - - GPUCommandContainer = abstract class(CommandQueue) - protected body: GPUCommandContainerBody; - protected commands := new List>; - - {$region def} - - protected procedure InitObj(obj: T; c: Context); virtual := exit; - - {$endregion def} - - {$region Common} - - protected constructor(o: T); - protected constructor(q: CommandQueue); - - protected function MakeQueueCommand(q: CommandQueueBase) := new QueueCommand(q); - - protected function MakeProcCommand(p: T->()) := new ProcCommand((o,c)->p(o)); - protected function MakeProcCommand(p: (T,Context)->()) := new ProcCommand(p); - - protected function MakeWaitAllCommand(qs: sequence of CommandQueueBase) := new WaitCommand(new WCQWaiterAll(qs.ToArray)); - protected function MakeWaitAnyCommand(qs: sequence of CommandQueueBase) := new WaitCommand(new WCQWaiterAny(qs.ToArray)); - - {$endregion Common} - - {$region sub implementation} - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override := - body.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - body.RegisterWaitables(tsk, prev_hubs); - foreach var comm in commands do comm.RegisterWaitables(tsk, prev_hubs); - end; - - {$endregion sub implementation} - - {$region reintroduce методы} - - //ToDo #2145 - ///-- - public function Equals(obj: object): boolean; reintroduce := inherited Equals(obj); - ///-- - public function ToString: string; reintroduce := inherited ToString(); - ///-- - public function GetType: System.Type; reintroduce := inherited GetType(); - ///-- - public function GetHashCode: integer; reintroduce := inherited GetHashCode(); - - {$endregion reintroduce методы} - - end; - - {$endregion Base} - - {$region BufferCommandQueue} - - ///Представляет очередь-контейнер для команд GPU, применяемых к объекту типа Buffer - BufferCommandQueue = sealed class(GPUCommandContainer) - - {$region constructor's} - - protected procedure InitObj(obj: Buffer; c: Context); override := obj.InitIfNeed(c); - protected static function InitBuffer(b: Buffer; c: Context): Buffer; - begin - b.InitIfNeed(c); - Result := b; - end; - - ///Создаёт контейнер команд, который будет применять команды к указанному объекту - public constructor(b: Buffer) := inherited; - ///Создаёт контейнер команд, который будет применять команды к объекту, который вернёт указанная очередь - ///За каждое одно выполнение контейнера - q выполнится ровно один раз - public constructor(q: CommandQueue) := - inherited Create(q.ThenConvert(InitBuffer)); - - {$endregion constructor's} - - {$region Non-command add's} - - protected function AddCommand(comm: GPUCommand): BufferCommandQueue; - begin - self.commands += comm; - Result := self; - end; - - {$region Queue} - - ///Добавляет выполнение очереди в список обычных команд для GPU - public function AddQueue(q: CommandQueueBase) := AddCommand(MakeQueueCommand(q)); - - {$endregion Queue} - - {$region Proc} - - ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU - public function AddProc(p: Buffer->()) := AddCommand(MakeProcCommand(p)); - ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU - public function AddProc(p: (Buffer, Context)->()) := AddCommand(MakeProcCommand(p)); - - {$endregion Proc} - - {$region Wait} - - ///Добавляет ожидание сигнала выполненности от всех заданных очередей - public function AddWaitAll(params qs: array of CommandQueueBase) := AddCommand(MakeWaitAllCommand(qs)); - ///Добавляет ожидание сигнала выполненности от всех заданных очередей - public function AddWaitAll(qs: sequence of CommandQueueBase) := AddCommand(MakeWaitAllCommand(qs)); - - ///Добавляет ожидание первого сигнала выполненности от одной из заданных очередей - public function AddWaitAny(params qs: array of CommandQueueBase) := AddCommand(MakeWaitAnyCommand(qs)); - ///Добавляет ожидание первого сигнала выполненности от одной из заданных очередей - public function AddWaitAny(qs: sequence of CommandQueueBase) := AddCommand(MakeWaitAnyCommand(qs)); - - ///Добавляет ожидание сигнала выполненности от заданной очереди - public function AddWait(q: CommandQueueBase) := AddWaitAll(q); - - {$endregion Wait} - - {$endregion Non-command add's} - - {$region 1#Write&Read} - - ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM - public function AddWriteData(ptr: CommandQueue): BufferCommandQueue; - - ///Копирует всё содержимое буфера в RAM, по указанному адресу - public function AddReadData(ptr: CommandQueue): BufferCommandQueue; - - ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddWriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue; - - ///Копирует часть содержимого буфера в RAM, по указанному адресу - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue; - - ///Заполняет весь буфер данными, находящимися по указанному адресу в RAM - public function AddWriteData(ptr: pointer): BufferCommandQueue; - - ///Копирует всё содержимое буфера в RAM, по указанному адресу - public function AddReadData(ptr: pointer): BufferCommandQueue; - - ///Заполняет часть буфер данными, находящимися по указанному адресу в RAM - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddWriteData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue; - - ///Копирует часть содержимого буфера в RAM, по указанному адресу - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddReadData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue; - - ///Записывает указанное значение размерного типа в начало буфера - public function AddWriteValue(val: TRecord): BufferCommandQueue; where TRecord: record; - - ///Записывает указанное значение размерного типа в буфер - ///buff_offset указывает отступ от начала буфера, в байтах - public function AddWriteValue(val: TRecord; buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает указанное значение размерного типа в начало буфера - public function AddWriteValue(val: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает указанное значение размерного типа в буфер - ///buff_offset указывает отступ от начала буфера, в байтах - public function AddWriteValue(val: CommandQueue; buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает весь массив в начало буфера - public function AddWriteArray1(a: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает весь массив в начало буфера - public function AddWriteArray2(a: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает весь массив в начало буфера - public function AddWriteArray3(a: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Читает из буфера достаточно байт чтоб заполнить весь массив - public function AddReadArray1(a: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Читает из буфера достаточно байт чтоб заполнить весь массив - public function AddReadArray2(a: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Читает из буфера достаточно байт чтоб заполнить весь массив - public function AddReadArray3(a: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает указанный участок массива в буфер - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - public function AddWriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает указанный участок массива в буфер - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function AddWriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Записывает указанный участок массива в буфер - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function AddWriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Читает в буфер указанный участок массива - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - public function AddReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Читает в буфер указанный участок массива - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function AddReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Читает в буфер указанный участок массива - ///a_offset(-ы) указывают индекс в массиве - ///len указывает кол-во задействованных элементов массива - ///buff_offset указывает отступ от начала буфера, в байтах - /// - ///ВНИМАНИЕ! У многомерных массивов элементы распологаются так же как у одномерных, разделение на строки виртуально - ///Это значит что, к примеру, чтение 4 элементов 2-х мерного массива начиная с индекса [0,1] - ///прочитает элементы [0,1], [0,2], [1,0], [1,1]. Для чтения частей из нескольких строк массива - делайте несколько операций чтения, по 1 на строку - public function AddReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue; where TRecord: record; - - {$endregion 1#Write&Read} - - {$region 2#Fill} - - ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями весь буфер - public function AddFillData(ptr: CommandQueue; pattern_len: CommandQueue): BufferCommandQueue; - - ///Читает pattern_len байт из RAM по указанному адресу и заполняет их копиями часть буфера - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddFillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): BufferCommandQueue; - - ///Заполняет весь буфер копиями указанного значения размерного типа - public function AddFillValue(val: TRecord): BufferCommandQueue; where TRecord: record; - - ///Заполняет часть буфера копиями указанного значения размерного типа - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddFillValue(val: TRecord; buff_offset, len: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Заполняет весь буфер копиями указанного значения размерного типа - public function AddFillValue(val: CommandQueue): BufferCommandQueue; where TRecord: record; - - ///Заполняет часть буфера копиями указанного значения размерного типа - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddFillValue(val: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue; where TRecord: record; - - {$endregion 2#Fill} - - {$region 3#Copy} - - ///Копирует данные из текущего буфера в b - ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера - public function AddCopyTo(b: CommandQueue): BufferCommandQueue; - - ///Копирует данные из b в текущий буфер - ///Если буферы имеют разный размер - в качестве объёма данных берётся размер меньшего буфера - public function AddCopyForm(b: CommandQueue): BufferCommandQueue; - - ///Копирует данные из текущего буфера в b - ///from_pos указывает отступ в байтах от начала буфера, из которого копируют - ///to_pos указывает отступ в байтах от начала буфера, в который копируют - ///len указывает кол-во копируемых байт - public function AddCopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue; - - ///Копирует данные из b в текущий буфер - ///from_pos указывает отступ в байтах от начала буфера, из которого копируют - ///to_pos указывает отступ в байтах от начала буфера, в который копируют - ///len указывает кол-во копируемых байт - public function AddCopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue; - - {$endregion 3#Copy} - - {$region Get} - - ///Выделяет область неуправляемой памяти и копирует в неё всё содержимое данного буфера - public function AddGetData: CommandQueue; - - ///Выделяет область неуправляемой памяти и копирует в неё часть содержимого данного буфера - ///buff_offset указывает отступ от начала буфера, в байтах - ///len указывает кол-во задействованных байт буфера - public function AddGetData(buff_offset, len: CommandQueue): CommandQueue; - - ///Читает значение указанного размерного типа из начала буфера - public function AddGetValue: CommandQueue; where TRecord: record; - - ///Читает значение указанного размерного типа из буфера - ///buff_offset указывает отступ от начала буфера, в байтах - public function AddGetValue(buff_offset: CommandQueue): CommandQueue; where TRecord: record; - - ///Создаёт массив максимального размера (на сколько хватит байт буфера) и копирует в него содержимое буфера - public function AddGetArray1: CommandQueue; where TRecord: record; - - ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера - public function AddGetArray1(len: CommandQueue): CommandQueue; where TRecord: record; - - ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера - public function AddGetArray2(len1,len2: CommandQueue): CommandQueue; where TRecord: record; - - ///Создаёт массив с указанным кол-вом элементов и копирует в него содержимое буфера - public function AddGetArray3(len1,len2,len3: CommandQueue): CommandQueue; where TRecord: record; - - {$endregion Get} - - end; - - {$endregion BufferCommandQueue} - - {$region KernelCommandQueue} - - ///Представляет очередь-контейнер для команд GPU, применяемых к объекту типа Kernel - KernelCommandQueue = sealed class(GPUCommandContainer) - - {$region constructor's} - - ///Создаёт контейнер команд, который будет применять команды к указанному объекту - public constructor(k: Kernel) := inherited; - ///Создаёт контейнер команд, который будет применять команды к объекту, который вернёт указанная очередь - ///За каждое одно выполнение контейнера - q выполнится ровно один раз - public constructor(q: CommandQueue) := inherited; - - {$endregion constructor's} - - {$region Non-command add's} - - protected function AddCommand(comm: GPUCommand): KernelCommandQueue; - begin - self.commands += comm; - Result := self; - end; - - {$region Queue} - - ///Добавляет выполнение очереди в список обычных команд для GPU - public function AddQueue(q: CommandQueueBase) := AddCommand(MakeQueueCommand(q)); - - {$endregion Queue} - - {$region Proc} - - ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU - public function AddProc(p: Kernel->()) := AddCommand(MakeProcCommand(p)); - ///Добавляет выполнение процедуры на CPU в список обычных команд для GPU - public function AddProc(p: (Kernel, Context)->()) := AddCommand(MakeProcCommand(p)); - - {$endregion Proc} - - {$region Wait} - - ///Добавляет ожидание сигнала выполненности от всех заданных очередей - public function AddWaitAll(params qs: array of CommandQueueBase) := AddCommand(MakeWaitAllCommand(qs)); - ///Добавляет ожидание сигнала выполненности от всех заданных очередей - public function AddWaitAll(qs: sequence of CommandQueueBase) := AddCommand(MakeWaitAllCommand(qs)); - - ///Добавляет ожидание первого сигнала выполненности от одной из заданных очередей - public function AddWaitAny(params qs: array of CommandQueueBase) := AddCommand(MakeWaitAnyCommand(qs)); - ///Добавляет ожидание первого сигнала выполненности от одной из заданных очередей - public function AddWaitAny(qs: sequence of CommandQueueBase) := AddCommand(MakeWaitAnyCommand(qs)); - - ///Добавляет ожидание сигнала выполненности от заданной очереди - public function AddWait(q: CommandQueueBase) := AddWaitAll(q); - - {$endregion Wait} - - {$endregion Non-command add's} - - {$region 1#Exec} - - ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы - public function AddExec1(sz1: CommandQueue; params args: array of KernelArg): KernelCommandQueue; - - ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы - public function AddExec2(sz1,sz2: CommandQueue; params args: array of KernelArg): KernelCommandQueue; - - ///Выполняет kernel с указанным кол-вом ядер и передаёт в него указанные аргументы - public function AddExec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): KernelCommandQueue; - - ///Выполняет kernel с расширенным набором параметров - ///Данная перегрузка используется в первую очередь для тонких оптимизаций - ///Если она вам понадобилась по другой причина - пожалуйста, напишите в issue - public function AddExec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): KernelCommandQueue; - - {$endregion 1#Exec} - - end; - - {$endregion KernelCommandQueue} - - {$endregion GPUCommandContainer} - - {$region Enqueueable's} - - EnqueueableGPUCommand = abstract class(GPUCommand) - - // Если это True - InvokeParams должен возращать (...)->cl_event.Zero - // Иначе останется ивент, который никто не удалил - protected function NeedThread: boolean; virtual := false; - - private function MakeEvList(exp_size: integer; start_ev: EventList): List; - begin - var need_start_ev := (start_ev<>nil) and (start_ev.count<>0); - Result := new List(exp_size + integer(need_start_ev)); - if need_start_ev then Result += start_ev; - end; - protected function ParamCountL1: integer; abstract; - protected function ParamCountL2: integer; abstract; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (T, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; abstract; - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_qr: QueueRes; l2_start_ev: EventList): EventList; - begin - var need_thread := self.NeedThread; - - var evs_l1 := MakeEvList(ParamCountL1, prev_qr.ev); // ожидание до Enqueue - var evs_l2 := MakeEvList(ParamCountL2, l2_start_ev); // ожидание, передаваемое в Enqueue - - var enq_f := InvokeParams(tsk, c, main_dvc, cq, evs_l1, evs_l2); - var ev_l1 := EventList.Combine(evs_l1, tsk, c.Native, main_dvc, cq); - var ev_l2 := EventList.Combine(evs_l2, tsk, c.Native, main_dvc, cq) ?? new EventList; - - NativeUtils.FixCQ(c.Native, main_dvc, cq); - - if not need_thread and (ev_l1=nil) then - begin - Result := enq_f(prev_qr.GetRes, cq, tsk, c, ev_l2); - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(Result.evs.Single, $'Enq by {self.GetType}, waiting on [{ev_l2.evs?.JoinToString}]'); - {$endif EventDebug} - Result.abortable := true; // ev_l2 тут всегда напрямую передаётся в cl.Enqueue*... и ev_l2.abortable всегда true - //ToDo С другой стороны, если ev_l2 абортится - получаем CL_EXEC_STATUS_ERROR_FOR_EVENTS_IN_WAIT_LIST в качестве статуса - // - Надо бы проверить как это всё работает - // - Наверное надо возвращать в Result не только результат enq_f, но и ev_l2, чтоб SmartStatusErr видел другие ивенты - // - Ну и не забыть в .Get* так же поменять. Или лучше объединить этот дубль кода, сколько можно... - end else - begin - var res_ev: UserEvent; - - // Асинхронное Enqueue, придётся пересоздать cq - var lcq := cq; - cq := cl_command_queue.Zero; - - if need_thread then - res_ev := UserEvent.StartBackgroundWork(ev_l1, ()->enq_f(prev_qr.GetRes, lcq, tsk, c, ev_l2), c.Native, tsk - {$ifdef EventDebug}, $'enq of {self.GetType}'{$endif} - ) else - begin - res_ev := tsk.MakeUserEvent(c.Native - {$ifdef EventDebug}, $'{self.GetType}, temp for nested AttachCallback: [{ev_l1?.evs.JoinToString}], then [{ev_l2.evs?.JoinToString}]'{$endif} - ); - - //ВНИМАНИЕ "ev_l1=nil" не может случится, из за условий выше - ev_l1.AttachCallback(()-> - begin - ev_l1.Release({$ifdef EventDebug}$'after waiting before Enq of {self.GetType}'{$endif}); - var enq_ev := enq_f(prev_qr.GetRes, lcq, tsk, c, ev_l2); - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(enq_ev, $'Enq by {self.GetType}, waiting on [{ev_l2.evs?.JoinToString}]'); - {$endif EventDebug} - EventList.AttachCallback(enq_ev, ()->res_ev.SetStatus(CommandExecutionStatus.COMPLETE), tsk, true{$ifdef EventDebug}, $'propagating Enq ev of {self.GetType} to res_ev: {res_ev.uev}'{$endif}); - end, tsk, c.Native, main_dvc, lcq{$ifdef EventDebug}, $'calling Enq of {self.GetType}'{$endif}); - - end; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - System.Threading.Tasks.Task.Run(()->tsk.AddErr(cl.ReleaseCommandQueue(lcq))); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - Result := res_ev; //ВНИМАНИЕ: "Result.abortable" тут установлено автоматически - end; - - end; - - protected function InvokeObj(o: T; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := - Invoke(tsk, c, main_dvc, cq, new QueueResConst(o, nil), prev_ev); - - protected function InvokeQueue(o_q: ()->CommandQueue; tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): EventList; override := - Invoke(tsk, c, main_dvc, cq, o_q().Invoke(tsk, c, main_dvc, false, cq, prev_ev), nil); - - end; - - EnqueueableGetCommand = abstract class(CommandQueue) - protected prev_commands: GPUCommandContainer; - - public constructor(prev_commands: GPUCommandContainer) := - self.prev_commands := prev_commands; - - // Если это True - InvokeParams должен возращать (...)->cl_event.Zero - // Иначе останется ивент, который никто не удалил - protected function NeedThread: boolean; virtual := false; - - protected function ForcePtrQr: boolean; virtual := false; - - private function MakeEvList(exp_size: integer; start_ev: EventList): List; - begin - var need_start_ev := (start_ev<>nil) and (start_ev.count<>0); - Result := new List(exp_size + integer(need_start_ev)); - if need_start_ev then Result += start_ev; - end; - protected function ParamCountL1: integer; abstract; - protected function ParamCountL2: integer; abstract; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (TObj, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; abstract; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - var need_thread := self.NeedThread; - var prev_qr := prev_commands.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - - var evs_l1 := MakeEvList(ParamCountL1, prev_qr.ev); // ожидание до Enqueue - var evs_l2 := MakeEvList(ParamCountL2, nil); // ожидание, передаваемое в Enqueue - - var enq_f := InvokeParams(tsk, c, main_dvc, cq, evs_l1, evs_l2); - var ev_l1 := EventList.Combine(evs_l1, tsk, c.Native, main_dvc, cq); - var ev_l2 := EventList.Combine(evs_l2, tsk, c.Native, main_dvc, cq) ?? new EventList; - - NativeUtils.FixCQ(c.Native, main_dvc, cq); - - var qr := QueueResDelayedBase&.MakeNew(need_ptr_qr or ForcePtrQr); - Result := qr; - - if not need_thread and (ev_l1=nil) then - begin - Result.ev := enq_f(prev_qr.GetRes, cq, tsk, ev_l2, qr); - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(Result.ev.evs.Single, $'Enq by {self.GetType}, waiting on [{ev_l2.evs?.JoinToString}]'); - {$endif EventDebug} - Result.ev.abortable := true; //ToDo та же история что выше - end else - begin - var res_ev: UserEvent; - - // Асинхронное Enqueue, придётся пересоздать cq - var lcq := cq; - cq := cl_command_queue.Zero; - - if need_thread then - res_ev := UserEvent.StartBackgroundWork(ev_l1, ()->enq_f(prev_qr.GetRes, lcq, tsk, ev_l2, qr), c.Native, tsk - {$ifdef EventDebug}, $'enq of {self.GetType}'{$endif} - ) else - begin - res_ev := tsk.MakeUserEvent(c.Native - {$ifdef EventDebug}, $'{self.GetType}, temp for nested AttachCallback: [{ev_l1?.evs.JoinToString}], then [{ev_l2.evs?.JoinToString}]'{$endif} - ); - - //ВНИМАНИЕ "ev_l1=nil" не может случится, из за условий выше - ev_l1.AttachCallback(()-> - begin - ev_l1.Release({$ifdef EventDebug}$'after waiting before Enq of {self.GetType}'{$endif}); - var enq_ev := enq_f(prev_qr.GetRes, lcq, tsk, ev_l2, qr); - {$ifdef EventDebug} - EventDebug.RegisterEventRetain(enq_ev, $'Enq by {self.GetType}, waiting on [{ev_l2.evs?.JoinToString}]'); - {$endif EventDebug} - EventList.AttachCallback(enq_ev, ()->res_ev.SetStatus(CommandExecutionStatus.COMPLETE), tsk, true{$ifdef EventDebug}, $'propagating Enq ev of {self.GetType} to res_ev: {res_ev.uev}'{$endif}); - end, tsk, c.Native, main_dvc, lcq{$ifdef EventDebug}, $'calling Enq of {self.GetType}'{$endif}); - - end; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - System.Threading.Tasks.Task.Run(()->tsk.AddErr(cl.ReleaseCommandQueue(lcq))); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - Result.ev := res_ev; //ВНИМАНИЕ: "Result.abortable" тут установлено автоматически - end; - - end; - - end; - - {$endregion Enqueueable's} - - {$region KernelArg} - - ISetableKernelArg = interface - procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); - end; - ///Представляет аргумент, передаваемый в вызов kernel-а - KernelArg = abstract class - - {$region Def} - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; abstract; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); abstract; - - {$endregion Def} - - {$region Buffer} - - ///Создаёт аргумент kernel-а, представляющий буфер - public static function FromBuffer(b: Buffer): KernelArg; - public static function operator implicit(b: Buffer): KernelArg := FromBuffer(b); - - ///Создаёт аргумент kernel-а, представляющий буфер - public static function FromBufferCQ(bq: CommandQueue): KernelArg; - public static function operator implicit(bq: CommandQueue): KernelArg := FromBufferCQ(bq); - public static function operator implicit(bq: BufferCommandQueue): KernelArg := FromBufferCQ(bq as CommandQueue); - - {$endregion Buffer} - - {$region Record} - - ///Создаёт аргумент kernel-а, представляющий небольшое значение размерного типа - public static function FromRecord(val: TRecord): KernelArg; where TRecord: record; - public static function operator implicit(val: TRecord): KernelArg; where TRecord: record; begin Result := FromRecord(val); end; - - ///Создаёт аргумент kernel-а, представляющий небольшое значение размерного типа - public static function FromRecordCQ(valq: CommandQueue): KernelArg; where TRecord: record; - public static function operator implicit(valq: CommandQueue): KernelArg; where TRecord: record; begin Result := FromRecordCQ(valq); end; - - {$endregion Record} - - {$region Ptr} - - ///Создаёт аргумент kernel-а, представляющий адрес в неуправляемой памяти - public static function FromPtr(ptr: IntPtr; sz: UIntPtr): KernelArg; - - ///Создаёт аргумент kernel-а, представляющий адрес в неуправляемой памяти - public static function FromPtrCQ(ptr_q: CommandQueue; sz_q: CommandQueue): KernelArg; - - ///Создаёт аргумент kernel-а, представляющий адрес размерного значения со стека - ///Внимание! Адрес должен ссылаться именно на стек, иначе программа может время от времени падать с ошибками доступа к памяти - ///Это значит, что передавать можно только адрес локальной переменной, не захваченной ни одной лямбдой - public static function FromRecordPtr(ptr: ^TRecord): KernelArg; where TRecord: record; begin Result := FromPtr(new IntPtr(ptr), new UIntPtr(Marshal.SizeOf&)); end; - public static function operator implicit(ptr: ^TRecord): KernelArg; where TRecord: record; begin Result := FromRecordPtr(ptr); end; - - {$endregion Ptr} - - end; - - {$endregion KernelArg} - -implementation - -{$region DelayedImpl} - -{$region Device} - -function Device.Split(props: array of DevicePartitionProperty): array of SubDevice; -begin - if supported_split_modes=nil then supported_split_modes := Properties.PartitionType; - if not supported_split_modes.Contains(props[0]) then - raise new NotSupportedException($'Данный режим .Split не поддерживается выбранным устройством'); - - var c: UInt32; - cl.CreateSubDevices(self.Native, props, 0, IntPtr.Zero, c).RaiseIfError; - - var res := new cl_device_id[int64(c)]; - cl.CreateSubDevices(self.Native, props, c, res[0], IntPtr.Zero).RaiseIfError; - - Result := res.ConvertAll(sdvc->new SubDevice(sdvc, self)); -end; - -{$endregion Device} - -{$region Buffer} - -function Buffer.NewQueue := new BufferCommandQueue(self); - -{$endregion Buffer} - -{$region Kernel} - -function Kernel.NewQueue := new KernelCommandQueue(self); - -{$endregion Kernel} - -{$region EventList} - -static function EventList.Combine(evs: IList; tsk: CLTaskBase; c: cl_context; main_dvc: cl_device_id; var cq: cl_command_queue): EventList; -begin - var count := 0; - var need_abort_ev := true; - - for var i := 0 to evs.Count-1 do - begin - count += evs[i].count; - if need_abort_ev and evs[i].abortable then need_abort_ev := false; - end; - if count=0 then exit; - - Result := new EventList(count + integer(need_abort_ev)); - - for var i := 0 to evs.Count-1 do - Result += evs[i]; - - if need_abort_ev then - begin - var uev := tsk.MakeUserEvent(c - {$ifdef EventDebug}, $'abortability of EventList.Combine of: {Result.evs.Take(Result.count).JoinToString}'{$endif} - ); - Result.AttachCallback(()->uev.SetStatus(CommandExecutionStatus.COMPLETE), tsk, c, main_dvc, cq - {$ifdef EventDebug}, $'setting abort ev: {uev.uev}'{$endif} - ); - Result += cl_event(uev); - Result.abortable := true; - end; - -end; - -{$endregion EventList} - -{$region QueueRes} - -static function QueueResDelayedBase.MakeNew(need_ptr_qr: boolean) := need_ptr_qr ? -new QueueResDelayedPtr as QueueResDelayedBase : -new QueueResDelayedObj as QueueResDelayedBase; - -{$endregion QueueRes} - -{$region UserEvent} - -static function UserEvent.MakeUserEvent(tsk: CLTaskBase; c: cl_context{$ifdef EventDebug}; reason: string{$endif}) := tsk.MakeUserEvent(c{$ifdef EventDebug}, reason{$endif}); - -{$endregion UserEvent} - -{$region CLTask} - -static procedure CLTaskExt.AddErr(tsk: CLTaskBase; e: Exception) := tsk.AddErr(e); -static function CLTaskExt.AddErr(tsk: CLTaskBase; ec: ErrorCode) := tsk.AddErr(ec); -static function CLTaskExt.AddErr(tsk: CLTaskBase; st: CommandExecutionStatus) := tsk.AddErr(st); - -function CLTask.OrgQueueBase: CommandQueueBase := self.OrgQueue; - -procedure CLTask.RegisterWaitables(q: CommandQueue) := q.RegisterWaitables(self, new HashSet); - -function CLTask.InvokeQueue(q: CommandQueue; c: Context; var cq: cl_command_queue): QueueRes := -q.Invoke(self, c, c.MainDevice.Native, false, cq, nil); - -{$endregion CLTask} - -{$region CommandQueue} - -static function CommandQueueBase.operator implicit(o: object): CommandQueueBase := -new ConstQueue(o); - -static function CommandQueue.operator implicit(o: T): CommandQueue := -new ConstQueue(o); - -{$endregion CommandQueue} - -{$endregion DelayedImpl} - -{$region CLTaskResLess} - -type - CLTaskResLess = sealed class(CLTaskBase) - protected q: CommandQueueBase; - protected q_res: object; - - protected function OrgQueueBase: CommandQueueBase; override := q; - - protected constructor(q: CommandQueueBase; c: Context); - begin - self.q := q; - self.org_c := c; - q.RegisterWaitables(self, new HashSet); - - var cq: cl_command_queue; - var qr := q.InvokeBase(self, c, c.MainDevice.Native, false, cq, nil); - - // mu выполняют лишний .Retain, чтобы ивент не удалился пока очередь ещё запускается - foreach var mu_qr in mu_res.Values do - mu_qr.ev.Release({$ifdef EventDebug}$'excessive mu ev'{$endif}); - mu_res := nil; - - {$ifdef DEBUG} - //CQ.Invoke всегда выполняет UserEvent.EnsureAbortability, поэтому тут оно не нужно - if (qr.ev.count<>0) and not qr.ev.abortable then raise new NotSupportedException; - {$endif DEBUG} - - qr.ev.AttachFinallyCallback(()-> - begin - qr.ev.Release({$ifdef EventDebug}$'last ev of CLTask'{$endif}); - if cq<>cl_command_queue.Zero then - System.Threading.Tasks.Task.Run(()->self.AddErr( cl.ReleaseCommandQueue(cq) )); - OnQDone(qr); - end, self, c.Native, c.MainDevice.Native, cq{$ifdef EventDebug}, $'CLTaskResLess.OnQDone'{$endif}); - - end; - - {$region CLTask event's} - - protected EvDone := new List>; - protected procedure WhenDoneBase(cb: Action); override := - if AddEventHandler(EvDone, cb) then cb(self); - - protected EvComplete := new List>; - protected procedure WhenCompleteBase(cb: Action); override := - if AddEventHandler(EvComplete, cb) then cb(self, q_res); - - protected EvError := new List>; - protected procedure WhenErrorBase(cb: Action); override := - if AddEventHandler(EvError, cb) then cb(self, GetErrArr); - - {$endregion CLTask event's} - - {$region Execution} - - private procedure OnQDone(qr: QueueResBase); - begin - var l_EvDone: array of Action; - var l_EvComplete: array of Action; - var l_EvError: array of Action; - - lock wh_lock do - try - - l_EvDone := EvDone.ToArray; - l_EvComplete := EvComplete.ToArray; - l_EvError := EvError.ToArray; - - if err_lst.Count=0 then self.q_res := qr.GetResBase; - finally - wh.Set; - end; - - foreach var ev in l_EvDone do - try - ev(self); - except - on e: Exception do AddErr(e); - end; - - if err_lst.Count=0 then - begin - - foreach var ev in l_EvComplete do - try - ev(self, self.q_res); - except - on e: Exception do AddErr(e); - end; - - end else - if l_EvError.Length<>0 then - begin - var err_arr := GetErrArr; - - foreach var ev in l_EvError do - try - ev(self, err_arr); - except - on e: Exception do AddErr(e); - end; - - end; - - end; - - protected function WaitResBase: object; override; - begin - Wait; - Result := q_res; - end; - - {$endregion Execution} - - end; - -function Context.BeginInvoke(q: CommandQueue) := new CLTask(q, self); -function Context.BeginInvoke(q: CommandQueueBase) := new CLTaskResLess(q, self); - -function Context.SyncInvoke(q: CommandQueue) := BeginInvoke(q).WaitRes; -function Context.SyncInvoke(q: CommandQueueBase) := BeginInvoke(q).WaitRes; - -{$endregion CLTaskResLess} - -{$region Queue converter's} - -{$region Cast} - -type - CastQueue = sealed class(CommandQueue) - private q: CommandQueueBase; - - public constructor(q: CommandQueueBase) := self.q := q; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override := - q.InvokeBase(tsk, c, main_dvc, false, cq, prev_ev).LazyQuickTransformBase(o->T(o)); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - q.RegisterWaitables(tsk, prev_hubs); - - end; - -function CommandQueueBase.Cast := new CastQueue(self); - -{$endregion Cast} - -{$region ThenConvert} - -type - CommandQueueThenConvert = sealed class(HostQueue) - protected q: CommandQueue; - protected f: (TInp, Context)->TRes; - - public constructor(q: CommandQueue; f: (TInp, Context)->TRes); - begin - self.q := q; - self.f := f; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - q.RegisterWaitables(tsk, prev_hubs); - - protected function InvokeSubQs(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override := - q.Invoke(tsk, c, main_dvc, false, cq, prev_ev); - - protected function ExecFunc(o: TInp; c: Context): TRes; override := f(o, c); - - end; - -function CommandQueue.ThenConvert(f: (T, Context)->TOtp) := -new CommandQueueThenConvert(self, f); - -{$endregion ThenConvert} - -{$region QueueArray} - -static function CommandQueue.operator+(q1: CommandQueueBase; q2: CommandQueue) := new SimpleSyncQueueArray(q1, q2); -static function CommandQueue.operator*(q1: CommandQueueBase; q2: CommandQueue) := new SimpleAsyncQueueArray(q1, q2); - -{$endregion QueueArray} - -{$region Multiusable} - -type - MultiusableCommandQueueHub = sealed class(MultiusableCommandQueueHubBase) - public q: CommandQueue; - public constructor(q: CommandQueue) := self.q := q; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public function OnNodeInvoked(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean): QueueRes; - begin - - var res_o: QueueResBase; - if tsk.mu_res.TryGetValue(self, res_o) then - Result := QueueRes&( res_o ) else - begin - Result := self.q.InvokeNewQ(tsk, c, main_dvc, need_ptr_qr, nil); - Result.can_set_ev := false; - tsk.mu_res[self] := Result; - end; - - Result.ev.Retain({$ifdef EventDebug}$'for all mu branches'{$endif}); - end; - - public function MakeNode: CommandQueue; - - end; - - MultiusableCommandQueueNode = sealed class(CommandQueue) - public hub: MultiusableCommandQueueHub; - public constructor(hub: MultiusableCommandQueueHub) := self.hub := hub; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - Result := hub.OnNodeInvoked(tsk, c, main_dvc, need_ptr_qr); - if prev_ev<>nil then Result := Result.TrySetEv( prev_ev + Result.ev ); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - if prev_hubs.Add(hub) then hub.q.RegisterWaitables(tsk, prev_hubs); - - end; - -function MultiusableCommandQueueHub.MakeNode := -new MultiusableCommandQueueNode(self); - -function CommandQueue.Multiusable: ()->CommandQueue := MultiusableCommandQueueHub&.Create(self).MakeNode; - -{$endregion Multiusable} - -{$region ThenWait} - -type - CommandQueueThenWaitFor = sealed class(CommandQueue) - public q: CommandQueue; - public waiter: WCQWaiter; - - public constructor(q: CommandQueue; waiter: WCQWaiter); - begin - self.q := q; - self.waiter := waiter; - end; - - protected function InvokeImpl(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - Result := q.Invoke(tsk, c, main_dvc, need_ptr_qr, cq, prev_ev); - Result := Result.TrySetEv( Result.ev + waiter.GetWaitEv(tsk, c) ); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - q.RegisterWaitables(tsk, prev_hubs); - waiter.RegisterWaitables(tsk); - end; - - end; - -function CommandQueue.ThenWaitForAll(qs: sequence of CommandQueueBase) := -new CommandQueueThenWaitFor(self, new WCQWaiterAll(qs.ToArray)); - -function CommandQueue.ThenWaitForAny(qs: sequence of CommandQueueBase) := -new CommandQueueThenWaitFor(self, new WCQWaiterAny(qs.ToArray)); - -{$endregion ThenWait} - -{$endregion Queue converter's} - -{$region GPUCommandContainerBody} - -type - CCBObj = sealed class(GPUCommandContainerBody) - public o: T; - - public constructor(o: T; cc: GPUCommandContainer); - begin - self.o := o; - self.cc := cc; - end; - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - var res_obj := self.o; - cc.InitObj(res_obj, c); - - foreach var comm in cc.commands do - prev_ev := comm.InvokeObj(res_obj, tsk, c, main_dvc, cq, prev_ev); - - Result := new QueueResConst(res_obj, prev_ev ?? new EventList); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; - - end; - CCBQueue = sealed class(GPUCommandContainerBody) - public hub: MultiusableCommandQueueHub; - - public constructor(q: CommandQueue; cc: GPUCommandContainer); - begin - self.hub := new MultiusableCommandQueueHub(q); - self.cc := cc; - end; - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; need_ptr_qr: boolean; var cq: cl_command_queue; prev_ev: EventList): QueueRes; override; - begin - var new_plug: ()->CommandQueue := hub.MakeNode; - // new_plub всегда делает mu ноду, а она не использует prev_ev - // это тут, чтобы хаб передал need_ptr_qr. Он делает это при первом Invoke - Result := new_plug().Invoke(tsk, c, main_dvc, need_ptr_qr, cq, nil); - - foreach var comm in cc.commands do - prev_ev := comm.InvokeQueue(new_plug, tsk, c, main_dvc, cq, prev_ev); - - Result := Result.TrySetEv( prev_ev ?? new EventList ); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - hub.q.RegisterWaitables(tsk, prev_hubs); - - end; - -constructor GPUCommandContainer.Create(o: T) := -self.body := new CCBObj(o, self); - -constructor GPUCommandContainer.Create(q: CommandQueue) := -self.body := new CCBQueue(q, self); - -{$endregion GPUCommandContainerBody} - -{$region KernelArg} - -{$region Const} - -{$region Base} - -type - ConstKernelArg = abstract class(KernelArg, ISetableKernelArg) - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override := - new QueueResConst(self, new EventList); - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; - - public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); abstract; - - end; - -{$endregion Base} - -{$region Buffer} - -type - KernelArgBuffer = sealed class(ConstKernelArg) - private b: Buffer; - - public constructor(b: Buffer) := self.b := b; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); override; - begin - b.InitIfNeed(c); - cl.SetKernelArg(k, ind, new UIntPtr(cl_mem.Size), b.ntv).RaiseIfError; - end; - - end; - -static function KernelArg.FromBuffer(b: Buffer) := new KernelArgBuffer(b) as KernelArg; //ToDo #1981 - -{$endregion Buffer} - -{$region Record} - -type - KernelArgRecord = sealed class(ConstKernelArg) - where TRecord: record; - private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); - - public constructor(val: TRecord) := self.val^ := val; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected procedure Finalize; override := - Marshal.FreeHGlobal(new IntPtr(val)); - - public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); override := - cl.SetKernelArg(k, ind, new UIntPtr(Marshal.SizeOf&), pointer(self.val)).RaiseIfError; - - end; - -static function KernelArg.FromRecord(val: TRecord) := new KernelArgRecord(val) as KernelArg; //ToDo #1981 - -{$endregion Record} - -{$region Ptr} - -type - KernelArgPtr = sealed class(ConstKernelArg) - private ptr: IntPtr; - private sz: UIntPtr; - - public constructor(ptr: IntPtr; sz: UIntPtr); - begin - self.ptr := ptr; - self.sz := sz; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); override := - cl.SetKernelArg(k, ind, sz, pointer(ptr)).RaiseIfError; - - end; - -static function KernelArg.FromPtr(ptr: IntPtr; sz: UIntPtr) := new KernelArgPtr(ptr, sz) as KernelArg; //ToDo #1981 - -{$endregion Ptr} - -{$endregion Const} - -{$region Invokeable} - -{$region Base} - -type - InvokeableKernelArg = abstract class(KernelArg) end; - -{$endregion Base} - -{$region Buffer} - -type - KernelArgBufferCQ = sealed class(InvokeableKernelArg) - public q: CommandQueue; - public constructor(q: CommandQueue) := self.q := q; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override := - q.InvokeNewQ(tsk, c, main_dvc, false, nil).LazyQuickTransform(b->new KernelArgBuffer(b) as ConstKernelArg as ISetableKernelArg); //ToDo #2289 - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - q.RegisterWaitables(tsk, prev_hubs); - - end; - -static function KernelArg.FromBufferCQ(bq: CommandQueue) := -new KernelArgBufferCQ(bq) as KernelArg; - -{$endregion Buffer} - -{$region Record} - -type - KernelArgRecordQR = sealed class(ISetableKernelArg) - where TRecord: record; - public qr: QueueRes; - public constructor(qr: QueueRes) := self.qr := qr; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - public procedure SetArg(k: cl_kernel; ind: UInt32; c: Context); - begin - var sz := new UIntPtr(Marshal.SizeOf&); - if qr is QueueResDelayedPtr(var pqr) then - cl.SetKernelArg(k, ind, sz, pointer(pqr.ptr)).RaiseIfError else - begin - var val := qr.GetRes; - cl.SetKernelArg(k, ind, sz, val).RaiseIfError; - end; - end; - - end; - KernelArgRecordCQ = sealed class(InvokeableKernelArg) - where TRecord: record; - public q: CommandQueue; - public constructor(q: CommandQueue) := self.q := q; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override; - begin - var prev_qr := q.InvokeNewQ(tsk, c, main_dvc, true, nil); - Result := new QueueResConst(new KernelArgRecordQR(prev_qr), prev_qr.ev); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := - q.RegisterWaitables(tsk, prev_hubs); - - end; - -static function KernelArg.FromRecordCQ(valq: CommandQueue) := -new KernelArgRecordCQ(valq) as KernelArg; - -{$endregion Record} - -{$region Ptr} - -type - KernelArgPtrCQ = sealed class(InvokeableKernelArg) - public ptr_q: CommandQueue; - public sz_q: CommandQueue; - public constructor(ptr_q: CommandQueue; sz_q: CommandQueue); - begin - self.ptr_q := ptr_q; - self.sz_q := sz_q; - end; - private constructor := raise new InvalidOperationException($'Был вызван не_применимый конструктор без параметров... Обратитесь к разработчику OpenCLABC'); - - protected function Invoke(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id): QueueRes; override; - begin - var ptr_qr := ptr_q.InvokeNewQ(tsk, c, main_dvc, false, nil); - var sz_qr := sz_q.InvokeNewQ(tsk, c, main_dvc, false, nil); - Result := new QueueResFunc(()->new KernelArgPtr(ptr_qr.GetRes, sz_qr.GetRes), ptr_qr.ev+sz_qr.ev); - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr_q.RegisterWaitables(tsk, prev_hubs); - sz_q.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -static function KernelArg.FromPtrCQ(ptr_q: CommandQueue; sz_q: CommandQueue) := -new KernelArgPtrCQ(ptr_q, sz_q) as KernelArg; - -{$endregion Ptr} - -{$endregion Invokeable} - -{$endregion KernelArg} - -{$region CommonCommands} - -{$region BufferCQ} - -{$region 1#Write&Read} - -{$region WriteDataAutoSize} - -type - BufferCommandWriteDataAutoSize = sealed class(EnqueueableGPUCommand) - private ptr: CommandQueue; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(ptr: CommandQueue); - begin - self.ptr := ptr; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += ptr_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var ptr := ptr_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.NON_BLOCKING, - UIntPtr.Zero, o.Size, - ptr, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteDataAutoSize} - -function BufferCommandQueue.AddWriteData(ptr: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteDataAutoSize(ptr)); - -{$region ReadDataAutoSize} - -type - BufferCommandReadDataAutoSize = sealed class(EnqueueableGPUCommand) - private ptr: CommandQueue; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(ptr: CommandQueue); - begin - self.ptr := ptr; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += ptr_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var ptr := ptr_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueReadBuffer( - cq, o.Native, Bool.NON_BLOCKING, - UIntPtr.Zero, o.Size, - ptr, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadDataAutoSize} - -function BufferCommandQueue.AddReadData(ptr: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadDataAutoSize(ptr)); - -{$region WriteData} - -type - BufferCommandWriteData = sealed class(EnqueueableGPUCommand) - private ptr: CommandQueue; - private buff_offset: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 3; - protected function ParamCountL2: integer; override := 0; - - public constructor(ptr: CommandQueue; buff_offset, len: CommandQueue); - begin - self. ptr := ptr; - self.buff_offset := buff_offset; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += ptr_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var ptr := ptr_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.NON_BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len), - ptr, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteData} - -function BufferCommandQueue.AddWriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteData(ptr, buff_offset, len)); - -{$region ReadData} - -type - BufferCommandReadData = sealed class(EnqueueableGPUCommand) - private ptr: CommandQueue; - private buff_offset: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 3; - protected function ParamCountL2: integer; override := 0; - - public constructor(ptr: CommandQueue; buff_offset, len: CommandQueue); - begin - self. ptr := ptr; - self.buff_offset := buff_offset; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += ptr_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var ptr := ptr_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueReadBuffer( - cq, o.Native, Bool.NON_BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len), - ptr, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadData} - -function BufferCommandQueue.AddReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadData(ptr, buff_offset, len)); - -function BufferCommandQueue.AddWriteData(ptr: pointer): BufferCommandQueue := -AddWriteData(IntPtr(ptr)); - -function BufferCommandQueue.AddReadData(ptr: pointer): BufferCommandQueue := -AddReadData(IntPtr(ptr)); - -function BufferCommandQueue.AddWriteData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue := -AddWriteData(IntPtr(ptr), buff_offset, len); - -function BufferCommandQueue.AddReadData(ptr: pointer; buff_offset, len: CommandQueue): BufferCommandQueue := -AddReadData(IntPtr(ptr), buff_offset, len); - -function BufferCommandQueue.AddWriteValue(val: TRecord): BufferCommandQueue := -AddWriteValue(val, 0); - -{$region WriteValue} - -type - BufferCommandWriteValue = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); - private buff_offset: CommandQueue; - - protected procedure Finalize; override; - begin - Marshal.FreeHGlobal(new IntPtr(val)); - end; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(val: TRecord; buff_offset: CommandQueue); - begin - self. val^ := val; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var buff_offset := buff_offset_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.NON_BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(Marshal.SizeOf&), - new IntPtr(val), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteValue} - -function BufferCommandQueue.AddWriteValue(val: TRecord; buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteValue(val, buff_offset)); - -function BufferCommandQueue.AddWriteValue(val: CommandQueue): BufferCommandQueue := -AddWriteValue(val, 0); - -{$region WriteValueQ} - -type - BufferCommandWriteValueQ = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private val: CommandQueue; - private buff_offset: CommandQueue; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 1; - - public constructor(val: CommandQueue; buff_offset: CommandQueue); - begin - self. val := val; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var val_qr := val.Invoke (tsk, c, main_dvc, True, cq, nil); evs_l2 += val_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var val := val_qr.ToPtr; - var buff_offset := buff_offset_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.NON_BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(Marshal.SizeOf&), - new IntPtr(val.GetPtr), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - var val_hnd := GCHandle.Alloc(val); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - val_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - val.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteValueQ} - -function BufferCommandQueue.AddWriteValue(val: CommandQueue; buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteValueQ(val, buff_offset)); - -{$region WriteArray1AutoSize} - -type - BufferCommandWriteArray1AutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue); - begin - self.a := a; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - - try - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.BLOCKING, - UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), - a[0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteArray1AutoSize} - -function BufferCommandQueue.AddWriteArray1(a: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteArray1AutoSize(a)); - -{$region WriteArray2AutoSize} - -type - BufferCommandWriteArray2AutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue); - begin - self.a := a; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - - try - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.BLOCKING, - UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), - a[0,0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteArray2AutoSize} - -function BufferCommandQueue.AddWriteArray2(a: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteArray2AutoSize(a)); - -{$region WriteArray3AutoSize} - -type - BufferCommandWriteArray3AutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue); - begin - self.a := a; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - - try - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.BLOCKING, - UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), - a[0,0,0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteArray3AutoSize} - -function BufferCommandQueue.AddWriteArray3(a: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteArray3AutoSize(a)); - -{$region ReadArray1AutoSize} - -type - BufferCommandReadArray1AutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue); - begin - self.a := a; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - - try - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), - a[0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadArray1AutoSize} - -function BufferCommandQueue.AddReadArray1(a: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadArray1AutoSize(a)); - -{$region ReadArray2AutoSize} - -type - BufferCommandReadArray2AutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue); - begin - self.a := a; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - - try - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), - a[0,0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadArray2AutoSize} - -function BufferCommandQueue.AddReadArray2(a: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadArray2AutoSize(a)); - -{$region ReadArray3AutoSize} - -type - BufferCommandReadArray3AutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue); - begin - self.a := a; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - - try - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - UIntPtr.Zero, new UIntPtr(a.Length*Marshal.SizeOf&), - a[0,0,0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadArray3AutoSize} - -function BufferCommandQueue.AddReadArray3(a: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadArray3AutoSize(a)); - -{$region WriteArray1} - -type - BufferCommandWriteArray1 = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - private a_offset: CommandQueue; - private len: CommandQueue; - private buff_offset: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue; a_offset, len, buff_offset: CommandQueue); - begin - self. a := a; - self. a_offset := a_offset; - self. len := len; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - var a_offset_qr := a_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - var a_offset := a_offset_qr.GetRes; - var len := len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - - try - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), - a[a_offset], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - a_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteArray1} - -function BufferCommandQueue.AddWriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteArray1(a, a_offset, len, buff_offset)); - -{$region WriteArray2} - -type - BufferCommandWriteArray2 = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - private a_offset1: CommandQueue; - private a_offset2: CommandQueue; - private len: CommandQueue; - private buff_offset: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 5; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue); - begin - self. a := a; - self. a_offset1 := a_offset1; - self. a_offset2 := a_offset2; - self. len := len; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset1_qr.ev; - var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset2_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - var a_offset1 := a_offset1_qr.GetRes; - var a_offset2 := a_offset2_qr.GetRes; - var len := len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - - try - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), - a[a_offset1,a_offset2], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - a_offset1.RegisterWaitables(tsk, prev_hubs); - a_offset2.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteArray2} - -function BufferCommandQueue.AddWriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteArray2(a, a_offset1, a_offset2, len, buff_offset)); - -{$region WriteArray3} - -type - BufferCommandWriteArray3 = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - private a_offset1: CommandQueue; - private a_offset2: CommandQueue; - private a_offset3: CommandQueue; - private len: CommandQueue; - private buff_offset: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 6; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue); - begin - self. a := a; - self. a_offset1 := a_offset1; - self. a_offset2 := a_offset2; - self. a_offset3 := a_offset3; - self. len := len; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset1_qr.ev; - var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset2_qr.ev; - var a_offset3_qr := a_offset3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset3_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - var a_offset1 := a_offset1_qr.GetRes; - var a_offset2 := a_offset2_qr.GetRes; - var a_offset3 := a_offset3_qr.GetRes; - var len := len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - - try - cl.EnqueueWriteBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), - a[a_offset1,a_offset2,a_offset3], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - a_offset1.RegisterWaitables(tsk, prev_hubs); - a_offset2.RegisterWaitables(tsk, prev_hubs); - a_offset3.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion WriteArray3} - -function BufferCommandQueue.AddWriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandWriteArray3(a, a_offset1, a_offset2, a_offset3, len, buff_offset)); - -{$region ReadArray1} - -type - BufferCommandReadArray1 = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - private a_offset: CommandQueue; - private len: CommandQueue; - private buff_offset: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue; a_offset, len, buff_offset: CommandQueue); - begin - self. a := a; - self. a_offset := a_offset; - self. len := len; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - var a_offset_qr := a_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - var a_offset := a_offset_qr.GetRes; - var len := len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - - try - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), - a[a_offset], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - a_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadArray1} - -function BufferCommandQueue.AddReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadArray1(a, a_offset, len, buff_offset)); - -{$region ReadArray2} - -type - BufferCommandReadArray2 = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - private a_offset1: CommandQueue; - private a_offset2: CommandQueue; - private len: CommandQueue; - private buff_offset: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 5; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue); - begin - self. a := a; - self. a_offset1 := a_offset1; - self. a_offset2 := a_offset2; - self. len := len; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset1_qr.ev; - var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset2_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - var a_offset1 := a_offset1_qr.GetRes; - var a_offset2 := a_offset2_qr.GetRes; - var len := len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - - try - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), - a[a_offset1,a_offset2], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - a_offset1.RegisterWaitables(tsk, prev_hubs); - a_offset2.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadArray2} - -function BufferCommandQueue.AddReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadArray2(a, a_offset1, a_offset2, len, buff_offset)); - -{$region ReadArray3} - -type - BufferCommandReadArray3 = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private a: CommandQueue; - private a_offset1: CommandQueue; - private a_offset2: CommandQueue; - private a_offset3: CommandQueue; - private len: CommandQueue; - private buff_offset: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 6; - protected function ParamCountL2: integer; override := 0; - - public constructor(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue); - begin - self. a := a; - self. a_offset1 := a_offset1; - self. a_offset2 := a_offset2; - self. a_offset3 := a_offset3; - self. len := len; - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var a_qr := a.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += a_qr.ev; - var a_offset1_qr := a_offset1.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset1_qr.ev; - var a_offset2_qr := a_offset2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset2_qr.ev; - var a_offset3_qr := a_offset3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += a_offset3_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var a := a_qr.GetRes; - var a_offset1 := a_offset1_qr.GetRes; - var a_offset2 := a_offset2_qr.GetRes; - var a_offset3 := a_offset3_qr.GetRes; - var len := len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - - try - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len*Marshal.SizeOf&), - a[a_offset1,a_offset2,a_offset3], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - a.RegisterWaitables(tsk, prev_hubs); - a_offset1.RegisterWaitables(tsk, prev_hubs); - a_offset2.RegisterWaitables(tsk, prev_hubs); - a_offset3.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion ReadArray3} - -function BufferCommandQueue.AddReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandReadArray3(a, a_offset1, a_offset2, a_offset3, len, buff_offset)); - -{$endregion 1#Write&Read} - -{$region 2#Fill} - -{$region FillDataAutoSize} - -type - BufferCommandFillDataAutoSize = sealed class(EnqueueableGPUCommand) - private ptr: CommandQueue; - private pattern_len: CommandQueue; - - protected function ParamCountL1: integer; override := 2; - protected function ParamCountL2: integer; override := 0; - - public constructor(ptr: CommandQueue; pattern_len: CommandQueue); - begin - self. ptr := ptr; - self.pattern_len := pattern_len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += ptr_qr.ev; - var pattern_len_qr := pattern_len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += pattern_len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var ptr := ptr_qr.GetRes; - var pattern_len := pattern_len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueFillBuffer( - cq, o.ntv, - ptr, new UIntPtr(pattern_len), - UIntPtr.Zero, o.Size, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr.RegisterWaitables(tsk, prev_hubs); - pattern_len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion FillDataAutoSize} - -function BufferCommandQueue.AddFillData(ptr: CommandQueue; pattern_len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandFillDataAutoSize(ptr, pattern_len)); - -{$region FillData} - -type - BufferCommandFillData = sealed class(EnqueueableGPUCommand) - private ptr: CommandQueue; - private pattern_len: CommandQueue; - private buff_offset: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue); - begin - self. ptr := ptr; - self.pattern_len := pattern_len; - self.buff_offset := buff_offset; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var ptr_qr := ptr.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += ptr_qr.ev; - var pattern_len_qr := pattern_len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += pattern_len_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var ptr := ptr_qr.GetRes; - var pattern_len := pattern_len_qr.GetRes; - var buff_offset := buff_offset_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueFillBuffer( - cq, o.ntv, - ptr, new UIntPtr(pattern_len), - new UIntPtr(buff_offset), new UIntPtr(len), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - ptr.RegisterWaitables(tsk, prev_hubs); - pattern_len.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion FillData} - -function BufferCommandQueue.AddFillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandFillData(ptr, pattern_len, buff_offset, len)); - -{$region FillValueAutoSize} - -type - BufferCommandFillValueAutoSize = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); - - protected procedure Finalize; override; - begin - Marshal.FreeHGlobal(new IntPtr(val)); - end; - - protected function ParamCountL1: integer; override := 0; - protected function ParamCountL2: integer; override := 0; - - public constructor(val: TRecord); - begin - self.val^ := val; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - - Result := (o, cq, tsk, c, evs)-> - begin - var res_ev: cl_event; - - cl.EnqueueFillBuffer( - cq, o.ntv, - new IntPtr(val), new UIntPtr(Marshal.SizeOf&), - UIntPtr.Zero, o.Size, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - end; - - end; - -{$endregion FillValueAutoSize} - -function BufferCommandQueue.AddFillValue(val: TRecord): BufferCommandQueue := -AddCommand(new BufferCommandFillValueAutoSize(val)); - -{$region FillValue} - -type - BufferCommandFillValue = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private val: ^TRecord := pointer(Marshal.AllocHGlobal(Marshal.SizeOf&)); - private buff_offset: CommandQueue; - private len: CommandQueue; - - protected procedure Finalize; override; - begin - Marshal.FreeHGlobal(new IntPtr(val)); - end; - - protected function ParamCountL1: integer; override := 2; - protected function ParamCountL2: integer; override := 0; - - public constructor(val: TRecord; buff_offset, len: CommandQueue); - begin - self. val^ := val; - self.buff_offset := buff_offset; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += buff_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var buff_offset := buff_offset_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueFillBuffer( - cq, o.ntv, - new IntPtr(val), new UIntPtr(Marshal.SizeOf&), - new UIntPtr(buff_offset), new UIntPtr(len), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - buff_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion FillValue} - -function BufferCommandQueue.AddFillValue(val: TRecord; buff_offset, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandFillValue(val, buff_offset, len)); - -{$region FillValueAutoSizeQ} - -type - BufferCommandFillValueAutoSizeQ = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private val: CommandQueue; - - protected function ParamCountL1: integer; override := 0; - protected function ParamCountL2: integer; override := 1; - - public constructor(val: CommandQueue); - begin - self.val := val; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var val_qr := val.Invoke (tsk, c, main_dvc, True, cq, nil); evs_l2 += val_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var val := val_qr.ToPtr; - var res_ev: cl_event; - - cl.EnqueueFillBuffer( - cq, o.ntv, - new IntPtr(val.GetPtr), new UIntPtr(Marshal.SizeOf&), - UIntPtr.Zero, o.Size, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - var val_hnd := GCHandle.Alloc(val); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - val_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - val.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion FillValueAutoSizeQ} - -function BufferCommandQueue.AddFillValue(val: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandFillValueAutoSizeQ(val)); - -{$region FillValueQ} - -type - BufferCommandFillValueQ = sealed class(EnqueueableGPUCommand) - where TRecord: record; - private val: CommandQueue; - private buff_offset: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 2; - protected function ParamCountL2: integer; override := 1; - - public constructor(val: CommandQueue; buff_offset, len: CommandQueue); - begin - self. val := val; - self.buff_offset := buff_offset; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var val_qr := val.Invoke (tsk, c, main_dvc, True, cq, nil); evs_l2 += val_qr.ev; - var buff_offset_qr := buff_offset.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += buff_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var val := val_qr.ToPtr; - var buff_offset := buff_offset_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueFillBuffer( - cq, o.ntv, - new IntPtr(val.GetPtr), new UIntPtr(Marshal.SizeOf&), - new UIntPtr(buff_offset), new UIntPtr(len), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - var val_hnd := GCHandle.Alloc(val); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - val_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - val.RegisterWaitables(tsk, prev_hubs); - buff_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion FillValueQ} - -function BufferCommandQueue.AddFillValue(val: CommandQueue; buff_offset, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandFillValueQ(val, buff_offset, len)); - -{$endregion 2#Fill} - -{$region 3#Copy} - -{$region CopyToAutoSize} - -type - BufferCommandCopyToAutoSize = sealed class(EnqueueableGPUCommand) - private b: CommandQueue; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(b: CommandQueue); - begin - self.b := b; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += b_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var b := b_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueCopyBuffer( - cq, o.ntv,b.ntv, - UIntPtr.Zero, UIntPtr.Zero, - o.Size64 - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - b.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion CopyToAutoSize} - -function BufferCommandQueue.AddCopyTo(b: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandCopyToAutoSize(b)); - -{$region CopyFormAutoSize} - -type - BufferCommandCopyFormAutoSize = sealed class(EnqueueableGPUCommand) - private b: CommandQueue; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(b: CommandQueue); - begin - self.b := b; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += b_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var b := b_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueCopyBuffer( - cq, b.ntv,o.ntv, - UIntPtr.Zero, UIntPtr.Zero, - o.Size64 - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - b.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion CopyFormAutoSize} - -function BufferCommandQueue.AddCopyForm(b: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandCopyFormAutoSize(b)); - -{$region CopyTo} - -type - BufferCommandCopyTo = sealed class(EnqueueableGPUCommand) - private b: CommandQueue; - private from_pos: CommandQueue; - private to_pos: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(b: CommandQueue; from_pos, to_pos, len: CommandQueue); - begin - self. b := b; - self.from_pos := from_pos; - self. to_pos := to_pos; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += b_qr.ev; - var from_pos_qr := from_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += from_pos_qr.ev; - var to_pos_qr := to_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += to_pos_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var b := b_qr.GetRes; - var from_pos := from_pos_qr.GetRes; - var to_pos := to_pos_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueCopyBuffer( - cq, o.ntv,b.ntv, - new UIntPtr(from_pos), new UIntPtr(to_pos), - new UIntPtr(len), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - b.RegisterWaitables(tsk, prev_hubs); - from_pos.RegisterWaitables(tsk, prev_hubs); - to_pos.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion CopyTo} - -function BufferCommandQueue.AddCopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandCopyTo(b, from_pos, to_pos, len)); - -{$region CopyForm} - -type - BufferCommandCopyForm = sealed class(EnqueueableGPUCommand) - private b: CommandQueue; - private from_pos: CommandQueue; - private to_pos: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(b: CommandQueue; from_pos, to_pos, len: CommandQueue); - begin - self. b := b; - self.from_pos := from_pos; - self. to_pos := to_pos; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var b_qr := b.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += b_qr.ev; - var from_pos_qr := from_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += from_pos_qr.ev; - var to_pos_qr := to_pos.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += to_pos_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, c, evs)-> - begin - var b := b_qr.GetRes; - var from_pos := from_pos_qr.GetRes; - var to_pos := to_pos_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueCopyBuffer( - cq, b.ntv,o.ntv, - new UIntPtr(from_pos), new UIntPtr(to_pos), - new UIntPtr(len), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - b.RegisterWaitables(tsk, prev_hubs); - from_pos.RegisterWaitables(tsk, prev_hubs); - to_pos.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion CopyForm} - -function BufferCommandQueue.AddCopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): BufferCommandQueue := -AddCommand(new BufferCommandCopyForm(b, from_pos, to_pos, len)); - -{$endregion 3#Copy} - -{$region Get} - -{$region GetDataAutoSize} - -type - BufferCommandGetDataAutoSize = sealed class(EnqueueableGetCommand) - - protected function ParamCountL1: integer; override := 0; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue); - begin - inherited Create(ccq); - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - - Result := (o, cq, tsk, evs, own_qr)-> - begin - var res_ev: cl_event; - - var res := Marshal.AllocHGlobal(IntPtr(pointer(o.Size))); own_qr.SetRes(res); - //ToDo А что если результат уже получен и освобождёт сдедующей .ThenConvert - // - Вообще .WhenError тут (и в +1 месте) - говнокод - tsk.WhenError((tsk,err)->Marshal.FreeHGlobal(res)); - cl.EnqueueReadBuffer( - cq, o.Native, Bool.NON_BLOCKING, - UIntPtr.Zero, o.Size, - res, - evs.count, evs.evs, res_ev - ); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; - - end; - -{$endregion GetDataAutoSize} - -function BufferCommandQueue.AddGetData: CommandQueue := -new BufferCommandGetDataAutoSize(self) as CommandQueue; - -{$region GetData} - -type - BufferCommandGetData = sealed class(EnqueueableGetCommand) - private buff_offset: CommandQueue; - private len: CommandQueue; - - protected function ParamCountL1: integer; override := 2; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue; buff_offset, len: CommandQueue); - begin - inherited Create(ccq); - self.buff_offset := buff_offset; - self. len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += buff_offset_qr.ev; - var len_qr := len.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, evs, own_qr)-> - begin - var buff_offset := buff_offset_qr.GetRes; - var len := len_qr.GetRes; - var res_ev: cl_event; - - var res := Marshal.AllocHGlobal(IntPtr(pointer(o.Size))); own_qr.SetRes(res); - tsk.WhenError((tsk,err)->Marshal.FreeHGlobal(res)); - cl.EnqueueReadBuffer( - cq, o.Native, Bool.NON_BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(len), - res, - evs.count, evs.evs, res_ev - ).RaiseIfError; - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - buff_offset.RegisterWaitables(tsk, prev_hubs); - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion GetData} - -function BufferCommandQueue.AddGetData(buff_offset, len: CommandQueue): CommandQueue := -new BufferCommandGetData(self, buff_offset, len) as CommandQueue; - -function BufferCommandQueue.AddGetValue: CommandQueue := -AddGetValue&(0); - -{$region GetValue} - -type - BufferCommandGetValue = sealed class(EnqueueableGetCommand) - where TRecord: record; - private buff_offset: CommandQueue; - - protected function ForcePtrQr: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue; buff_offset: CommandQueue); - begin - inherited Create(ccq); - self.buff_offset := buff_offset; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - var buff_offset_qr := buff_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += buff_offset_qr.ev; - - Result := (o, cq, tsk, evs, own_qr)-> - begin - var buff_offset := buff_offset_qr.GetRes; - var res_ev: cl_event; - - cl.EnqueueReadBuffer( - cq, o.Native, Bool.NON_BLOCKING, - new UIntPtr(buff_offset), new UIntPtr(Marshal.SizeOf&), - new IntPtr((own_qr as QueueResDelayedPtr).ptr), - evs.count, evs.evs, res_ev - ).RaiseIfError; - - var own_qr_hnd := GCHandle.Alloc(own_qr); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - own_qr_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - buff_offset.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion GetValue} - -function BufferCommandQueue.AddGetValue(buff_offset: CommandQueue): CommandQueue := -new BufferCommandGetValue(self, buff_offset) as CommandQueue; - -{$region GetArray1AutoSize} - -type - BufferCommandGetArray1AutoSize = sealed class(EnqueueableGetCommand) - where TRecord: record; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 0; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue); - begin - inherited Create(ccq); - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - - Result := (o, cq, tsk, evs, own_qr)-> - begin - - try - var len := o.Size64 div Marshal.SizeOf&; - var res := new TRecord[len]; own_qr.SetRes(res); - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(0), new UIntPtr(len * Marshal.SizeOf&), - res[0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override := exit; - - end; - -{$endregion GetArray1AutoSize} - -function BufferCommandQueue.AddGetArray1: CommandQueue := -new BufferCommandGetArray1AutoSize(self) as CommandQueue; - -{$region GetArray1} - -type - BufferCommandGetArray1 = sealed class(EnqueueableGetCommand) - where TRecord: record; - private len: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 1; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue; len: CommandQueue); - begin - inherited Create(ccq); - self.len := len; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - var len_qr := len.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += len_qr.ev; - - Result := (o, cq, tsk, evs, own_qr)-> - begin - var len := len_qr.GetRes; - - try - var res := new TRecord[len]; own_qr.SetRes(res); - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(0), new UIntPtr(int64(len) * Marshal.SizeOf&), - res[0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - len.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion GetArray1} - -function BufferCommandQueue.AddGetArray1(len: CommandQueue): CommandQueue := -new BufferCommandGetArray1(self, len) as CommandQueue; - -{$region GetArray2} - -type - BufferCommandGetArray2 = sealed class(EnqueueableGetCommand) - where TRecord: record; - private len1: CommandQueue; - private len2: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 2; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue; len1,len2: CommandQueue); - begin - inherited Create(ccq); - self.len1 := len1; - self.len2 := len2; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - var len1_qr := len1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += len1_qr.ev; - var len2_qr := len2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len2_qr.ev; - - Result := (o, cq, tsk, evs, own_qr)-> - begin - var len1 := len1_qr.GetRes; - var len2 := len2_qr.GetRes; - - try - var res := new TRecord[len1,len2]; own_qr.SetRes(res); - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(0), new UIntPtr(int64(len1)*len2 * Marshal.SizeOf&), - res[0,0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - len1.RegisterWaitables(tsk, prev_hubs); - len2.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion GetArray2} - -function BufferCommandQueue.AddGetArray2(len1,len2: CommandQueue): CommandQueue := -new BufferCommandGetArray2(self, len1, len2) as CommandQueue; - -{$region GetArray3} - -type - BufferCommandGetArray3 = sealed class(EnqueueableGetCommand) - where TRecord: record; - private len1: CommandQueue; - private len2: CommandQueue; - private len3: CommandQueue; - - protected function NeedThread: boolean; override := true; - - protected function ParamCountL1: integer; override := 3; - protected function ParamCountL2: integer; override := 0; - - public constructor(ccq: BufferCommandQueue; len1,len2,len3: CommandQueue); - begin - inherited Create(ccq); - self.len1 := len1; - self.len2 := len2; - self.len3 := len3; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Buffer, cl_command_queue, CLTaskBase, EventList, QueueResDelayedBase)->cl_event; override; - begin - var len1_qr := len1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += len1_qr.ev; - var len2_qr := len2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len2_qr.ev; - var len3_qr := len3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += len3_qr.ev; - - Result := (o, cq, tsk, evs, own_qr)-> - begin - var len1 := len1_qr.GetRes; - var len2 := len2_qr.GetRes; - var len3 := len3_qr.GetRes; - - try - var res := new TRecord[len1,len2,len3]; own_qr.SetRes(res); - cl.EnqueueReadBuffer( - cq, o.Native, Bool.BLOCKING, - new UIntPtr(0), new UIntPtr(int64(len1)*len2*len3 * Marshal.SizeOf&), - res[0,0,0], - evs.count, evs.evs, IntPtr.Zero - ).RaiseIfError; - finally - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end; - - Result := cl_event.Zero; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - len1.RegisterWaitables(tsk, prev_hubs); - len2.RegisterWaitables(tsk, prev_hubs); - len3.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion GetArray3} - -function BufferCommandQueue.AddGetArray3(len1,len2,len3: CommandQueue): CommandQueue := -new BufferCommandGetArray3(self, len1, len2, len3) as CommandQueue; - -{$endregion Get} - -{$endregion BufferCQ} - -{$region Buffer} - -{$region 1#Write&Read} - -function Buffer.WriteData(ptr: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteData(ptr) as CommandQueue); - -function Buffer.ReadData(ptr: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadData(ptr) as CommandQueue); - -function Buffer.WriteData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteData(ptr, buff_offset, len) as CommandQueue); - -function Buffer.ReadData(ptr: CommandQueue; buff_offset, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadData(ptr, buff_offset, len) as CommandQueue); - -function Buffer.WriteData(ptr: pointer): Buffer := -WriteData(IntPtr(ptr)); - -function Buffer.ReadData(ptr: pointer): Buffer := -ReadData(IntPtr(ptr)); - -function Buffer.WriteData(ptr: pointer; buff_offset, len: CommandQueue): Buffer := -WriteData(IntPtr(ptr), buff_offset, len); - -function Buffer.ReadData(ptr: pointer; buff_offset, len: CommandQueue): Buffer := -ReadData(IntPtr(ptr), buff_offset, len); - -function Buffer.WriteValue(val: TRecord): Buffer := -WriteValue(val, 0); - -function Buffer.WriteValue(val: TRecord; buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteValue&(val, buff_offset) as CommandQueue); - -function Buffer.WriteValue(val: CommandQueue): Buffer := -WriteValue(val, 0); - -function Buffer.WriteValue(val: CommandQueue; buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteValue&(val, buff_offset) as CommandQueue); - -function Buffer.WriteArray1(a: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteArray1&(a) as CommandQueue); - -function Buffer.WriteArray2(a: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteArray2&(a) as CommandQueue); - -function Buffer.WriteArray3(a: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteArray3&(a) as CommandQueue); - -function Buffer.ReadArray1(a: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadArray1&(a) as CommandQueue); - -function Buffer.ReadArray2(a: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadArray2&(a) as CommandQueue); - -function Buffer.ReadArray3(a: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadArray3&(a) as CommandQueue); - -function Buffer.WriteArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteArray1&(a, a_offset, len, buff_offset) as CommandQueue); - -function Buffer.WriteArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteArray2&(a, a_offset1, a_offset2, len, buff_offset) as CommandQueue); - -function Buffer.WriteArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddWriteArray3&(a, a_offset1, a_offset2, a_offset3, len, buff_offset) as CommandQueue); - -function Buffer.ReadArray1(a: CommandQueue; a_offset, len, buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadArray1&(a, a_offset, len, buff_offset) as CommandQueue); - -function Buffer.ReadArray2(a: CommandQueue; a_offset1,a_offset2, len, buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadArray2&(a, a_offset1, a_offset2, len, buff_offset) as CommandQueue); - -function Buffer.ReadArray3(a: CommandQueue; a_offset1,a_offset2,a_offset3, len, buff_offset: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddReadArray3&(a, a_offset1, a_offset2, a_offset3, len, buff_offset) as CommandQueue); - -{$endregion 1#Write&Read} - -{$region 2#Fill} - -function Buffer.FillData(ptr: CommandQueue; pattern_len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddFillData(ptr, pattern_len) as CommandQueue); - -function Buffer.FillData(ptr: CommandQueue; pattern_len, buff_offset, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddFillData(ptr, pattern_len, buff_offset, len) as CommandQueue); - -function Buffer.FillValue(val: TRecord): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val) as CommandQueue); - -function Buffer.FillValue(val: TRecord; buff_offset, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val, buff_offset, len) as CommandQueue); - -function Buffer.FillValue(val: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val) as CommandQueue); - -function Buffer.FillValue(val: CommandQueue; buff_offset, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddFillValue&(val, buff_offset, len) as CommandQueue); - -{$endregion 2#Fill} - -{$region 3#Copy} - -function Buffer.CopyTo(b: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddCopyTo(b) as CommandQueue); - -function Buffer.CopyForm(b: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddCopyForm(b) as CommandQueue); - -function Buffer.CopyTo(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddCopyTo(b, from_pos, to_pos, len) as CommandQueue); - -function Buffer.CopyForm(b: CommandQueue; from_pos, to_pos, len: CommandQueue): Buffer := -Context.Default.SyncInvoke(self.NewQueue.AddCopyForm(b, from_pos, to_pos, len) as CommandQueue); - -{$endregion 3#Copy} - -{$region Get} - -function Buffer.GetData: IntPtr := -Context.Default.SyncInvoke(self.NewQueue.AddGetData as CommandQueue); - -function Buffer.GetData(buff_offset, len: CommandQueue): IntPtr := -Context.Default.SyncInvoke(self.NewQueue.AddGetData(buff_offset, len) as CommandQueue); - -function Buffer.GetValue: TRecord := -GetValue&(0); - -function Buffer.GetValue(buff_offset: CommandQueue): TRecord := -Context.Default.SyncInvoke(self.NewQueue.AddGetValue&(buff_offset) as CommandQueue); - -function Buffer.GetArray1: array of TRecord := -Context.Default.SyncInvoke(self.NewQueue.AddGetArray1& as CommandQueue); - -function Buffer.GetArray1(len: CommandQueue): array of TRecord := -Context.Default.SyncInvoke(self.NewQueue.AddGetArray1&(len) as CommandQueue); - -function Buffer.GetArray2(len1,len2: CommandQueue): array[,] of TRecord := -Context.Default.SyncInvoke(self.NewQueue.AddGetArray2&(len1, len2) as CommandQueue); - -function Buffer.GetArray3(len1,len2,len3: CommandQueue): array[,,] of TRecord := -Context.Default.SyncInvoke(self.NewQueue.AddGetArray3&(len1, len2, len3) as CommandQueue); - -{$endregion Get} - -{$endregion Buffer} - -{$region KernelCQ} - -{$region 1#Exec} - -{$region Exec1} - -type - KernelCommandExec1 = sealed class(EnqueueableGPUCommand) - private sz1: CommandQueue; - private args: array of KernelArg; - - protected function ParamCountL1: integer; override := 2; - protected function ParamCountL2: integer; override := 0; - - public constructor(sz1: CommandQueue; params args: array of KernelArg); - begin - self. sz1 := sz1; - self.args := args; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var sz1_qr := sz1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += sz1_qr.ev; - var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1 += Result.ev; end); - - Result := (o, cq, tsk, c, evs)-> - begin - var sz1 := sz1_qr.GetRes; - var args := args_qr.ConvertAll(temp1->temp1.GetRes); - var res_ev: cl_event; - - o.UseExclusiveNative(ntv-> - begin - - for var i := 0 to args.Length-1 do - args[i].SetArg(ntv, i, c); - - cl.EnqueueNDRangeKernel( - cq, ntv, 1, - nil, - new UIntPtr[](new UIntPtr(sz1)), - nil, - evs.count, evs.evs, res_ev - ); - - cl.RetainKernel(ntv).RaiseIfError; - var args_hnd := GCHandle.Alloc(args); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - cl.ReleaseKernel(ntv).RaiseIfError(); - args_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - end); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - sz1.RegisterWaitables(tsk, prev_hubs); - foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion Exec1} - -function KernelCommandQueue.AddExec1(sz1: CommandQueue; params args: array of KernelArg): KernelCommandQueue := -AddCommand(new KernelCommandExec1(sz1, args)); - -{$region Exec2} - -type - KernelCommandExec2 = sealed class(EnqueueableGPUCommand) - private sz1: CommandQueue; - private sz2: CommandQueue; - private args: array of KernelArg; - - protected function ParamCountL1: integer; override := 3; - protected function ParamCountL2: integer; override := 0; - - public constructor(sz1,sz2: CommandQueue; params args: array of KernelArg); - begin - self. sz1 := sz1; - self. sz2 := sz2; - self.args := args; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var sz1_qr := sz1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += sz1_qr.ev; - var sz2_qr := sz2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += sz2_qr.ev; - var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1 += Result.ev; end); - - Result := (o, cq, tsk, c, evs)-> - begin - var sz1 := sz1_qr.GetRes; - var sz2 := sz2_qr.GetRes; - var args := args_qr.ConvertAll(temp1->temp1.GetRes); - var res_ev: cl_event; - - o.UseExclusiveNative(ntv-> - begin - - for var i := 0 to args.Length-1 do - args[i].SetArg(ntv, i, c); - - cl.EnqueueNDRangeKernel( - cq, ntv, 2, - nil, - new UIntPtr[](new UIntPtr(sz1),new UIntPtr(sz2)), - nil, - evs.count, evs.evs, res_ev - ); - - cl.RetainKernel(ntv).RaiseIfError; - var args_hnd := GCHandle.Alloc(args); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - cl.ReleaseKernel(ntv).RaiseIfError(); - args_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - end); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - sz1.RegisterWaitables(tsk, prev_hubs); - sz2.RegisterWaitables(tsk, prev_hubs); - foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion Exec2} - -function KernelCommandQueue.AddExec2(sz1,sz2: CommandQueue; params args: array of KernelArg): KernelCommandQueue := -AddCommand(new KernelCommandExec2(sz1, sz2, args)); - -{$region Exec3} - -type - KernelCommandExec3 = sealed class(EnqueueableGPUCommand) - private sz1: CommandQueue; - private sz2: CommandQueue; - private sz3: CommandQueue; - private args: array of KernelArg; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg); - begin - self. sz1 := sz1; - self. sz2 := sz2; - self. sz3 := sz3; - self.args := args; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var sz1_qr := sz1.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += sz1_qr.ev; - var sz2_qr := sz2.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += sz2_qr.ev; - var sz3_qr := sz3.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += sz3_qr.ev; - var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1 += Result.ev; end); - - Result := (o, cq, tsk, c, evs)-> - begin - var sz1 := sz1_qr.GetRes; - var sz2 := sz2_qr.GetRes; - var sz3 := sz3_qr.GetRes; - var args := args_qr.ConvertAll(temp1->temp1.GetRes); - var res_ev: cl_event; - - o.UseExclusiveNative(ntv-> - begin - - for var i := 0 to args.Length-1 do - args[i].SetArg(ntv, i, c); - - cl.EnqueueNDRangeKernel( - cq, ntv, 3, - nil, - new UIntPtr[](new UIntPtr(sz1),new UIntPtr(sz2),new UIntPtr(sz3)), - nil, - evs.count, evs.evs, res_ev - ); - - cl.RetainKernel(ntv).RaiseIfError; - var args_hnd := GCHandle.Alloc(args); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - cl.ReleaseKernel(ntv).RaiseIfError(); - args_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - end); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - sz1.RegisterWaitables(tsk, prev_hubs); - sz2.RegisterWaitables(tsk, prev_hubs); - sz3.RegisterWaitables(tsk, prev_hubs); - foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion Exec3} - -function KernelCommandQueue.AddExec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): KernelCommandQueue := -AddCommand(new KernelCommandExec3(sz1, sz2, sz3, args)); - -{$region Exec} - -type - KernelCommandExec = sealed class(EnqueueableGPUCommand) - private global_work_offset: CommandQueue; - private global_work_size: CommandQueue; - private local_work_size: CommandQueue; - private args: array of KernelArg; - - protected function ParamCountL1: integer; override := 4; - protected function ParamCountL2: integer; override := 0; - - public constructor(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg); - begin - self.global_work_offset := global_work_offset; - self. global_work_size := global_work_size; - self. local_work_size := local_work_size; - self. args := args; - end; - private constructor := raise new System.InvalidOperationException; - - protected function InvokeParams(tsk: CLTaskBase; c: Context; main_dvc: cl_device_id; var cq: cl_command_queue; evs_l1, evs_l2: List): (Kernel, cl_command_queue, CLTaskBase, Context, EventList)->cl_event; override; - begin - var global_work_offset_qr := global_work_offset.Invoke (tsk, c, main_dvc, False, cq, nil); evs_l1 += global_work_offset_qr.ev; - var global_work_size_qr := global_work_size.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += global_work_size_qr.ev; - var local_work_size_qr := local_work_size.InvokeNewQ(tsk, c, main_dvc, False, nil); evs_l1 += local_work_size_qr.ev; - var args_qr := args.ConvertAll(temp1->begin Result := temp1.Invoke(tsk, c, main_dvc); evs_l1 += Result.ev; end); - - Result := (o, cq, tsk, c, evs)-> - begin - var global_work_offset := global_work_offset_qr.GetRes; - var global_work_size := global_work_size_qr.GetRes; - var local_work_size := local_work_size_qr.GetRes; - var args := args_qr.ConvertAll(temp1->temp1.GetRes); - var res_ev: cl_event; - - o.UseExclusiveNative(ntv-> - begin - - for var i := 0 to args.Length-1 do - args[i].SetArg(ntv, i, c); - - cl.EnqueueNDRangeKernel( - cq, ntv, global_work_size.Length, - global_work_offset, - global_work_size, - local_work_size, - evs.count, evs.evs, res_ev - ); - - cl.RetainKernel(ntv).RaiseIfError; - var args_hnd := GCHandle.Alloc(args); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - cl.ReleaseKernel(ntv).RaiseIfError(); - args_hnd.Free; - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - end); - - EventList.AttachFinallyCallback(res_ev, ()-> - begin - evs.Release({$ifdef EventDebug}$'after use in waiting of {self.GetType}'{$endif}); - end, tsk, false{$ifdef EventDebug}, nil{$endif}); - - Result := res_ev; - end; - - end; - - protected procedure RegisterWaitables(tsk: CLTaskBase; prev_hubs: HashSet); override; - begin - global_work_offset.RegisterWaitables(tsk, prev_hubs); - global_work_size.RegisterWaitables(tsk, prev_hubs); - local_work_size.RegisterWaitables(tsk, prev_hubs); - foreach var temp1 in args do temp1.RegisterWaitables(tsk, prev_hubs); - end; - - end; - -{$endregion Exec} - -function KernelCommandQueue.AddExec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): KernelCommandQueue := -AddCommand(new KernelCommandExec(global_work_offset, global_work_size, local_work_size, args)); - -{$endregion 1#Exec} - -{$endregion KernelCQ} - -{$region Kernel} - -{$region 1#Exec} - -function Kernel.Exec1(sz1: CommandQueue; params args: array of KernelArg): Kernel := -Context.Default.SyncInvoke(self.NewQueue.AddExec1(sz1, args) as CommandQueue); - -function Kernel.Exec2(sz1,sz2: CommandQueue; params args: array of KernelArg): Kernel := -Context.Default.SyncInvoke(self.NewQueue.AddExec2(sz1, sz2, args) as CommandQueue); - -function Kernel.Exec3(sz1,sz2,sz3: CommandQueue; params args: array of KernelArg): Kernel := -Context.Default.SyncInvoke(self.NewQueue.AddExec3(sz1, sz2, sz3, args) as CommandQueue); - -function Kernel.Exec(global_work_offset, global_work_size, local_work_size: CommandQueue; params args: array of KernelArg): Kernel := -Context.Default.SyncInvoke(self.NewQueue.AddExec(global_work_offset, global_work_size, local_work_size, args) as CommandQueue); - -{$endregion 1#Exec} - -{$endregion Kernel} - -{$endregion CommonCommands} - -end. \ No newline at end of file diff --git a/TestSuite/formatter_tests/input/PABCSystem.pas b/TestSuite/formatter_tests/input/PABCSystem.pas index f560659b3..ee68cf776 100644 --- a/TestSuite/formatter_tests/input/PABCSystem.pas +++ b/TestSuite/formatter_tests/input/PABCSystem.pas @@ -67,6 +67,9 @@ const /// Константа перехода на новую строку /// !! The newline string defined for this environment. NewLine = System.Environment.NewLine; + /// Константа - символы-разделители слов + /// !! symbols - word delimiters + AllDelimiters = ' <>=^`|~$№§!"#%&''()*,+-./:;?@[\]_{}«­·»'#9#10#13; //{{{--doc: Конец секции стандартных констант для документации }}} @@ -253,6 +256,12 @@ type /// Предоставляет методы для точного измерения затраченного времени Stopwatch = System.Diagnostics.Stopwatch; + /// Указывает на возможность сериализации класса + Serializable = System.SerializableAttribute; + + /// Указывает, что поле сериализуемого класса не должно быть сериализовано + NonSerialized = System.NonSerializedAttribute; + /// Представляет тип короткой строки фиксированной длины 255 символов ShortString = string[255]; @@ -492,6 +501,7 @@ type function ToString: string; override; class function operator implicit(s: TypedSet): HashSet; class function operator implicit(s: HashSet): TypedSet; + //class function operator implicit(a: array of T): TypedSet; function Count: integer := ht.Count; procedure Print(delim: string := ' '); procedure Println(delim: string := ' '); @@ -585,6 +595,10 @@ type function ReadReal: real; /// Считывает строку из бестипового файла function ReadString: string; + /// Сериализует объект в файл (объект должен иметь атрибут [Serializable]) + procedure Serialize(obj: object); + /// Десериализует объект из файла + function Deserialize: object; end; type @@ -606,13 +620,13 @@ type end; property Low: integer read l; property High: integer read h; - property Count: integer read GetCount; + //property Count: integer read GetCount; static function operator in(x: integer; r: IntRange): boolean := (x >= r.l) and (x <= r.h); static function operator in(x: real; r: IntRange): boolean := (x >= r.l) and (x <= r.h); static function operator=(r1,r2: IntRange): boolean := (r1.l = r2.l) and (r1.h = r2.h); - - function IsEmpty: boolean := l<=h; + /// Возвращает True если диапазон пуст + function IsEmpty: boolean := l>h; function Step(n: integer): sequence of integer; function Reverse: sequence of integer; @@ -627,7 +641,7 @@ type Result := (l = r2.l) and (h = r2.h); end; function GetHashCode: integer; override := l.GetHashCode xor h.GetHashCode; - function ToArray: array of integer; + {function ToArray: array of integer; begin Result := new integer[Count]; var x := l; @@ -639,25 +653,25 @@ type end; function ToList: List; begin - Result := new List; + Result := new List(Count); var x := l; loop Count do begin Result.Add(x); x += 1; end; - end; + end;} function ToLinkedList: LinkedList; begin - Result := new LinkedList(System.Linq.Enumerable.Range(l,Count)); + Result := new LinkedList(System.Linq.Enumerable.Range(l,GetCount)); end; function ToHashSet: HashSet; begin - Result := new HashSet(System.Linq.Enumerable.Range(l,Count)); + Result := new HashSet(System.Linq.Enumerable.Range(l,GetCount)); end; function ToSortedSet: SortedSet; begin - Result := new SortedSet(System.Linq.Enumerable.Range(l,Count)); + Result := new SortedSet(System.Linq.Enumerable.Range(l,GetCount)); end; end; @@ -679,12 +693,13 @@ type end; property Low: char read l; property High: char read h; - property Count: integer read GetCount; + //property Count: integer read GetCount; static function operator in(x: char; r: CharRange): boolean := (x >= r.l) and (x <= r.h); static function operator=(r1,r2: CharRange): boolean := (r1.l = r2.l) and (r1.h = r2.h); - function IsEmpty: boolean := l<=h; + /// Возвращает True если диапазон пуст + function IsEmpty: boolean := l>h; function Step(n: integer): sequence of char; function Reverse: sequence of char; @@ -700,7 +715,7 @@ type end; function GetHashCode: integer; override := l.GetHashCode xor h.GetHashCode; - function ToArray: array of char; + {function ToArray: array of char; begin Result := new char[Count]; var x := l; @@ -719,18 +734,18 @@ type Result.Add(x); x := char(integer(x) + 1); end; - end; + end;} function ToLinkedList: LinkedList; begin - Result := new LinkedList(System.Linq.Enumerable.Range(integer(l),Count).Select(i -> char(i))); + Result := new LinkedList(System.Linq.Enumerable.Range(integer(l),GetCount).Select(i -> char(i))); end; function ToHashSet: HashSet; begin - Result := new HashSet(System.Linq.Enumerable.Range(integer(l),Count).Select(i -> char(i))); + Result := new HashSet(System.Linq.Enumerable.Range(integer(l),GetCount).Select(i -> char(i))); end; function ToSortedSet: SortedSet; begin - Result := new SortedSet(System.Linq.Enumerable.Range(integer(l),Count).Select(i -> char(i))); + Result := new SortedSet(System.Linq.Enumerable.Range(integer(l),GetCount).Select(i -> char(i))); end; end; @@ -750,7 +765,8 @@ type static function operator in(x: real; r: RealRange): boolean := (x >= r.l) and (x <= r.h); static function operator=(r1,r2: RealRange): boolean := (r1.l = r2.l) and (r1.h = r2.h); - function IsEmpty: boolean := l<=h; + /// Возвращает True если диапазон пуст + function IsEmpty: boolean := l>h; function ToString: string; override := $'{l}..{h}'; function Equals(o: Object): boolean; override; @@ -1182,6 +1198,12 @@ procedure Println(params args: array of object); /// Выводит значения a,b,... в текстовый файл f, после каждого значения выводит пробел и переходит на новую строку procedure Println(f: Text; params args: array of object); +/// Сериализует объект в файл (объект должен иметь атрибут [Serializable]) +procedure Serialize(filename: string; obj: object); +/// Десериализует объект из файла +function Deserialize(filename: string): object; + + // ----------------------------------------------------- //>> Общие подпрограммы для работы с файлами # Common subroutines for files // ----------------------------------------------------- @@ -1401,7 +1423,7 @@ procedure RmDir(s: string); /// Создает каталог. Возвращает True, если каталог успешно создан function CreateDir(s: string): boolean; /// Удаляет файл. Если файл не может быть удален, то возвращает False -function DeleteFile(s: string): boolean; +function DeleteFile(fname: string): boolean; /// Возвращает текущий каталог function GetCurrentDir: string; /// Удаляет каталог. Возвращает True, если каталог успешно удален @@ -1862,10 +1884,10 @@ function Length(s: string): integer; procedure SetLength(var s: string; n: integer); ///-- procedure SetLengthForShortString(var s: string; n, sz: integer); -/// Вставляет подстроку source в строку s с позиции index -procedure Insert(source: string; var s: string; index: integer); +/// Вставляет подстроку subs в строку s с позиции index +procedure Insert(subs: string; var s: string; index: integer); ///-- -procedure InsertInShortString(source: string; var s: string; index, n: integer); +procedure InsertInShortString(subs: string; var s: string; index, n: integer); /// Удаляет из строки s count символов с позиции index procedure Delete(var s: string; index, count: integer); /// Возвращает подстроку строки s длины count с позиции index @@ -2130,6 +2152,9 @@ function MatrEqual(a, b: array [,] of T): boolean; /// Перемешивает список случайным образом procedure Shuffle(l: List); +/// Возвращает следующую перестановку в массиве +function NextPermutation(a: array of integer): boolean; + // ----------------------------------------------------- //>> Подпрограммы для генерации последовательностей # Subroutines for sequence generation @@ -2138,6 +2163,10 @@ procedure Shuffle(l: List); function Range(a, b: integer): sequence of integer; /// Возвращает последовательность целых от a до b с шагом step function Range(a, b, step: integer): sequence of integer; +/// Возвращает последовательность длинных целых от a до b +function Range(a, b: BigInteger): sequence of BigInteger; +/// Возвращает последовательность длинных целых от a до b с шагом step +function Range(a, b, step: BigInteger): sequence of BigInteger; /// Возвращает последовательность символов от c1 до c2 function Range(c1, c2: char): sequence of char; /// Возвращает последовательность символов от c1 до c2 с шагом step @@ -2744,6 +2773,9 @@ function InternalRange(l,r: real): RealRange; ///-- function IsInputPipedOrRedirectedFromFile: boolean; + +///-- +function CheckAndCorrectFromToAndCalcCountForSystemSlice(situation: integer; Len: integer; var from, &to: integer; step: integer): integer; // ----------------------------------------------------- // Internal procedures for PABCRTL.dll @@ -2810,6 +2842,9 @@ function WINAPI_AllocConsole: longword; external 'kernel32.dll' name 'AllocConso var console_alloc: boolean := false; + +type + BinaryFormatter = System.Runtime.Serialization.Formatters.Binary.BinaryFormatter; // ----------------------------------------------------- // Internal functions @@ -3366,6 +3401,17 @@ begin Result := ts; end; +///-- +{class function TypedSet.operator implicit(a: array of T): TypedSet; +begin + var ts := new TypedSet(); + foreach key: T in a do + begin + ts.ht[key] := key; + end; + Result := ts; +end;} + ///-- function TypedSet.ToString: string; var @@ -4029,20 +4075,25 @@ function CharRange.Reverse: sequence of char := Range(l,h).Reverse; //------------------------------------------------------------------------------ // Операции для string и char //------------------------------------------------------------------------------ +///-- procedure string.operator+=(var left: string; right: string); begin left := left + right; end; +///-- function string.operator<(left, right: string) := string.CompareOrdinal(left, right) < 0; +///-- function string.operator<=(left, right: string) := string.CompareOrdinal(left, right) <= 0; +///-- function string.operator>(left, right: string) := string.CompareOrdinal(left, right) > 0; +///-- function string.operator>=(left, right: string) := string.CompareOrdinal(left, right) >= 0; -/// Повторяет строку str n раз +///-- function string.operator*(str: string; n: integer): string; begin var sb := new StringBuilder; @@ -4051,7 +4102,7 @@ begin Result := sb.ToString; end; -/// Повторяет строку str n раз +///-- function string.operator*(n: integer; str: string): string; begin var sb := new StringBuilder; @@ -4060,7 +4111,7 @@ begin Result := sb.ToString; end; -/// Повторяет символ c n раз +///-- function char.operator*(c: char; n: integer): string; begin if n <= 0 then @@ -4074,7 +4125,7 @@ begin Result := sb.ToString; end; -/// Повторяет символ c n раз +///-- function char.operator*(n: integer; c: char): string; begin if n <= 0 then @@ -4088,18 +4139,23 @@ begin Result := sb.ToString; end; -/// Добавляет к строке str строковое представление числа n +// Добавляет к строке str строковое представление числа n +///-- function string.operator+(str: string; n: integer) := str + n.ToString; -/// Добавляет к строке str строковое представление числа n +// Добавляет к строке str строковое представление числа n +///-- function string.operator+(n: integer; str: string) := n.ToString + str; -/// Добавляет к строке str строковое представление числа r +// Добавляет к строке str строковое представление числа r +///-- function string.operator+(str: string; r: real) := str + r.ToString(nfi); -/// Добавляет к строке str строковое представление числа r +// Добавляет к строке str строковое представление числа r +///-- function string.operator+(r: real; str: string) := r.ToString(nfi) + str; +///-- procedure string.operator+=(var left: string; right: integer); begin left := left + right.ToString; @@ -4542,7 +4598,7 @@ begin else Result := System.Linq.Enumerable.Range(a, b - a + 1); end; -function Range(a, b: real; n: integer): sequence of real; +function PartitionPoints(a, b: real; n: integer): sequence of real; begin if n = 0 then raise new System.ArgumentException('Range: n=0'); @@ -4567,11 +4623,26 @@ begin Result := Range(integer(c1), integer(c2), step).Select(x -> Chr(x)); end; -function PartitionPoints(a, b: real; n: integer): sequence of real; +function Range(a, b, step: BigInteger): sequence of BigInteger; begin - Result := Range(a, b, n) + if step = 0 then + raise new System.ArgumentException('step=0'); + if step > 0 then + while a<=b do + begin + yield a; + a += step; + end + else + while a>=b do + begin + yield a; + a += step; + end end; +function Range(a, b: BigInteger): sequence of BigInteger := Range(a,b,1); + type ArithmSeq = auto class a, step: integer; @@ -5169,54 +5240,6 @@ begin res := self; end; -// ----------------------------------------------------------------------------- -// ReadLexem -// ----------------------------------------------------------------------------- - -{function ReadLexem: string; -begin - var c: char; - repeat - c := CurrentIOSystem.read_symbol; - until not char.IsWhiteSpace(c); - var sb := new System.Text.StringBuilder; - repeat - sb.Append(c); - c := char(CurrentIOSystem.peek); - if char.IsWhiteSpace(c) or (c = char(-1)) then // char(-1) - Ctrl-Z во входном потоке - break; - c := CurrentIOSystem.read_symbol; - until False; // accumulate nonspaces - Result := sb.ToString; -end;} - -function ReadLexem(f: Text): string; -begin - if f.fi = nil then - raise new System.IO.IOException(GetTranslation(FILE_NOT_ASSIGNED)); - if f.sr = nil then - raise new System.IO.IOException(GetTranslation(FILE_NOT_OPENED_FOR_READING)); - var i: integer; - repeat - i := f.sr.Read(); - until not char.IsWhiteSpace(char(i)); // pass spaces - if i=-1 then - raise new System.IO.IOException(GetTranslation(READ_LEXEM_AFTER_END_OF_TEXT_FILE)); - var c := char(i); - var sb := System.Text.StringBuilder.Create; - repeat - sb.Append(c); - i := f.sr.Peek(); - if i = -1 then - break; - c := char(i); - if char.IsWhiteSpace(c) then - break; - f.sr.Read(); - until False; // accumulate nonspaces - Result := sb.ToString; -end; - // ----------------------------------------------------- // IOStandardSystem: implementation // ----------------------------------------------------- @@ -5410,9 +5433,9 @@ end; function ReadLexem: string; begin - if input.sr <> nil then + {if input.sr <> nil then Result := ReadLexem(input) - else Result := CurrentIOSystem.ReadLexem; + else} Result := CurrentIOSystem.ReadLexem; end; function IOStandardSystem.ReadLexem: string; @@ -6444,6 +6467,39 @@ begin Result := ReadBoolean(f); Readln(f); end; + +function ReadLexem(f: Text): string; +begin + if f = input then + begin + Result := ReadLexem; + exit + end; + if f.fi = nil then + raise new System.IO.IOException(GetTranslation(FILE_NOT_ASSIGNED)); + if f.sr = nil then + raise new System.IO.IOException(GetTranslation(FILE_NOT_OPENED_FOR_READING)); + var i: integer; + repeat + i := f.sr.Read(); + until not char.IsWhiteSpace(char(i)); // pass spaces + if i=-1 then + raise new System.IO.IOException(GetTranslation(READ_LEXEM_AFTER_END_OF_TEXT_FILE)); + var c := char(i); + var sb := System.Text.StringBuilder.Create; + repeat + sb.Append(c); + i := f.sr.Peek(); + if i = -1 then + break; + c := char(i); + if char.IsWhiteSpace(c) then + break; + f.sr.Read(); + until False; // accumulate nonspaces + Result := sb.ToString; +end; + // ----------------------------------------------------- // TextFile methods // ----------------------------------------------------- @@ -6642,6 +6698,18 @@ begin Result := Self.br.ReadString; end; +procedure BinaryFile.Serialize(obj: object); +begin + var formatter := new BinaryFormatter; + formatter.Serialize(fs,obj); +end; + +function BinaryFile.Deserialize: object; +begin + var formatter := new BinaryFormatter; + Result := formatter.Deserialize(fs); +end; + // ----------------------------------------------------- // Eoln - Eof // ----------------------------------------------------- @@ -6962,6 +7030,23 @@ begin Print(f, args); Writeln(f); end; + +procedure Serialize(filename: string; obj: object); +begin + var fs := new System.IO.FileStream(filename,System.IO.FileMode.Create); + var formatter := new BinaryFormatter; + formatter.Serialize(fs,obj); + fs.Close; +end; + +function Deserialize(filename: string): object; +begin + var fs := new System.IO.FileStream(filename,System.IO.FileMode.Open); + var formatter := new BinaryFormatter; + Result := formatter.Deserialize(fs); + fs.Close; +end; + // ----------------------------------------------------- // Text files // ----------------------------------------------------- @@ -6979,6 +7064,7 @@ begin begin f.sr := new StreamReader(f.fi.FullName, DefaultEncoding); (CurrentIOSystem as IOStandardSystem).tr := f.sr; + (CurrentIOSystem as IOStandardSystem).realbuflen := -1; _IsPipedRedirected := True; _IsPipedRedirectedQuery := True; end; @@ -7029,6 +7115,11 @@ begin f.sr.BaseStream.Position := 0; f.sr.DiscardBufferedData; end; + if f = input then + begin + (CurrentIOSystem as IOStandardSystem).tr := f.sr; + (CurrentIOSystem as IOStandardSystem).realbuflen := -1; + end; end; procedure Reset(f: Text; name: string) := Reset(f, name, DefaultEncoding); @@ -7120,7 +7211,9 @@ end; function Eof(f: Text): boolean; begin - if f.sr <> nil then + if f = input then + Result := Eof + else if f.sr <> nil then Result := f.sr.EndOfStream else if f.sw <> nil then raise new IOException(GetTranslation(EOF_FOR_TEXT_WRITEOPENED)) @@ -7129,7 +7222,9 @@ end; function Eoln(f: Text): boolean; begin - if f.sr <> nil then + if f = input then + Result := Eoln + else if f.sr <> nil then Result := f.sr.EndOfStream or (f.sr.Peek = 13) or (f.sr.Peek = 10) else if f.sw <> nil then raise new IOException(GetTranslation(EOLN_FOR_TEXT_WRITEOPENED)) @@ -7138,6 +7233,11 @@ end; function SeekEof(f: Text): boolean; begin + if f = input then + begin + Result := SeekEof; + exit; + end; if f.sw <> nil then raise new IOException(GetTranslation(SEEKEOF_FOR_TEXT_WRITEOPENED)); if f.sr = nil then @@ -7155,6 +7255,11 @@ end; function SeekEoln(f: Text): boolean; begin + if f = input then + begin + Result := SeekEoln; + exit; + end; if f.sw <> nil then raise new IOException(GetTranslation(SEEKEOLN_FOR_TEXT_WRITEOPENED)); if f.sr = nil then @@ -7742,11 +7847,16 @@ begin end; end; -function DeleteFile(s: string): boolean; +function DeleteFile(fname: string): boolean; begin + if not &File.Exists(fname) then + begin + Result := False; + exit + end; try Result := True; - &File.Delete(s); + &File.Delete(fname); except Result := False; end; @@ -8113,7 +8223,7 @@ function LogN(base, x: real) := Math.Log(x) / Math.Log(base); function Sqrt(x: real) := Math.Sqrt(x); -function Sqr(x: integer): int64 := x * x; +function Sqr(x: integer): int64 := int64(x) * int64(x); function Sqr(x: shortint): integer := x * x; @@ -8123,11 +8233,11 @@ function Sqr(x: BigInteger): BigInteger := x * x; function Sqr(x: byte): integer := x * x; -function Sqr(x: word): uint64 := x * x; +function Sqr(x: word): uint64 := uint64(x) * uint64(x); -function Sqr(x: longword): uint64 := x * x; +function Sqr(x: longword): uint64 := uint64(x) * uint64(x); -function Sqr(x: int64): int64 := x * x; +function Sqr(x: int64): int64 := int64(x) * int64(x); function Sqr(x: uint64): uint64 := x * x; @@ -8726,27 +8836,27 @@ begin s += new String(' ', sz - s.Length) end; -procedure Insert(source: string; var s: string; index: integer); +procedure Insert(subs: string; var s: string; index: integer); // Insert никогда не возвращает исключения begin if index < 1 then index := 1; if index > s.Length + 1 then index := s.Length + 1; - s := s.Insert(index - 1, source); + s := s.Insert(index - 1, subs); end; -procedure InsertInShortString(source: string; var s: string; index, n: integer); +procedure InsertInShortString(subs: string; var s: string; index, n: integer); begin if index < 1 then index := 1; if index > n then exit; try - s := s.Insert(index - 1, source); + s := s.Insert(index - 1, subs); if s.Length > n then s := s.Substring(0, n); except - s := s.Insert(s.Length, source); + s := s.Insert(s.Length, subs); if s.Length > n then s := s.Substring(0, n); end; end; @@ -8814,7 +8924,7 @@ end; function ReverseString(s: string; index,length: integer): string; begin var ca := s.ToCharArray; - &Array.Reverse(ca,index+1,length); + &Array.Reverse(ca,index-1,length); Result := new string(ca); end; @@ -9723,6 +9833,39 @@ begin Result += f(x); end;} +// SSM 23/11/2020 - Sum Average Product for sequence of BigInteger + +/// Возвращает сумму элементов последовательности +function Sum(Self: sequence of BigInteger): BigInteger; extensionmethod; +begin + Result := 0bi; + foreach var a in Self do + Result += a +end; + +/// Возвращает среднее элементов последовательности +function Average(Self: sequence of BigInteger): real; extensionmethod; +begin + var cnt := 0; + var sum := 0bi; + foreach var a in Self do + begin + sum += a; + cnt += 1; + end; + if cnt <> 0 then + Result := sum/cnt + else Result := 0 +end; + +/// Возвращает произведение элементов последовательности +function Product(Self: sequence of BigInteger): BigInteger; extensionmethod; +begin + Result := 1bi; + foreach var a in Self do + Result *= a +end; + /// Возвращает отсортированную по возрастанию последовательность function Sorted(Self: sequence of T): sequence of T; extensionmethod; @@ -9883,7 +10026,7 @@ begin Result := Self.Reverse.Skip(count).Reverse; end; -/// Декартово произведение последовательностей +/// Возвращает декартово произведение последовательностей в виде последовательности пар function Cartesian(Self: sequence of T; b: sequence of T1): sequence of (T, T1); extensionmethod; begin if b = nil then @@ -9894,7 +10037,7 @@ begin yield (x, y) end; -/// Декартово произведение последовательностей +/// Возвращает декартово произведение последовательностей, проектируя каждую пару на значение function Cartesian(Self: sequence of T; b: sequence of T1; func: (T,T1)->T2): sequence of T2; extensionmethod; begin if b = nil then @@ -10239,6 +10382,15 @@ end; // ToDo Сделать AdjacentGroup с функцией сравнения +/// Возвращает количество элементов, равных указанному значению +function CountOf(Self: sequence of T; x: T): integer; extensionmethod; +begin + Result := 0; + foreach var y in Self do + if y = x then + Result += 1; +end; + // ----------------------------------------------------- //>> Методы расширения списков # Extension methods for List T // ----------------------------------------------------- @@ -11657,6 +11809,12 @@ begin until not NextCombHelper(ind,m,n); end; +/// Возвращает все сочетания по m элементов +function Combinations(Self: sequence of T; m: integer): sequence of array of T; extensionmethod; +begin + Result := Self.ToArray.Combinations(m); +end; + // Возвращает все сочетания по 2 элемента в виде кортежей {function Combinations2(Self: array of T): sequence of (T,T); extensionmethod; begin @@ -11686,7 +11844,7 @@ begin Result := True; end; -/// Возвращает все перестановки +/// Возвращает все перестановки множества элементов, заданного массивом function Permutations(Self: array of T): sequence of array of T; extensionmethod; begin var a := Self; @@ -11696,10 +11854,64 @@ begin repeat for var i:=0 to n-1 do res[i] := a[ind[i]]; - yield res; + yield Arr(res); until not NextPermutation(ind); end; +/// Возвращает все перестановки множества элементов, заданного последовательностью +function Permutations(Self: sequence of T): sequence of array of T; extensionmethod; +begin + Result := Self.ToArray.Permutations +end; + +/// Возвращает все частичные перестановки из n элементов по m +function Permutations(Self: array of T; m: integer): sequence of array of T; extensionmethod; +begin + Result := Self.Combinations(m).SelectMany(c->c.Permutations); +end; + +/// Возвращает все частичные перестановки из n элементов по m +function Permutations(Self: sequence of T; m: integer): sequence of array of T; extensionmethod; +begin + Result := Self.ToArray.Permutations(m); +end; + +/// Возвращает n-тую декартову степень множества элементов, заданного массивом +function Cartesian(Self: array of T; n: integer): sequence of array of T; extensionmethod; +begin + var r := new integer[n]; + var ar1 := new T[n]; + for var i:=0 to n-1 do + ar1[i] := Self[r[i]]; + yield ar1; + + var m := Self.Length; + while True do + begin + var i := n-1; + r[i] += 1; + while r[i]>=m do + begin + r[i] := 0; + i -= 1; + if i<0 then + exit; + r[i] += 1; + end; + + var ar := new T[n]; + for var j:=0 to n-1 do + ar[j] := Self[r[j]]; + yield ar; + end; +end; + +/// Возвращает n-тую декартову степень множества элементов, заданного массивом +function Cartesian(Self: sequence of T; n: integer): sequence of array of T; extensionmethod; +begin + Result := Self.ToArray.Cartesian(n); +end; + // Внутренние функции для одномерных массивов ///-- @@ -11830,6 +12042,292 @@ begin Result := SystemSliceArrayImplQuestion(Self, situation, from, &to, step); end; +// Срезы многомерных массивов - вспомогательные типы и функции +type + SliceType = class + situation,from, &to, step, count: integer; + fromInverted, toInverted: boolean; + function oneelem: boolean := step = integer.MaxValue; // если шаг = integer.MaxValue, то это один элемент, а не срез (договорённость) + constructor (sit,f,t: integer; st: integer := 1); + begin + situation := sit; + from := f; + &to := t; + fromInverted := False; + toInverted := False; + step := st; + count := -1; // заполняется во внешней функции CorrectSliceAndCalcCount при известной длине по данной размерности + //oneelem := step = integer.MaxValue; // если шаг = integer.MaxValue, то это один элемент, а не срез (договорённость) + end; + procedure CorrectSliceAndCalcCount(len: integer); + begin + if fromInverted then // Надеюсь, что ровно здесь. Это означает, что эти значения точно не пропущены + from := len - from; + if toInverted then + &to := len - &to; + + if oneelem then + count := 1 + else count := CheckAndCorrectFromToAndCalcCountForSystemSlice(situation, len, from, &to, step); + end; + static function operator implicit(i: integer): SliceType; + static function operator implicit(ir: IntRange): SliceType; + static function operator implicit(sl: (integer,integer,integer)): SliceType; + static function operator implicit(sl: (SystemIndex,SystemIndex,integer)): SliceType; // a[^1:,^2] + static function operator implicit(sl: (integer,SystemIndex,integer)): SliceType; // a[^1:,^2] + static function operator implicit(sl: (SystemIndex,integer,integer)): SliceType; // a[^1:,^2] + end; + +function Diap(f, t: integer) := new SliceType(0, f, t, 1); +function Elem(ind: integer) := new SliceType(0, ind, ind+1, integer.MaxValue); +function Slice(f, t: integer; st: integer := 1): SliceType; +begin + var sit := 0; + if f = integer.MaxValue then + sit += 1; + if t = integer.MaxValue then + sit += 2; + Result := new SliceType(sit, f, t, st); +end; +{function Slice(f, t: SystemIndex; st: integer := 1): SliceType; +begin + Result := Slice(f.IndexValue, t.IndexValue, st); + Result.fromInverted := f.IsInverted; + Result.toInverted := t.IsInverted; +end;} + +static function SliceType.operator implicit(i: integer): SliceType; +begin + Result := Elem(i); +end; + +static function SliceType.operator implicit(ir: IntRange): SliceType; +begin + Result := Diap(ir.Low,ir.High); +end; + +static function SliceType.operator implicit(sl: (integer,integer,integer)): SliceType; +begin + Result := Slice(sl[0],sl[1],sl[2]); +end; + +static function SliceType.operator implicit(sl: (SystemIndex,SystemIndex,integer)): SliceType; +begin + Result := Slice(sl[0].IndexValue,sl[1].IndexValue,sl[2]); + Result.fromInverted := sl[0].IsInverted; + Result.toInverted := sl[1].IsInverted; +end; + +static function SliceType.operator implicit(sl: (integer,SystemIndex,integer)): SliceType; +begin + Result := Slice(sl[0],sl[1].IndexValue,sl[2]); + Result.toInverted := sl[1].IsInverted; +end; + +static function SliceType.operator implicit(sl: (SystemIndex,integer,integer)): SliceType; +begin + Result := Slice(sl[0].IndexValue,sl[1],sl[2]); + Result.fromInverted := sl[0].IsInverted; +end; + +function ToOneDim(a: array [,] of T; l: array of SliceType): array of T; +begin + for var i:=0 to l.Length-1 do + l[i].CorrectSliceAndCalcCount(a.GetLength(i)); + var onedimsz := l[0].count * l[1].count; + var res := new T[onedimsz]; + if onedimsz>0 then + begin + var cur := 0; + var i0 := l[0].from; + loop l[0].count do + begin + var i1:=l[1].from; + loop l[1].count do + begin + res[cur] := a[i0,i1]; + cur += 1; + i1 += l[1].step; + end; + i0 += l[0].step; + end; + end; + Result := res; +end; + +function ToOneDim(a: array [,,] of T; l: array of SliceType): array of T; +begin + for var i:=0 to l.Length-1 do + l[i].CorrectSliceAndCalcCount(a.GetLength(i)); + var onedimsz := l[0].count * l[1].count * l[2].count; + var res := new T[onedimsz]; + if onedimsz>0 then + begin + var cur := 0; + var i0 := l[0].from; + loop l[0].count do + begin + var i1:=l[1].from; + loop l[1].count do + begin + var i2 := l[2].from; + loop l[2].count do + begin + res[cur] := a[i0,i1,i2]; + cur += 1; + i2 += l[2].step; + end; + i1 += l[1].step; + end; + i0 += l[0].step; + end; + end; + Result := res; +end; + +function ToOneDim(a: array [,,,] of T; l: array of SliceType): array of T; +begin + for var i:=0 to l.Length-1 do + l[i].CorrectSliceAndCalcCount(a.GetLength(i)); + var onedimsz := l[0].count * l[1].count * l[2].count * l[3].count; + var res := new T[onedimsz]; + if onedimsz>0 then + begin + var cur := 0; + var i0 := l[0].from; + loop l[0].count do + begin + var i1:=l[1].from; + loop l[1].count do + begin + var i2 := l[2].from; + loop l[2].count do + begin + var i3 := l[3].from; + loop l[3].count do + begin + res[cur] := a[i0,i1,i2,i3]; + cur += 1; + i3 += l[3].step; + end; + i2 += l[2].step; + end; + i1 += l[1].step; + end; + i0 += l[0].step; + end; + end; + Result := res; +end; + +function FromOneDim2(r: array of T; l: array of SliceType): array [,] of T; +begin + var dims := l.FindAll(x -> x.oneelem = False).ConvertAll(x -> x.count); + var cur := 0; + var res := new T[dims[0],dims[1]]; + for var i0:=0 to dims[0]-1 do + for var i1:=0 to dims[1]-1 do + begin + res[i0,i1] := r[cur]; + cur += 1; + end; + Result := res; +end; + +function FromOneDim3(r: array of T; l: array of SliceType): array [,,] of T; +begin + var dims := l.FindAll(x -> x.oneelem = False).ConvertAll(x -> x.count); + var cur := 0; + var res := new T[dims[0],dims[1],dims[2]]; + for var i0:=0 to dims[0]-1 do + for var i1:=0 to dims[1]-1 do + for var i2:=0 to dims[2]-1 do + begin + res[i0,i1,i2] := r[cur]; + cur += 1; + end; + Result := res; +end; + +function FromOneDim4(r: array of T; l: array of SliceType): array [,,,] of T; +begin + var dims := l.FindAll(x -> x.oneelem = False).ConvertAll(x -> x.count); + var cur := 0; + var res := new T[dims[0],dims[1],dims[2],dims[3]]; + for var i0:=0 to dims[0]-1 do + for var i1:=0 to dims[1]-1 do + for var i2:=0 to dims[2]-1 do + for var i3:=0 to dims[3]-1 do + begin + res[i0,i1,i2,i3] := r[cur]; + cur += 1; + end; + Result := res; +end; + +function FromOneDimN(r: array of T; l: array of SliceType): System.Array; +begin + var rank := l.Count(x -> x.oneelem = False); + case rank of + 1: Result := r; + 2: Result := FromOneDim2(r,l); + 3: Result := FromOneDim3(r,l); + 4: Result := FromOneDim4(r,l); + end; +end; + +function SliceN(a: array[,] of T; l: array of SliceType): System.Array; +begin + var r := ToOneDim(a,l); + Result := FromOneDimN(r,l); +end; + +function SliceN(a: array[,,] of T; l: array of SliceType): System.Array; +begin + var r := ToOneDim(a,l); + Result := FromOneDimN(r,l); +end; + +function SliceN(a: array[,,,] of T; l: array of SliceType): System.Array; +begin + var r := ToOneDim(a,l); + Result := FromOneDimN(r,l); +end; + +{type // это не компилируется в PABCSystem + ArrT = array of T; + Arr2T = array [,] of T; + Arr3T = array [,,] of T; + Arr4T = array [,,,] of T;} + +///-- +function SystemSliceN1(Self: array[,] of T; params l: array of SliceType): array of T; extensionmethod + := SliceN(Self,l) as array of T; +///-- +function SystemSliceN1(Self: array[,,] of T; params l: array of SliceType): array of T; extensionmethod + := SliceN(Self,l) as array of T; +///-- +function SystemSliceN1(Self: array[,,,] of T; params l: array of SliceType): array of T; extensionmethod + := SliceN(Self,l) as array of T; +///-- +function SystemSliceN2(Self: array[,] of T; params l: array of SliceType): array[,] of T; extensionmethod + := SliceN(Self,l) as array [,] of T; +///-- +function SystemSliceN2(Self: array[,,] of T; params l: array of SliceType): array[,] of T; extensionmethod + := SliceN(Self,l) as array [,] of T; +///-- +function SystemSliceN2(Self: array[,,,] of T; params l: array of SliceType): array[,] of T; extensionmethod + := SliceN(Self,l) as array [,] of T; +///-- +function SystemSliceN3(Self: array[,,] of T; params l: array of SliceType): array[,,] of T; extensionmethod + := SliceN(Self,l) as array [,,] of T; +///-- +function SystemSliceN3(Self: array[,,,] of T; params l: array of SliceType): array[,,] of T; extensionmethod + := SliceN(Self,l) as array [,,] of T; +///-- +function SystemSliceN4(Self: array[,,,] of T; params l: array of SliceType): array[,,,] of T; extensionmethod + := SliceN(Self,l) as array [,,,] of T; + // ----------------------------------------------------- //>> Методы расширения типа integer # Extension methods for integer // ----------------------------------------------------- @@ -12165,19 +12663,25 @@ end; /// Считывает целое из строки начиная с позиции from и устанавливает from за считанным значением function ReadInteger(Self: string; var from: integer): integer; extensionmethod; begin - Result := ReadIntegerFromString(Self, from); + var from1 := from + 1; + Result := ReadIntegerFromString(Self, from1); + from := from1 - 1; end; /// Считывает вещественное из строки начиная с позиции from и устанавливает from за считанным значением function ReadReal(Self: string; var from: integer): real; extensionmethod; begin - Result := ReadRealFromString(Self, from); + var from1 := from + 1; + Result := ReadRealFromString(Self, from1); + from := from1 - 1; end; /// Считывает слово из строки начиная с позиции from и устанавливает from за считанным значением function ReadWord(Self: string; var from: integer): string; extensionmethod; begin - Result := ReadwordFromString(Self, from); + var from1 := from + 1; + Result := ReadwordFromString(Self, from1); + from := from1 - 1; end; /// Преобразует строку в целое @@ -12197,6 +12701,21 @@ function TryToInteger(Self: string; var value: integer): boolean; extensionmetho ///При невозможности преобразования возвращается False function TryToReal(Self: string; var value: real): boolean; extensionmethod := TryStrToReal(Self,value); + +/// Возвращает True если строку можно преобразовать в вещественное +function IsReal(Self: string): boolean; extensionmethod; +begin + var r: real; + Result := TryStrToReal(Self, r); +end; + +/// Возвращает True если строку можно преобразовать в целое +function IsInteger(Self: string): boolean; extensionmethod; +begin + var i: integer; + Result := TryStrToInt(Self, i); +end; + /// Преобразует строку в целое ///При невозможности преобразования возвращается defaultvalue function ToInteger(Self: string; defaultvalue: integer): integer; extensionmethod; @@ -12221,6 +12740,12 @@ begin Result := Self.Split(delim, System.StringSplitOptions.RemoveEmptyEntries); end; +/// Преобразует строку в массив слов, используя в качестве разделителей символы из строки delims +function ToWords(Self: string; delims: string := ' '): array of string; extensionmethod; +begin + Result := Self.Split(delims.ToCharArray, System.StringSplitOptions.RemoveEmptyEntries); +end; + procedure PassSpaces(var s: string; var from: integer); begin while (from <= s.Length) and (s[from]=' ') do @@ -12723,59 +13248,59 @@ function operator>=(Self: (T1, T2, T3, T4,T5,T6,T7); v: (T // ------------------------------------------- // Дополнения февраль 2016 -// Добавляет поле к кортежу +/// Добавляет поле к кортежу function Add(Self: (T1, T2); v: T3): (T1, T2, T3); extensionmethod; begin Result := (Self[0], Self[1], v); end; -// Добавляет поле к кортежу +/// Добавляет поле к кортежу function Add(Self: (T1, T2, T3); v: T4): (T1, T2, T3, T4); extensionmethod; begin Result := (Self[0], Self[1], Self[2], v); end; -// Добавляет поле к кортежу +/// Добавляет поле к кортежу function Add(Self: (T1, T2, T3, T4); v: T5): (T1, T2, T3, T4, T5); extensionmethod; begin Result := (Self[0], Self[1], Self[2], Self[3], v); end; -// Добавляет поле к кортежу +/// Добавляет поле к кортежу function Add(Self: (T1, T2, T3, T4, T5); v: T6): (T1, T2, T3, T4, T5, T6); extensionmethod; begin Result := (Self[0], Self[1], Self[2], Self[3], Self[4], v); end; -// Добавляет поле к кортежу +/// Добавляет поле к кортежу function Add(Self: (T1, T2, T3, T4, T5, T6); v: T7): (T1, T2, T3, T4, T5, T6, T7); extensionmethod; begin Result := (Self[0], Self[1], Self[2], Self[3], Self[4], Self[5], v); end; -// Выводит кортеж +/// Выводит кортеж procedure Print(Self: (T1, T2)); extensionmethod := Print(Self); -// Выводит кортеж +/// Выводит кортеж procedure Print(Self: (T1, T2, T3)); extensionmethod := Print(Self); -// Выводит кортеж +/// Выводит кортеж procedure Print(Self: (T1, T2, T3, T4)); extensionmethod := Print(Self); -// Выводит кортеж +/// Выводит кортеж procedure Print(Self: (T1, T2, T3, T4, T5)); extensionmethod := Print(Self); -// Выводит кортеж +/// Выводит кортеж procedure Print(Self: (T1, T2, T3, T4, T5, T6)); extensionmethod := Print(Self); -// Выводит кортеж +/// Выводит кортеж procedure Print(Self: (T1, T2, T3, T4, T5, T6, T7)); extensionmethod := Print(Self); -// Выводит кортеж и переходит на новую строку +/// Выводит кортеж и переходит на новую строку procedure Println(Self: (T1, T2)); extensionmethod := Println(Self); -// Выводит кортеж и переходит на новую строку +/// Выводит кортеж и переходит на новую строку procedure Println(Self: (T1, T2, T3)); extensionmethod := Println(Self); -// Выводит кортеж и переходит на новую строку +/// Выводит кортеж и переходит на новую строку procedure Println(Self: (T1, T2, T3, T4)); extensionmethod := Println(Self); -// Выводит кортеж и переходит на новую строку +/// Выводит кортеж и переходит на новую строку procedure Println(Self: (T1, T2, T3, T4, T5)); extensionmethod := Println(Self); -// Выводит кортеж и переходит на новую строку +/// Выводит кортеж и переходит на новую строку procedure Println(Self: (T1, T2, T3, T4, T5, T6)); extensionmethod := Println(Self); -// Выводит кортеж и переходит на новую строку +/// Выводит кортеж и переходит на новую строку procedure Println(Self: (T1, T2, T3, T4, T5, T6, T7)); extensionmethod := Println(Self); @@ -13385,7 +13910,11 @@ end; procedure __InitModule; begin - DefaultEncoding := Encoding.GetEncoding(1251); + try + DefaultEncoding := Encoding.GetEncoding(1251); + except + DefaultEncoding := Encoding.UTF8; + end; rnd := new System.Random; CurrentIOSystem := new IOStandardSystem; diff --git a/TestSuite/formatter_tests/input/graph3d.pas b/TestSuite/formatter_tests/input/graph3d.pas index 9ab008773..84be6d6a8 100644 --- a/TestSuite/formatter_tests/input/graph3d.pas +++ b/TestSuite/formatter_tests/input/graph3d.pas @@ -22,6 +22,7 @@ uses System.XML; uses System.IO; uses System.Threading; uses System.Windows.Input; +uses System.Runtime.Serialization; uses HelixToolkit.Wpf; //uses Petzold.Media3D; @@ -41,6 +42,8 @@ type GMaterial = System.Windows.Media.Media3D.Material; /// Тип диффузного материала GDiffuseMaterial = System.Windows.Media.Media3D.DiffuseMaterial; + /// Тип зеркальногоы материала + GSpecularMaterial = System.Windows.Media.Media3D.SpecularMaterial; /// Тип материала свечения GEmissiveMaterial = System.Windows.Media.Media3D.EmissiveMaterial; /// Тип камеры @@ -75,8 +78,10 @@ var //>> Короткие функции модуля Graph3D # Graph3D short functions // ----------------------------------------------------- +/// Процедура синхронизации операций с потоком, создающим графические элементы +procedure Invoke(p: procedure); /// Процедура ускорения вывода. Обновляет экран после всех изменений -procedure Redraw(p: ()->()); +procedure Redraw(p: procedure); /// Возвращает цвет по красной, зеленой и синей составляющей (в диапазоне 0..255) function RGB(r, g, b: byte): Color; /// Возвращает цвет по красной, зеленой и синей составляющей и параметру прозрачности (в диапазоне 0..255) @@ -230,11 +235,11 @@ type procedure SetD(d: real) := Invoke(SetDP, d); function GetD: real := InvokeReal(()->Cam.Position.DistanceTo(P3D(0, 0, 0))); - procedure MoveOnP(x,y,z: real); + procedure MoveByP(x,y,z: real); begin Cam.Position += V3D(x,y,z)//:= P3D(Cam.Position. end; - procedure MoveOnPV(v: Vector3D); + procedure MoveByPV(v: Vector3D); begin Cam.Position += v; end; @@ -270,9 +275,13 @@ type property Distanse: real read GetD write SetD; /// Перемещает камеру на вектор (dx,dy,dz) - procedure MoveOn(dx,dy,dz: real) := Invoke(MoveOnP,dx,dy,dz); + procedure MoveBy(dx,dy,dz: real) := Invoke(MoveByP,dx,dy,dz); /// Перемещает камеру на вектор v - procedure MoveOn(v: Vector3D) := Invoke(MoveOnPV,v); + procedure MoveBy(v: Vector3D) := Invoke(MoveByPV,v); + ///-- + procedure MoveOn(dx,dy,dz: real) := Invoke(MoveByP,dx,dy,dz); + ///-- + procedure MoveOn(v: Vector3D) := Invoke(MoveByPV,v); /// Обеспечивает плавное движение камеры procedure AddMoveForce(ForwardForce,RightForce,UpForce: real) := Invoke(AddMoveForceP,RightForce,UpForce,ForwardForce); /// Обеспечивает плавное движение камеры вперед с некоторой силой @@ -352,12 +361,14 @@ type // ----------------------------------------------------- //>> Graph3D: класс Object3D # Graph3D Object3D class // ----------------------------------------------------- + [Serializable] ///!# /// Базовый класс трехмерных объектов - Object3D = class - (DependencyObject) // для генерации документации - private + Object3D = class(ISerializable) + //(DependencyObject) // для генерации документации + public model: Visual3D; + private Parent: ObjectWithChildren3D; transfgroup := new Transform3DGroup; @@ -368,7 +379,7 @@ type procedure AddToObject3DList; procedure DeleteFromObject3DList; - + protected procedure CreateBase0(m: Visual3D; x, y, z: real); begin model := m; @@ -384,7 +395,7 @@ type hvp.Children.Add(model); AddToObject3DList; end; - + private procedure SetX(xx: real) := Invoke(()->begin transltransform.OffsetX += xx - Self.X; end); function GetX: real := InvokeReal(()->transfgroup.Value.OffsetX); procedure SetY(yy: real) := Invoke(()->begin transltransform.OffsetY += yy - Self.Y; end); @@ -435,6 +446,61 @@ type end; public + function CreateModel: Visual3D; virtual; + begin + Result := nil; + end; + + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + //Invoke(procedure -> begin + info.AddValue('rotatetransform', rotatetransform.Value, typeof(Matrix3D)); + info.AddValue('scalex', scaletransform.ScaleX, typeof(real)); + info.AddValue('scaley', scaletransform.ScaleY, typeof(real)); + info.AddValue('scalez', scaletransform.ScaleZ, typeof(real)); + info.AddValue('offsetx', transltransform.OffsetX, typeof(real)); + info.AddValue('offsety', transltransform.OffsetY, typeof(real)); + info.AddValue('offsetz', transltransform.OffsetZ, typeof(real)); + info.AddValue('rotatetransform_absolute', rotatetransform_absolute.Value, typeof(Matrix3D)); + //end); + end; + + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + //Invoke(procedure -> begin + model := CreateModel; + rotatetransform := new MatrixTransform3D(Matrix3D(info.GetValue('rotatetransform', typeof(Matrix3D)))); + var scalex := real(info.GetValue('scalex', typeof(real))); + var scaley := real(info.GetValue('scaley', typeof(real))); + var scalez := real(info.GetValue('scalez', typeof(real))); + scaletransform := new ScaleTransform3D(scalex,scaley,scalez); + + var offsetx := real(info.GetValue('offsetx', typeof(real))); + var offsety := real(info.GetValue('offsety', typeof(real))); + var offsetz := real(info.GetValue('offsetz', typeof(real))); + + transltransform := new TranslateTransform3D(offsetx,offsety,offsetz); + + rotatetransform_absolute := new MatrixTransform3D(Matrix3D(info.GetValue('rotatetransform_absolute', typeof(Matrix3D)))); + transfgroup := new Transform3DGroup; + transfgroup.Children.Add(rotatetransform); + transfgroup.Children.Add(scaletransform); + transfgroup.Children.Add(transltransform); + transfgroup.Children.Add(rotatetransform_absolute); + + AddToObject3DList; + //if model<>nil then + begin + model.Transform := transfgroup; + hvp.Children.Add(model); + end; + //end); + end; + + procedure Serialize(fname: string); + + static function DeSerialize(fname: string): Object3D; + constructor(model: Visual3D) := CreateBase0(model, 0, 0, 0); /// Координата X @@ -458,15 +524,25 @@ type /// Перемещает 3D-объект к точке p function MoveTo(p: Point3D): Object3D := MoveTo(p.X, p.y, p.z); /// Перемещает 3D-объект на вектор (dx,dy,dz) - function MoveOn(dx, dy, dz: real): Object3D := MoveTo(x + dx, y + dy, z + dz); + function MoveBy(dx, dy, dz: real): Object3D := MoveTo(x + dx, y + dy, z + dz); /// Перемещает 3D-объект на вектор v - function MoveOn(v: Vector3D): Object3D := MoveOn(v.X, v.Y, v.Z); + function MoveBy(v: Vector3D): Object3D := MoveBy(v.X, v.Y, v.Z); /// Перемещает x-координату 3D-объекта на dx - function MoveOnX(dx: real): Object3D := MoveOn(dx, 0, 0); + function MoveByX(dx: real): Object3D := MoveBy(dx, 0, 0); /// Перемещает y-координату 3D-объекта на dy - function MoveOnY(dy: real): Object3D := MoveOn(0, dy, 0); + function MoveByY(dy: real): Object3D := MoveBy(0, dy, 0); /// Перемещает z-координату 3D-объекта на dz - function MoveOnZ(dz: real): Object3D := MoveOn(0, 0, dz); + function MoveByZ(dz: real): Object3D := MoveBy(0, 0, dz); + ///-- + function MoveOn(dx, dy, dz: real): Object3D := MoveTo(x + dx, y + dy, z + dz); + ///-- + function MoveOn(v: Vector3D): Object3D := MoveBy(v.X, v.Y, v.Z); + ///-- + function MoveOnX(dx: real): Object3D := MoveBy(dx, 0, 0); + ///-- + function MoveOnY(dy: real): Object3D := MoveBy(0, dy, 0); + ///-- + function MoveOnZ(dz: real): Object3D := MoveBy(0, 0, dz); /// Перемещает 3D-объект вдоль вектора Direction со скоростью Velocity за время dt procedure MoveTime(dt: real); virtual; begin @@ -479,7 +555,7 @@ type var dvx := dx/len*Velocity; var dvy := dy/len*Velocity; var dvz := dz/len*Velocity; - MoveOn(dvx*dt,dvy*dt,dvz*dt); + MoveBy(dvx*dt,dvy*dt,dvz*dt); end; /// Цвет 3D-объекта property Color: GColor read GetColor write SetColor; virtual; @@ -578,35 +654,35 @@ type function AnimMoveTrajectory(trajectory: sequence of Point3D; seconds: real := 1): AnimationBase := AnimMoveTrajectory(trajectory,seconds,nil); /// Возвращает анимацию перемещения объекта на вектор (dx, dy, dz) за seconds секунд. В конце анимации выполняется процедура Completed - function AnimMoveOn(dx, dy, dz: real; seconds: real; Completed: procedure): AnimationBase; + function AnimMoveBy(dx, dy, dz: real; seconds: real; Completed: procedure): AnimationBase; /// Возвращает анимацию перемещения объекта на вектор (dx, dy, dz) за seconds секунд - function AnimMoveOn(dx, dy, dz: real; seconds: real := 1): AnimationBase := AnimMoveOn(dx,dy,dz,seconds,nil); + function AnimMoveBy(dx, dy, dz: real; seconds: real := 1): AnimationBase := AnimMoveBy(dx,dy,dz,seconds,nil); /// Возвращает анимацию перемещения объекта на вектор v за seconds секунд. В конце анимации выполняется процедура Completed - function AnimMoveOn(v: Vector3D; seconds: real; Completed: procedure) := AnimMoveOn(v.x, v.y, v.z, seconds, Completed); + function AnimMoveBy(v: Vector3D; seconds: real; Completed: procedure) := AnimMoveBy(v.x, v.y, v.z, seconds, Completed); /// Возвращает анимацию перемещения объекта на вектор v за seconds секунд - function AnimMoveOn(v: Vector3D; seconds: real := 1) := AnimMoveOn(v.x, v.y, v.z, seconds, nil); + function AnimMoveBy(v: Vector3D; seconds: real := 1) := AnimMoveBy(v.x, v.y, v.z, seconds, nil); /// Возвращает анимацию перемещения объекта по оси OX на величину dx за seconds секунд. В конце анимации выполняется процедура Completed - function AnimMoveOnX(dx: real; seconds: real; Completed: procedure) := AnimMoveOn(dx, 0, 0, seconds, Completed); + function AnimMoveByX(dx: real; seconds: real; Completed: procedure) := AnimMoveBy(dx, 0, 0, seconds, Completed); /// Возвращает анимацию перемещения объекта по оси OX на величину dx за seconds секунд - function AnimMoveOnX(dx: real; seconds: real) := AnimMoveOnX(dx, seconds, nil); + function AnimMoveByX(dx: real; seconds: real) := AnimMoveByX(dx, seconds, nil); /// Возвращает анимацию перемещения объекта по оси OX на величину dx за 1 секунду - function AnimMoveOnX(dx: real) := AnimMoveOnX(dx, 1, nil); + function AnimMoveByX(dx: real) := AnimMoveByX(dx, 1, nil); /// Возвращает анимацию перемещения объекта по оси OY на величину dy за seconds секунд. В конце анимации выполняется процедура Completed - function AnimMoveOnY(dy: real; seconds: real; Completed: procedure) := AnimMoveOn(0, dy, 0, seconds, Completed); + function AnimMoveByY(dy: real; seconds: real; Completed: procedure) := AnimMoveBy(0, dy, 0, seconds, Completed); /// Возвращает анимацию перемещения объекта по оси OY на величину dy за seconds секунд - function AnimMoveOnY(dy: real; seconds: real) := AnimMoveOnY(dy, seconds, nil); + function AnimMoveByY(dy: real; seconds: real) := AnimMoveByY(dy, seconds, nil); /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за 1 секунду - function AnimMoveOnY(dy: real) := AnimMoveOnY(dy, 1, nil); + function AnimMoveByY(dy: real) := AnimMoveByY(dy, 1, nil); /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за seconds секунд. В конце анимации выполняется процедура Completed - function AnimMoveOnZ(dz: real; seconds: real; Completed: procedure) := AnimMoveOn(0, 0, dz, seconds, Completed); + function AnimMoveByZ(dz: real; seconds: real; Completed: procedure) := AnimMoveBy(0, 0, dz, seconds, Completed); /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за seconds секунд - function AnimMoveOnZ(dz: real; seconds: real) := AnimMoveOnZ(dz, seconds, nil); + function AnimMoveByZ(dz: real; seconds: real) := AnimMoveByZ(dz, seconds, nil); /// Возвращает анимацию перемещения объекта по оси OZ на величину dz за 1 секунду - function AnimMoveOnZ(dz: real) := AnimMoveOnZ(dz, 1, nil); + function AnimMoveByZ(dz: real) := AnimMoveByZ(dz, 1, nil); /// Возвращает анимацию масштабирования объекта на величину sc за seconds секунд. В конце анимации выполняется процедура Completed function AnimScale(sc: real; seconds: real; Completed: procedure): AnimationBase; @@ -668,8 +744,9 @@ type // ----------------------------------------------------- //>> Graph3D: класс ObjectWithChildren3D # Graph3D ObjectWithChildren3D class // ----------------------------------------------------- + [Serializable] /// 3D-объект с дочерними подобъектами - ObjectWithChildren3D = class(Object3D) // model is ModelVisual3D + ObjectWithChildren3D = class(Object3D,ISerializable) // model is ModelVisual3D private l := new List; @@ -736,6 +813,22 @@ type foreach var xx in ll do AddChild(xx.Clone); end; + + function ColorToLongWord(c: GColor): longword; + begin + Result := ((c.A * 256 + c.R) * 256 + c.G) * 256 + c.B; + end; + + function LongWordToColor(w: longword): GColor; + begin + var b := w mod 256; + w := w div 256; + var g := w mod 256; + w := w div 256; + var r := w mod 256; + var a := w div 256; + Result := ARGB(a,r,g,b); + end; public /// Добавить дочерний подобъект @@ -771,13 +864,39 @@ type inherited Destroy; Invoke(DestroyP); end; + + function CreateModel: Visual3D; override; + begin + Result := nil; + end; + + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('listchildrencount',l.Count,typeof(integer)); + for var i:=0 to l.Count -1 do + info.AddValue('children'+i, l[i], typeof(Object3D)); + end; + + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + l := new List; + var count := integer(info.GetValue('listchildrencount',typeof(integer))); + for var i:=0 to count-1 do + begin + var xx := info.GetValue('children'+i, typeof(Object3D)) as Object3D; + AddChild(xx); + end; + end; end; // ----------------------------------------------------- //>> Graph3D: класс ObjectWithMaterial3D # Graph3D ObjectWithMaterial3D class // ----------------------------------------------------- + [Serializable] /// 3D-объект с материалом - ObjectWithMaterial3D = class(ObjectWithChildren3D) // model is MeshElement3D + ObjectWithMaterial3D = class(ObjectWithChildren3D,ISerializable) // model is MeshElement3D private procedure CreateBase(m: MeshElement3D; x, y, z: real; mat: GMaterial); begin @@ -822,10 +941,133 @@ type property BackMaterial: GMaterial read GetBMaterial write SetBMaterial; /// Видим ли объект property Visible: boolean read GetV write SetV; + + function CreateModel: Visual3D; override; + begin + Result := nil; + end; + private + procedure SaveMaterialHelper(mat: GMaterial; info: SerializationInfo; i: integer; back: string := ''); + begin + match mat with + GDiffuseMaterial(dm): + begin + if dm.Brush is SolidColorBrush(var scb) then + begin + info.AddValue('materialkind' + back + i, 'diffuse' + back, typeof(string)); + info.AddValue('diffusebrushcolor' + back, ColorToLongWord(scb.Color), typeof(longword)); + end + else if dm.Brush is ImageBrush(var ib) then + begin + info.AddValue('materialkind' + back + i, 'diffusetexture' + back, typeof(string)); + var bi := (ib.ImageSource as System.Windows.Media.Imaging.BitmapImage); + info.AddValue('ibViewPortWidth' + back, ib.Viewport.Width, typeof(real)); + info.AddValue('ibViewPortHeight' + back, ib.Viewport.Height, typeof(real)); + info.AddValue('texturepath' + back, bi.UriSource.ToString, typeof(string)); + end; + end; + GSpecularMaterial(spm): + begin + info.AddValue('materialkind' + back + i, 'specular' + back, typeof(string)); + if spm.Brush is SolidColorBrush(var scb) then + info.AddValue('specularbrushcolor' + back, ColorToLongWord(scb.Color), typeof(longword)); + end; + GEmissiveMaterial(em): + begin + info.AddValue('materialkind' + back + i, 'emissive' + back, typeof(string)); + if em.Brush is SolidColorBrush(var scb) then + info.AddValue('emissivebrushcolor' + back, ColorToLongWord(scb.Color), typeof(longword)); + end; + end; + end; + procedure SaveMaterial(mat: GMaterial; info: SerializationInfo; back: string := ''); + begin + if mat is MaterialGroup (var mg) then + info.AddValue('materialscount' + back, mg.Children.Count, typeof(integer)) + else info.AddValue('materialscount' + back, 1, typeof(integer)); + + if mat is MaterialGroup (var mg) then + begin + var i := 1; + foreach var m in (mat as MaterialGroup).Children do + begin + SaveMaterialHelper(m as GMaterial, info,i,back); + i += 1; + end + end + else SaveMaterialHelper(mat,info,1,back); + end; + public +///-- + procedure GetObjectData(info: System.Runtime.Serialization.SerializationInfo; context: System.Runtime.Serialization.StreamingContext); + begin + inherited GetObjectData(info,context); + SaveMaterial(Material,info,''); + SaveMaterial(BackMaterial,info,'back'); + end; + private + function LoadMaterialHelper(info: SerializationInfo; i: integer; back: string := ''): GMaterial; + begin + Result := nil; + var mk := info.GetString('materialkind'+back+i); + if mk = 'diffuse' + back then + begin + var w := info.GetUInt32('diffusebrushcolor'+back); + var c := LongWordToColor(w); + Result := Materials.Diffuse(c); + end + else if mk = 'diffusetexture' + back then + begin + var fname := info.GetString('texturepath'+back); + var width := info.GetDouble('ibViewPortWidth' + back); + var height := info.GetDouble('ibViewPortHeight' + back); + if (width<>1) or (height<>1) then + Result := Materials.Image(fname,width,height) + else Result := Materials.Image(fname); + end + else if mk = 'specular' + back then + begin + var w := info.GetUInt32('specularbrushcolor'+back); + var c := LongWordToColor(w); + Result := Materials.Specular(c); + end + else if mk = 'emissive' + back then + begin + var w := info.GetUInt32('emissivebrushcolor'+back); + var c := LongWordToColor(w); + Result := Materials.Emissive(c); + end; + end; + function LoadMaterial(info: SerializationInfo; back: string := ''): GMaterial; + begin + var count := integer(info.GetValue('materialscount'+back, typeof(integer))); + if count = 1 then + begin + Result := LoadMaterialHelper(info,1,back); + end + else + begin + var mg := new MaterialGroup(); + for var i:=1 to count do + begin + var m := LoadMaterialHelper(info,i,back); + mg.Children.Add(m) + end; + Result := mg; + end; + end; + public + constructor Create(info: System.Runtime.Serialization.SerializationInfo; context: System.Runtime.Serialization.StreamingContext); + begin + inherited Create(info,context); + (model as MeshElement3D).Material := LoadMaterial(info); + (model as MeshElement3D).BackMaterial := LoadMaterial(info,'back'); + end; end; + [Serializable] /// Группа 3D-объектов - Group3D = class(ObjectWithChildren3D) + Group3D = class(ObjectWithChildren3D,ISerializable) protected function CreateObject: Object3D; override := new Group3D(X, Y, Z); //public @@ -846,9 +1088,22 @@ type RemoveChild(l[i]); end; end; +///-- + function CreateModel: Visual3D; override; + begin + Result := new ModelVisual3D; + end; +///-- + procedure GetObjectData(info: System.Runtime.Serialization.SerializationInfo; context: System.Runtime.Serialization.StreamingContext); + begin + inherited GetObjectData(info,context); + end; +///-- + constructor Create(info: System.Runtime.Serialization.SerializationInfo; context: System.Runtime.Serialization.StreamingContext); + begin + inherited Create(info,context); + end; - /// ВОзвращает клон группы 3D-объектов - function Clone := (inherited Clone) as Group3D; end; //------------------------------ Animations ----------------------------------- @@ -1507,8 +1762,9 @@ type // ----------------------------------------------------- //>> Graph3D: класс SphereT # Graph3D SphereT class // ----------------------------------------------------- + [Serializable] /// Класс сферы - SphereT = class(ObjectWithMaterial3D) + SphereT = class(ObjectWithMaterial3D,ISerializable) private function Model := inherited model as SphereVisual3D; procedure SetRP(r: real) := Model.Radius := r; @@ -1531,13 +1787,29 @@ type property Radius: real read GetR write SetR; /// Возвращает клон сферы function Clone := (inherited Clone) as SphereT; + +///-- + function CreateModel: Visual3D; override := new SphereVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('radius', Radius, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Radius := info.GetDouble('radius'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс EllipsoidT # Graph3D EllipsoidT class // ----------------------------------------------------- + [Serializable] /// Класс эллипсоида - EllipsoidT = class(ObjectWithMaterial3D) + EllipsoidT = class(ObjectWithMaterial3D,ISerializable) private function Model := inherited model as EllipsoidVisual3D; procedure SetRX(r: real) := Invoke(procedure(r: real)->Model.RadiusX := r, r); @@ -1570,13 +1842,32 @@ type property RadiusZ: real read GetRZ write SetRZ; /// Возвращает клон эллипсоида function Clone := (inherited Clone) as EllipsoidT; +///-- + function CreateModel: Visual3D; override := new EllipsoidVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('RadiusX', RadiusX, typeof(real)); + info.AddValue('RadiusY', RadiusY, typeof(real)); + info.AddValue('RadiusZ', RadiusZ, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + RadiusX := info.GetDouble('RadiusX'); + RadiusY := info.GetDouble('RadiusY'); + RadiusZ := info.GetDouble('RadiusZ'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс CubeT # Graph3D CubeT class // ----------------------------------------------------- + [Serializable] /// Класс куба - CubeT = class(ObjectWithMaterial3D) + CubeT = class(ObjectWithMaterial3D,ISerializable) private function model := inherited model as CubeVisual3D; procedure SetWP(r: real) := model.SideLength := r; @@ -1600,13 +1891,28 @@ type property SideLength: real read GetW write SetW; /// Возвращает клон куба function Clone := (inherited Clone) as CubeT; +///-- + function CreateModel: Visual3D; override := new CubeVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('SideLength', SideLength, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + SideLength := info.GetDouble('SideLength'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс BoxT # Graph3D BoxT class // ----------------------------------------------------- + [Serializable] /// Класс паралеллепипеда - BoxT = class(ObjectWithMaterial3D) + BoxT = class(ObjectWithMaterial3D,ISerializable) private function model := inherited model as BoxVisual3D; procedure SetWP(r: real) := model.Width := r; @@ -1648,13 +1954,32 @@ type property Size: Size3D read GetSz write SetSz; /// Возвращает клон паралеллепипеда function Clone := (inherited Clone) as BoxT; +///-- + function CreateModel: Visual3D; override := new BoxVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Length', Length, typeof(real)); + info.AddValue('Width', Width, typeof(real)); + info.AddValue('Height', Height, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Length := info.GetDouble('Length'); + Width := info.GetDouble('Width'); + Height := info.GetDouble('Height'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс ArrowT # Graph3D ArrowT class // ----------------------------------------------------- + [Serializable] /// Класс 3D-стрелки - ArrowT = class(ObjectWithMaterial3D) + ArrowT = class(ObjectWithMaterial3D,ISerializable) private function model := inherited model as ArrowVisual3D; @@ -1697,13 +2022,37 @@ type property Direction: Vector3D read GetDir write SetDir; /// Возвращает клон 3D-стрелки function Clone := (inherited Clone) as ArrowT; +///-- + function CreateModel: Visual3D; override := new ArrowVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('HeadLength', HeadLength, typeof(real)); + info.AddValue('Diameter', Diameter, typeof(real)); + info.AddValue('DirectionX', Direction.X, typeof(real)); + info.AddValue('DirectionY', Direction.Y, typeof(real)); + info.AddValue('DirectionZ', Direction.Z, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + HeadLength := info.GetDouble('HeadLength'); + Diameter := info.GetDouble('Diameter'); + var dx := info.GetDouble('DirectionX'); + var dy := info.GetDouble('DirectionY'); + var dz := info.GetDouble('DirectionZ'); + Direction := V3D(dx,dy,dz); + end; end; // ----------------------------------------------------- //>> Graph3D: класс TruncatedConeT # Graph3D TruncatedConeT class // ----------------------------------------------------- + [Serializable] /// Класс усеченного конуса - TruncatedConeT = class(ObjectWithMaterial3D) + TruncatedConeT = class(ObjectWithMaterial3D,ISerializable) private function model := inherited model as TruncatedConeVisual3D; @@ -1754,13 +2103,34 @@ type property Topcap: boolean read GetTC write SetTC; /// Возвращает клон усеченного конуса function Clone := (inherited Clone) as TruncatedConeT; +///-- + function CreateModel: Visual3D; override := new TruncatedConeVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Height', Height, typeof(real)); + info.AddValue('BaseRadius', BaseRadius, typeof(real)); + info.AddValue('TopRadius', TopRadius, typeof(real)); + info.AddValue('Topcap', Topcap, typeof(boolean)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Height := info.GetDouble('Height'); + BaseRadius := info.GetDouble('BaseRadius'); + TopRadius := info.GetDouble('TopRadius'); + Topcap := info.GetBoolean('Topcap'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс CylinderT # Graph3D CylinderT class // ----------------------------------------------------- + [Serializable] /// Класс цилиндра - CylinderT = class(TruncatedConeT) + CylinderT = class(TruncatedConeT,ISerializable) private procedure SetR(r: real); begin @@ -1782,13 +2152,21 @@ type property Radius: real read GetR write SetR; /// Возвращает клон цилиндра function Clone := (inherited Clone) as CylinderT; +///-- + function CreateModel: Visual3D; override := new TruncatedConeVisual3D; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс TeapotT # Graph3D TeapotT class // ----------------------------------------------------- + [Serializable] /// Класс чайника - TeapotT = class(ObjectWithMaterial3D) + TeapotT = class(ObjectWithMaterial3D,ISerializable) private procedure SetVP(v: boolean) := (model as MeshElement3D).Visible := v; procedure SetV(v: boolean) := Invoke(SetVP, v); @@ -1806,13 +2184,21 @@ type property Visible: boolean read GetV write SetV; /// Возвращает клон чайника function Clone := (inherited Clone) as TeapotT; +///-- + function CreateModel: Visual3D; override := new Teapot; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс CoordinateSystemT # Graph3D CoordinateSystemT class // ----------------------------------------------------- + [Serializable] /// Класс системы координат - CoordinateSystemT = class(ObjectWithChildren3D) + CoordinateSystemT = class(ObjectWithChildren3D,ISerializable) private procedure SetALP(r: real) := (model as CoordinateSystemVisual3D).ArrowLengths := r; procedure SetAL(r: real) := Invoke(SetALP, r); @@ -1838,13 +2224,35 @@ type property Diameter: real read GetD; /// Возвращает клон системы координат function Clone := (inherited Clone) as CoordinateSystemT; +///-- + function CreateModel: Visual3D; override := new CoordinateSystemVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('ArrowLengths', ArrowLengths, typeof(real)); + info.AddValue('Diameter', Diameter, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + ArrowLengths := info.GetDouble('ArrowLengths'); + var d := info.GetDouble('Diameter'); + var a := model as CoordinateSystemVisual3D; + (a.Children[0] as ArrowVisual3D).Diameter := d; + (a.Children[1] as ArrowVisual3D).Diameter := d; + (a.Children[2] as ArrowVisual3D).Diameter := d; + (a.Children[3] as CubeVisual3D).SideLength := d; + end; end; // ----------------------------------------------------- //>> Graph3D: класс BillboardTextT # Graph3D BillboardTextT class // ----------------------------------------------------- + [Serializable] /// Класс текста на билборде (всегда направлен к камере) - BillboardTextT = class(ObjectWithChildren3D) + BillboardTextT = class(ObjectWithChildren3D,ISerializable) private function model := inherited model as BillboardTextVisual3D; @@ -1873,13 +2281,30 @@ type property FontSize: real read GetFS write SetFS; /// Возвращает клон билборда function Clone := (inherited Clone) as BillboardTextT; +///-- + function CreateModel: Visual3D; override := new BillboardTextVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Text', Text, typeof(string)); + info.AddValue('FontSize', FontSize, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Text := info.GetString('Text'); + FontSize := info.GetDouble('FontSize'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс TextT # Graph3D TextT class // ----------------------------------------------------- + [Serializable] /// Класс 3D-текстового объекта - TextT = class(ObjectWithChildren3D) + TextT = class(ObjectWithChildren3D,ISerializable) private _fontname: string; function model := inherited model as TextVisual3D; @@ -1897,7 +2322,7 @@ type function GetU: Vector3D := Invoke&(()->model.UpDirection); procedure SetNP(fontname: string) := model.FontFamily := new FontFamily(fontname); - procedure SetN(fontname: string) := Invoke(SetTP, fontname); + procedure SetN(fontname: string) := Invoke(SetNP, fontname); function GetN: string := InvokeString(()->_fontname); procedure SetColorP(c: GColor) := model.Foreground := new SolidColorBrush(c); @@ -1931,13 +2356,41 @@ type property Color: GColor read GetColor write SetColor; override; /// Возвращает клон 3D-текстового объекта function Clone := (inherited Clone) as TextT; +///-- + function CreateModel: Visual3D; override := new TextVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Text', Text, typeof(string)); + info.AddValue('Height', Height, typeof(real)); + info.AddValue('FontName', FontName, typeof(string)); + info.AddValue('UpDirectionX', UpDirection.X, typeof(real)); + info.AddValue('UpDirectionY', UpDirection.Y, typeof(real)); + info.AddValue('UpDirectionZ', UpDirection.Z, typeof(real)); + info.AddValue('Color', ColorToLongWord(Color), typeof(longword)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Text := info.GetString('Text'); + model.Height := info.GetDouble('Height'); + FontName := info.GetString('FontName'); + var dx := info.GetDouble('UpDirectionX'); + var dy := info.GetDouble('UpDirectionY'); + var dz := info.GetDouble('UpDirectionZ'); + UpDirection := V3D(dx,dy,dz); + Color := LongwordToColor(info.GetUInt32('Color')); + end; end; // ----------------------------------------------------- //>> Graph3D: класс RectangleT # Graph3D RectangleT class // ----------------------------------------------------- + [Serializable] /// Класс 3D-прямоугольника - RectangleT = class(ObjectWithMaterial3D) + RectangleT = class(ObjectWithMaterial3D,ISerializable) private function model := inherited model as RectangleVisual3D; procedure SetWP(r: real) := model.Width := r; @@ -1979,13 +2432,44 @@ type property Normal: Vector3D read GetN write SetN; /// Возвращает клон 3D-прямоугольника function Clone := (inherited Clone) as RectangleT; +///-- + function CreateModel: Visual3D; override := new RectangleVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Width', Width, typeof(real)); + info.AddValue('Length', Length, typeof(real)); + info.AddValue('LengthDirectionX', LengthDirection.X, typeof(real)); + info.AddValue('LengthDirectionY', LengthDirection.Y, typeof(real)); + info.AddValue('LengthDirectionZ', LengthDirection.Z, typeof(real)); + info.AddValue('NormalX', Normal.X, typeof(real)); + info.AddValue('NormalY', Normal.Y, typeof(real)); + info.AddValue('NormalZ', Normal.Z, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Width := info.GetDouble('Width'); + Length := info.GetDouble('Length'); + var dx := info.GetDouble('LengthDirectionX'); + var dy := info.GetDouble('LengthDirectionY'); + var dz := info.GetDouble('LengthDirectionZ'); + LengthDirection := V3D(dx,dy,dz); + dx := info.GetDouble('NormalX'); + dy := info.GetDouble('NormalY'); + dz := info.GetDouble('NormalZ'); + Normal := V3D(dx,dy,dz); + end; end; // ----------------------------------------------------- //>> Graph3D: класс FileModelT # Graph3D FileModelT class // ----------------------------------------------------- + [Serializable] /// Класс 3D-модели - FileModelT = class(ObjectWithChildren3D) + FileModelT = class(ObjectWithChildren3D,ISerializable) private fn: string; procedure SetMP(mat: GMaterial) := (model as FileModelVisual3D).DefaultMaterial := mat; @@ -2016,13 +2500,28 @@ type public /// Возвращает клон 3D-модели function Clone := (inherited Clone) as FileModelT; +///-- + function CreateModel: Visual3D; override := new FileModelVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('FileName', (model as FileModelVisual3D).Source as string, typeof(string)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + (model as FileModelVisual3D).Source := info.GetString('FileName'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс PipeT # Graph3D PipeT class // ----------------------------------------------------- + [Serializable] /// Класс трубы - PipeT = class(ObjectWithMaterial3D) + PipeT = class(ObjectWithMaterial3D,ISerializable) private function model := inherited model as PipeVisual3D; procedure SetDP(r: real) := model.Diameter := r * 2; @@ -2057,13 +2556,32 @@ type property Height: real read GetH write SetH; /// Возвращает клон трубы function Clone := (inherited Clone) as PipeT; +///-- + function CreateModel: Visual3D; override := new PipeVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Radius', Radius, typeof(real)); + info.AddValue('InnerRadius', InnerRadius, typeof(real)); + info.AddValue('Height', Height, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Radius := info.GetDouble('Radius'); + InnerRadius := info.GetDouble('InnerRadius'); + Height := info.GetDouble('Height'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс LegoT # Graph3D LegoT class // ----------------------------------------------------- + [Serializable] /// Класс лего-детали - LegoT = class(ObjectWithMaterial3D) + LegoT = class(ObjectWithMaterial3D,ISerializable) private //function model := inherited model as LegoVisual3D; procedure SetWP(r: integer); @@ -2099,78 +2617,142 @@ type {property Size: Size3D read GetSz write SetSz;} /// Возвращает клон лего-детали function Clone := (inherited Clone) as LegoT; +///-- + function CreateModel: Visual3D; override; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Columns', Columns, typeof(integer)); + info.AddValue('Rows', Rows, typeof(integer)); + info.AddValue('Height', Height, typeof(integer)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Columns := info.GetInt32('Columns'); + Rows := info.GetInt32('Rows'); + Height := info.GetInt32('Height'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс PlatonicAbstractT # Graph3D PlatonicAbstractT class // ----------------------------------------------------- + [Serializable] /// Абстрактный класс платоновых тел - PlatonicAbstractT = class(ObjectWithMaterial3D) + PlatonicAbstractT = class(ObjectWithMaterial3D,ISerializable) private function GetLength: real; procedure SetLengthP(r: real); public /// Длина грани property Length: real read GetLength write Invoke(SetLengthP, value); +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Length', Length, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Length := info.GetDouble('Length'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс IcosahedronT # Graph3D IcosahedronT class // ----------------------------------------------------- + [Serializable] /// Класс икосаэдра - IcosahedronT = class(PlatonicAbstractT) + IcosahedronT = class(PlatonicAbstractT,ISerializable) protected function CreateObject: Object3D; override := new IcosahedronT(X, Y, Z, Length, Material); public constructor(x, y, z, Length: real; m: GMaterial); /// Возвращает клон икосаэдра function Clone := (inherited Clone) as IcosahedronT; +///-- + function CreateModel: Visual3D; override; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс DodecahedronT # Graph3D DodecahedronT class // ----------------------------------------------------- + [Serializable] /// Класс додекаэдра - DodecahedronT = class(PlatonicAbstractT) + DodecahedronT = class(PlatonicAbstractT,ISerializable) protected function CreateObject: Object3D; override := new DodecahedronT(X, Y, Z, Length, Material); public constructor(x, y, z, Length: real; m: GMaterial); /// Возвращает клон додекаэдра function Clone := (inherited Clone) as DodecahedronT; +///-- + function CreateModel: Visual3D; override; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс TetrahedronT # Graph3D TetrahedronT class // ----------------------------------------------------- + [Serializable] /// Класс тетраэдра - TetrahedronT = class(PlatonicAbstractT) + TetrahedronT = class(PlatonicAbstractT,ISerializable) protected function CreateObject: Object3D; override := new TetrahedronT(X, Y, Z, Length, Material); public constructor(x, y, z, Length: real; m: GMaterial); /// Возвращает клон тетраэдра function Clone := (inherited Clone) as TetrahedronT; +///-- + function CreateModel: Visual3D; override; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс OctahedronT # Graph3D OctahedronT class // ----------------------------------------------------- + [Serializable] /// Класс октаэдра - OctahedronT = class(PlatonicAbstractT) + OctahedronT = class(PlatonicAbstractT,ISerializable) protected function CreateObject: Object3D; override := new OctahedronT(X, Y, Z, Length, Material); public constructor(x, y, z, Length: real; m: GMaterial); /// Возвращает клон октаэдра function Clone := (inherited Clone) as OctahedronT; +///-- + function CreateModel: Visual3D; override; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс TriangleT # Graph3D TriangleT class // ----------------------------------------------------- + [Serializable] /// Класс 3D-треугольника - TriangleT = class(ObjectWithMaterial3D) + TriangleT = class(ObjectWithMaterial3D,ISerializable) protected procedure SetP1(p: Point3D); function GetP1: Point3D; @@ -2191,13 +2773,38 @@ type property P3: Point3D read GetP3 write SetP3; /// Устанавливает точки 3D-треугольника procedure SetPoints(p1, p2, p3: Point3D); +///-- + function CreateModel: Visual3D; override; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('p1x', P1.X, typeof(real)); + info.AddValue('p1y', P1.Y, typeof(real)); + info.AddValue('p1z', P1.Z, typeof(real)); + info.AddValue('p2x', P2.X, typeof(real)); + info.AddValue('p2y', P2.Y, typeof(real)); + info.AddValue('p2z', P2.Z, typeof(real)); + info.AddValue('p3x', P3.X, typeof(real)); + info.AddValue('p3y', P3.Y, typeof(real)); + info.AddValue('p3z', P3.Z, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + SetPoints(P3D(info.GetDouble('p1x'),info.GetDouble('p1y'),info.GetDouble('p1z')), + P3D(info.GetDouble('p2x'),info.GetDouble('p2y'),info.GetDouble('p2z')), + P3D(info.GetDouble('p3x'),info.GetDouble('p3y'),info.GetDouble('p3z'))); + end; end; // ----------------------------------------------------- //>> Graph3D: класс PrismT # Graph3D PrismT class // ----------------------------------------------------- + [Serializable] /// Класс правильной призмы - PrismT = class(ObjectWithMaterial3D) + PrismT = class(ObjectWithMaterial3D,ISerializable) private procedure SetR(r: real); function GetR: real; @@ -2217,33 +2824,64 @@ type property Sides: integer read GetN write SetN; /// Возвращает клон правильной призмы function Clone := (inherited Clone) as PrismT; +///-- + function CreateModel: Visual3D; override; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Radius', Radius, typeof(real)); + info.AddValue('Height', Height, typeof(real)); + info.AddValue('Sides', Sides, typeof(integer)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Radius := info.GetDouble('Radius'); + Height := info.GetDouble('Height'); + Sides := info.GetInt32('Sides'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс PyramidT # Graph3D PyramidT class // ----------------------------------------------------- + [Serializable] /// Класс правильной пирамиды - PyramidT = class(PrismT) + PyramidT = class(PrismT,ISerializable) private protected function CreateObject: Object3D; override := new PyramidT(X, Y, Z, Sides, Radius, Height, Material.Clone); public constructor(x, y, z: real; N: integer; r, h: real; m: GMaterial); -/// Радиус правильной пирамиды +{/// Радиус правильной пирамиды property Radius: real read GetR write SetR; /// Высота правильной пирамиды property Height: real read GetH write SetH; /// Количество боковых граней правильной пирамиды - property Sides: integer read GetN write SetN; + property Sides: integer read GetN write SetN;} /// Возвращает клон правильной пирамиды function Clone := (inherited Clone) as PyramidT; + function CreateModel: Visual3D; override; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; // ----------------------------------------------------- //>> Graph3D: класс PrismTWireframe # Graph3D PrismTWireframe class // ----------------------------------------------------- + [Serializable] /// Класс проволочной правильной призмы - PrismTWireframe = class(ObjectWithChildren3D) + PrismTWireframe = class(ObjectWithChildren3D,ISerializable) private fn: integer; fh, fr: real; @@ -2344,13 +2982,36 @@ type property Color: GColor read GetC write SetC; override; /// Толщина проволоки правильной призмы property Thickness: real read GetT write SetT; +///-- + function CreateModel: Visual3D; override := NewVisualObject(1,0,0,0,Colors.Transparent); +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Radius', Radius, typeof(real)); + info.AddValue('Height', Height, typeof(real)); + info.AddValue('Sides', Sides, typeof(integer)); + info.AddValue('Color', ColorToLongword(Color), typeof(longword)); + info.AddValue('Thickness', Thickness, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Radius := info.GetDouble('Radius'); + Height := info.GetDouble('Height'); + Sides := info.GetInt32('Sides'); + Color := LongwordToColor(info.GetUInt32('Color')); + Thickness := info.GetDouble('Thickness'); + end; end; // ----------------------------------------------------- //>> Graph3D: класс PyramidTWireframe # Graph3D PyramidTWireframe class // ----------------------------------------------------- + [Serializable] /// Класс проволочной правильной пирамиды - PyramidTWireframe = class(PrismTWireframe) + PyramidTWireframe = class(PrismTWireframe,ISerializable) protected function CreateObject: Object3D; override := new PyramidTWireframe(X, Y, Z, Sides, Radius, Height, (model as LinesVisual3D).Thickness, (model as LinesVisual3D).Color); private @@ -2383,6 +3044,21 @@ type property Color: GColor read GetC write SetC; override; /// Толщина проволоки правильной пирамиды property Thickness: real read GetT write SetT; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + end; + + constructor(x, y, z: real; N: integer; Radius, Height: real; Thickness: real; c: GColor); + begin + inherited Create(x, y, z, N, Radius, Height, Thickness, c); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + end; end; P3DArray = array of Point3D; @@ -2391,8 +3067,9 @@ type // ----------------------------------------------------- //>> Graph3D: класс SegmentsT # Graph3D SegmentsT class // ----------------------------------------------------- + [Serializable] /// Класс Набор 3D-отрезков - SegmentsT = class(ObjectWithChildren3D) + SegmentsT = class(ObjectWithChildren3D,ISerializable) private function Model := inherited model as LinesVisual3D; function GetTP: real := Model.Thickness; @@ -2425,13 +3102,47 @@ type property Points: array of Point3D read GetP write SetP; /// Возвращает клон 3D-отрезков function Clone := (inherited Clone) as SegmentsT; +///-- + function CreateModel: Visual3D; override := new LinesVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Thickness', Thickness, typeof(real)); + info.AddValue('Color', ColorToLongword(Color), typeof(longword)); + info.AddValue('PointsCount', Points.Count, typeof(integer)); + for var i:=0 to Points.Length-1 do + begin + info.AddValue('px'+i, Points[i].X, typeof(real)); + info.AddValue('py'+i, Points[i].Y, typeof(real)); + info.AddValue('pz'+i, Points[i].Z, typeof(real)); + end; + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Thickness := info.GetDouble('Thickness'); + Color := LongwordToColor(info.GetUInt32('Color')); + var count := info.GetInt32('PointsCount'); + var ll := new List; + for var i:=0 to count-1 do + begin + var x := info.GetDouble('px'+i); + var y := info.GetDouble('py'+i); + var z := info.GetDouble('pz'+i); + ll.Add(P3D(x,y,z)); + end; + Points := ll.ToArray; + end; end; // ----------------------------------------------------- //>> Graph3D: класс TorusT # Graph3D TorusT class // ----------------------------------------------------- + [Serializable] /// Класс Тор (бублик) - TorusT = class(ObjectWithMaterial3D) + TorusT = class(ObjectWithMaterial3D,ISerializable) private procedure SetD(d: real) := Invoke(procedure(d: real)->(model as TorusVisual3D).TorusDiameter := d, d); function GetD: real := InvokeReal(()->(model as TorusVisual3D).TorusDiameter); @@ -2454,6 +3165,22 @@ type property TubeDiameter: real read GetTD write SetTD; /// Возвращает клон тора function Clone := (inherited Clone) as PrismT; + + function CreateModel: Visual3D; override := new TorusVisual3D; +///-- + procedure GetObjectData(info: SerializationInfo; context: StreamingContext); + begin + inherited GetObjectData(info,context); + info.AddValue('Diameter', Diameter, typeof(real)); + info.AddValue('TubeDiameter', TubeDiameter, typeof(real)); + end; +///-- + constructor Create(info: SerializationInfo; context: StreamingContext); + begin + inherited Create(info,context); + Diameter := info.GetDouble('Diameter'); + TubeDiameter := info.GetDouble('TubeDiameter'); + end; end; @@ -2665,6 +3392,12 @@ procedure BeginFrameBasedAnimationTime(Draw: procedure(dt: real)); /// Заканчивает анимацию, основанную на кадре procedure EndFrameBasedAnimation; +/// Сериализует трёхмерный объект в файл +procedure SerializeObject3D(filename: string; obj: Object3D); + +/// Десериализует трёхмерный объект из файла +function DeserializeObject3D(filename: string): Object3D; + var // ----------------------------------------------------- //>> События модуля Graph3D # Graph3D events @@ -2737,7 +3470,77 @@ procedure __FinalizeModule__; implementation -procedure Redraw(p: ()->()) := GraphWPFBase.Invoke(p); +type + CustomBinder = class(SerializationBinder) + public function BindToType(assemblyName, typeName: string): System.Type; override; + begin + var currentasm := System.Reflection.Assembly.GetExecutingAssembly(); + var s := typeName + ', ' +currentasm.ToString(); + Result := System.Type.GetType(s); // игнорировать assemblyname!!! + end; + end; + +procedure SerializeObject3D(filename: string; obj: Object3D); +begin + Invoke(procedure -> begin + var fs := new System.IO.FileStream(filename,System.IO.FileMode.Create); + var formatter := new System.Runtime.Serialization.Formatters.Binary.BinaryFormatter; + formatter.Serialize(fs,obj); + fs.Close; + end); +end; + +var magiccounter := 1; + +function DeserializeObject3D(filename: string): Object3D; +begin + if magiccounter = 0 then // никогда не выполнится + begin + var a := typeof(Object3D); + a := typeof(ObjectWithChildren3D); + a := typeof(ObjectWithMaterial3D); + a := typeof(Group3D); + a := typeof(SphereT); + a := typeof(EllipsoidT); + a := typeof(CubeT); + a := typeof(BoxT); + a := typeof(ArrowT); + a := typeof(TruncatedConeT); + a := typeof(CylinderT); + a := typeof(TeapotT); + a := typeof(CoordinateSystemT); + a := typeof(BillboardTextT); + a := typeof(TextT); + a := typeof(RectangleT); + a := typeof(FileModelT); + a := typeof(PipeT); + a := typeof(LegoT); + a := typeof(PlatonicAbstractT); + a := typeof(IcosahedronT); + a := typeof(DodecahedronT); + a := typeof(TetrahedronT); + a := typeof(OctahedronT); + a := typeof(TriangleT); + a := typeof(PrismT); + a := typeof(PyramidT); + a := typeof(PrismTWireframe); + a := typeof(PyramidTWireframe); + a := typeof(SegmentsT); + a := typeof(TorusT); + end; + var res: Object3D; + Invoke(procedure -> begin + var fs := new System.IO.FileStream(filename,System.IO.FileMode.Open); + var formatter := new System.Runtime.Serialization.Formatters.Binary.BinaryFormatter; + formatter.Binder := new CustomBinder(); + res := formatter.Deserialize(fs) as Object3D; + fs.Close; + end); + Result := res; +end; + +procedure Redraw(p: procedure) := GraphWPFBase.Invoke(p); +procedure Invoke(p: procedure) := GraphWPFBase.Invoke(p); function RGB(r, g, b: byte) := Color.Fromrgb(r, g, b); function ARGB(a, r, g, b: byte) := Color.FromArgb(a, r, g, b); @@ -2791,11 +3594,15 @@ function RainbowMaterial: Material := GMaterials.Rainbow; //function hplus: real := SystemParameters.WindowCaptionHeight + SystemParameters.WindowResizeBorderThickness.Top + SystemParameters.WindowResizeBorderThickness.Bottom; +procedure Object3D.Serialize(fname: string) := SerializeObject3D(fname,Self); + +static function Object3D.DeSerialize(fname: string): Object3D := DeserializeObject3D(fname) as Object3D; + function Object3D.AnimMoveTo(x, y, z, seconds: real; Completed: procedure) := new OffsetAnimation(Self, seconds, x, y, z, Completed); function Object3D.AnimMoveTrajectory(trajectory: sequence of Point3D; seconds: real; Completed: procedure) := new OffsetAnimationUsingKeyframes(Self, seconds, trajectory, Completed); -function Object3D.AnimMoveOn(dx, dy, dz, seconds: real; Completed: procedure) := new OffsetAnimationOn(Self, seconds, dx, dy, dz, Completed); +function Object3D.AnimMoveBy(dx, dy, dz, seconds: real; Completed: procedure) := new OffsetAnimationOn(Self, seconds, dx, dy, dz, Completed); function Object3D.AnimScale(sc, seconds: real; Completed: procedure) := new ScaleAnimation(Self, seconds, sc, Completed); @@ -2914,6 +3721,9 @@ begin CreateBase(bx, x, y, z, m); end; +function LegoT.CreateModel: Visual3D := new LegoVisual3D; + + procedure LegoT.SetWP(r: integer) := (model as LegoVisual3D).Rows := r; procedure LegoT.SetW(r: integer) := Invoke(SetWP, r); function LegoT.GetW: integer := InvokeInteger(()->(model as LegoVisual3D).Rows); @@ -3115,12 +3925,16 @@ function PlatonicAbstractT.GetLength: real := InvokeReal(()->(model as PlatonicA procedure PlatonicAbstractT.SetLengthP(r: real) := (model as PlatonicAbstractVisual3D).Length := r; constructor IcosahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new IcosahedronVisual3D(Length), x, y, z, m); +function IcosahedronT.CreateModel: Visual3D := new IcosahedronVisual3D; constructor DodecahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new DodecahedronVisual3D(Length), x, y, z, m); +function DodecahedronT.CreateModel: Visual3D := new DodecahedronVisual3D; constructor TetrahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new TetrahedronVisual3D(Length), x, y, z, m); +function TetrahedronT.CreateModel: Visual3D := new TetrahedronVisual3D; constructor OctahedronT.Create(x, y, z, Length: real; m: GMaterial) := CreateBase(new OctahedronVisual3D(Length), x, y, z, m); +function OctahedronT.CreateModel: Visual3D := new OctahedronVisual3D; type @@ -3128,13 +3942,17 @@ type private fn: integer; fh, fr: real; - procedure SetR(value: real);begin fr := value; OnGeometryChanged; end; + procedure SetR(value: real); begin fr := value; OnGeometryChanged; end; - procedure SetH(value: real);begin fh := value; OnGeometryChanged; end; + procedure SetH(value: real); begin fh := value; OnGeometryChanged; end; - procedure SetN(value: integer);begin fn := value; OnGeometryChanged; end; + procedure SetN(value: integer); begin fn := value; OnGeometryChanged; end; public + constructor; + begin + end; + constructor(N: integer; Radius, Height: real); begin (fn, fr, fh) := (n, Radius, Height); @@ -3235,6 +4053,7 @@ function TriangleT.GetP2: Point3D := Invoke&(()->(model as TriangleVis procedure TriangleT.SetP3(p: Point3D) := Invoke(procedure(p: Point3D)->(model as TriangleVisual3D).P3 := p, p); function TriangleT.GetP3: Point3D := Invoke&(()->(model as TriangleVisual3D).P3); procedure TriangleT.SetPoints(p1, p2, p3: Point3D) := Invoke(procedure(p1, p2, p3: Point3D)->begin (model as TriangleVisual3D).SetPoints(p1, p2, p3); end, p1, p2, p3); +function TriangleT.CreateModel: Visual3D := new TriangleVisual3D; function TriangleT.CreateObject: Object3D := new TriangleT((model as TriangleVisual3D).p1, (model as TriangleVisual3D).p2, (model as TriangleVisual3D).p3, Material.Clone); @@ -3252,9 +4071,10 @@ procedure PrismT.SetN(n: integer) := Invoke(procedure(n: integer)->(model as Pri function PrismT.GetN: integer := InvokeInteger(()->(model as PrismVisual3D).N); constructor PrismT.Create(x, y, z: real; N: integer; r, h: real; m: Gmaterial) := CreateBase(new PrismVisual3D(N, r, h), x, y, z, m); +function PrismT.CreateModel: Visual3D := new PrismVisual3D; constructor PyramidT.Create(x, y, z: real; N: integer; r, h: real; m: GMaterial) := CreateBase(new PyramidVisual3D(N, r, h), x, y, z, m); - +function PyramidT.CreateModel: Visual3D := new PyramidVisual3D; diff --git a/TreeConverter/TreeConversion/compilation_context.cs b/TreeConverter/TreeConversion/compilation_context.cs index 40f6690b1..8fbfc57ca 100644 --- a/TreeConverter/TreeConversion/compilation_context.cs +++ b/TreeConverter/TreeConversion/compilation_context.cs @@ -858,9 +858,10 @@ namespace PascalABCCompiler.TreeConverter } //Нахождение узла по имени либо точечному имени (напр. Unit1.type1) - public List find_definition_node(SyntaxTree.named_type_reference names, location loc) // SSM перебросил сюда из syntax_tree_visitor 3.04.14 + public List find_definition_node(SyntaxTree.named_type_reference names, location loc, bool throw_error = false) // SSM перебросил сюда из syntax_tree_visitor 3.04.14 { definition_node di = null; + List si = null; if (names.names.Count > 1) { di = convert_names_to_namespace(names, loc); @@ -870,18 +871,28 @@ namespace PascalABCCompiler.TreeConverter int num = names.names.Count - 1; if (di is namespace_node) { - return (di as namespace_node).find(names.names[num].name); + si = (di as namespace_node).find(names.names[num].name); + if (si == null && throw_error) + AddError(new UndefinedNameReference(names.names[num].name, syntax_tree_visitor.get_location(names.names[num]))); } else if (di is type_node) { - return (di as type_node).find_in_type(names.names[num].name); + si = (di as type_node).find_in_type(names.names[num].name); + if (si == null && throw_error) + AddError(new UndefinedNameReference(names.names[num].name, syntax_tree_visitor.get_location(names.names[num]))); } else { - return (di as unit_node).find_only_in_namespace(names.names[num].name); + si = (di as unit_node).find_only_in_namespace(names.names[num].name); + if (si == null && throw_error) + AddError(new UndefinedNameReference(names.names[num].name, syntax_tree_visitor.get_location(names.names[num]))); } + return si; } - return find(names.names[0].name); + si = find(names.names[0].name); + if (si == null && throw_error) + AddError(new UndefinedNameReference(names.names[0].name, syntax_tree_visitor.get_location(names.names[0]))); + return si; } //\ssyy @@ -2263,7 +2274,6 @@ namespace PascalABCCompiler.TreeConverter { return _ctn.base_generic_instance.ConvertSymbolInfo(sil); } - return sil; } @@ -3524,7 +3534,7 @@ namespace PascalABCCompiler.TreeConverter } } - public common_property_node add_property(string property_name,location loc) + public common_property_node add_property(string property_name, location loc) { if (_ctn==null) { @@ -3742,6 +3752,40 @@ namespace PascalABCCompiler.TreeConverter return fn; } + public property_node FindPropertyToImplement(common_property_node cpn, string pure_name, type_node interf) + { + List sil = interf.find_in_type(pure_name, CurrentScope); + property_node pn = null; + SymbolInfo find_property = null; + if (sil != null) + { + foreach (SymbolInfo si in sil) + { + if (si.sym_info.general_node_type != general_node_type.property_node) + { + return null; + } + pn = si.sym_info as property_node; + //(ssyy) Сверяем как параметры функций, так и типы возвращаемых значений + if (cpn.get_function == null && pn.get_function == null && pn.property_type == cpn.property_type) + { + find_property = si; + break; + } + else if (cpn.get_function != null && pn.get_function != null && convertion_data_and_alghoritms.function_eq_params_and_result(cpn.get_function, pn.get_function)) + { + find_property = si; + break; + } + } + } + if (find_property == null) + { + return null; + } + return pn; + } + public property_node FindPropertyToOverride(common_property_node cpn) { type_node base_class = cpn.common_comprehensive_type.base_type; @@ -3816,7 +3860,7 @@ namespace PascalABCCompiler.TreeConverter { (cpn.get_function as common_method_node).overrided_method = overrided_property.get_function; (cpn.get_function as common_method_node).polymorphic_state = SemanticTree.polymorphic_state.ps_virtual; - } + } if (cpn.set_function is common_method_node) { (cpn.set_function as common_method_node).overrided_method = overrided_property.set_function; @@ -3825,6 +3869,28 @@ namespace PascalABCCompiler.TreeConverter } } + public void set_implement(common_property_node cpn, string pure_name, type_node interf) + { + property_node overrided_property = FindPropertyToImplement(cpn, pure_name, interf); + if (overrided_property == null) + AddError(cpn.loc, "NO_PROPERTY_TO_OVERRIDE"); + else + { + if (cpn.get_function is common_method_node) + { + (cpn.get_function as common_method_node).overrided_method = overrided_property.get_function; + (cpn.get_function as common_method_node).is_final = true; + (cpn.get_function as common_method_node).newslot_awaited = true; + } + if (cpn.set_function is common_method_node) + { + (cpn.set_function as common_method_node).overrided_method = overrided_property.set_function; + (cpn.set_function as common_method_node).is_final = true; + (cpn.set_function as common_method_node).newslot_awaited = true; + } + } + } + public void set_override(common_method_node cmn) { cmn.polymorphic_state = SemanticTree.polymorphic_state.ps_virtual; diff --git a/TreeConverter/TreeConversion/syntax_tree_visitor.cs b/TreeConverter/TreeConversion/syntax_tree_visitor.cs index 7c75fbd2d..6766e3839 100644 --- a/TreeConverter/TreeConversion/syntax_tree_visitor.cs +++ b/TreeConverter/TreeConversion/syntax_tree_visitor.cs @@ -4257,9 +4257,29 @@ namespace PascalABCCompiler.TreeConverter AddError(get_location(_simple_property), "PROPERTYACCESSOR_{0}_OR_{1}_EXPECTED", compiler_string_consts.PascalReadAccessorName, compiler_string_consts.PascalWriteAccessorName); if (_simple_property.property_type == null) AddError(get_location(_simple_property.property_name), "TYPE_NAME_EXPECTED"); - - common_property_node pn = context.add_property(_simple_property.property_name.name, - get_location(_simple_property.property_name)); + string name = _simple_property.property_name.name; + type_node expl_interface = null; + if (_simple_property.property_name.ln != null) + { + for (var i = 0; i < _simple_property.property_name.ln.Count - 1; i++) + if (_simple_property.property_name.ln[i] is SyntaxTree.template_type_name) + AddError(new NameCannotHaveGenericParameters(_simple_property.property_name.ln[i].name, get_location(_simple_property.property_name.ln[i]))); + + var ntr = new SyntaxTree.named_type_reference(); + for (var i = 0; i < _simple_property.property_name.ln.Count; i++) + { + ntr.Add(new ident(_simple_property.property_name.ln[i].name+ + (_simple_property.property_name.ln[i] is template_type_name ? "`"+(_simple_property.property_name.ln[i] as template_type_name).template_args.Count :""), _simple_property.property_name.ln[i].source_context)); + + } + + List sil = context.find_definition_node(ntr, get_location(_simple_property.property_name), true); + if (!(sil[0].sym_info as type_node).IsInterface) + AddError(get_location(_simple_property.property_name), "INTERFACE_AWAITED"); + name = (sil[0].sym_info as type_node).BaseFullName + "." + name; + expl_interface = sil[0].sym_info as type_node; + } + common_property_node pn = context.add_property(name, get_location(_simple_property.property_name)); assign_doc_info(pn, _simple_property); //pn.polymorphic_state=SemanticTree.polymorphic_state.ps_common; //pn.loc=get_location(_simple_property.property_name); @@ -4605,6 +4625,11 @@ namespace PascalABCCompiler.TreeConverter make_attributes_for_declaration(_simple_property,pn); if (_simple_property.virt_over_none_attr == proc_attribute.attr_override) context.set_override(pn); + else if (expl_interface != null) + { + context.set_implement(pn, _simple_property.property_name.name, expl_interface); + } + //TODO: Можно сделать множество свойств по умолчанию. if (_simple_property.array_default != null) { @@ -4622,8 +4647,14 @@ namespace PascalABCCompiler.TreeConverter private function_node GenerateGetMethod(common_property_node cpn, common_method_node accessor, location loc) { + string getter_name = "get_" + cpn.name; + if (cpn.name.IndexOf('.') != -1) + { + string[] names = cpn.name.Split('.'); + getter_name = names.Take(names.Length - 1).ToArray().JoinIntoString(".") + "get_" + names[names.Length - 1]; + } common_method_node cmn = new common_method_node( - "get_"+cpn.name, loc, cpn.common_comprehensive_type, + getter_name, loc, cpn.common_comprehensive_type, cpn.polymorphic_state, cpn.field_access_level, null); cpn.common_comprehensive_type.methods.AddElement(cmn); cmn.return_value_type = cpn.property_type; @@ -4651,14 +4682,20 @@ namespace PascalABCCompiler.TreeConverter } } cmn.function_code = new return_node(meth_call, loc); - cpn.common_comprehensive_type.scope.AddSymbol("get_" + cpn.name, new SymbolInfo(cmn)); + cpn.common_comprehensive_type.scope.AddSymbol(getter_name, new SymbolInfo(cmn)); return cmn; } private function_node GenerateSetMethod(common_property_node cpn, common_method_node accessor, location loc) { + string setter_name = "set_" + cpn.name; + if (cpn.name.IndexOf('.') != -1) + { + string[] names = cpn.name.Split('.'); + setter_name = names.Take(names.Length - 1).ToArray().JoinIntoString(".") + "set_" + names[names.Length - 1]; + } common_method_node cmn = new common_method_node( - "set_" + cpn.name, loc, cpn.common_comprehensive_type, + setter_name, loc, cpn.common_comprehensive_type, cpn.polymorphic_state, cpn.field_access_level, null); cpn.common_comprehensive_type.methods.AddElement(cmn); //cmn.return_value_type = cpn.property_type; @@ -4686,7 +4723,7 @@ namespace PascalABCCompiler.TreeConverter } } cmn.function_code = meth_call; - cpn.common_comprehensive_type.scope.AddSymbol("set_" + cpn.name, new SymbolInfo(cmn)); + cpn.common_comprehensive_type.scope.AddSymbol(setter_name, new SymbolInfo(cmn)); return cmn; } diff --git a/TreeConverter/TreeRealization/propertyes.cs b/TreeConverter/TreeRealization/propertyes.cs index 1bfa8ba1c..c281bfde8 100644 --- a/TreeConverter/TreeRealization/propertyes.cs +++ b/TreeConverter/TreeRealization/propertyes.cs @@ -204,7 +204,9 @@ namespace PascalABCCompiler.TreeRealization /// private location _loc; - public common_property_node(string name, common_type_node comprehensive_type, location loc, + private type_node _explicit_interface; + + public common_property_node(string name, common_type_node comprehensive_type, location loc, SemanticTree.field_access_level field_access_level, SemanticTree.polymorphic_state polymorphic_state) { _name = name; @@ -318,7 +320,19 @@ namespace PascalABCCompiler.TreeRealization } } - public function_node internal_get_function + public type_node explicit_interface + { + get + { + return _explicit_interface; + } + set + { + _explicit_interface = value; + } + } + + public function_node internal_get_function { get { diff --git a/bin/Lng/Eng/SemanticErrors_ib.dat b/bin/Lng/Eng/SemanticErrors_ib.dat index cc496f4a2..daffab3c0 100644 --- a/bin/Lng/Eng/SemanticErrors_ib.dat +++ b/bin/Lng/Eng/SemanticErrors_ib.dat @@ -169,6 +169,7 @@ PARTIAL_CLASS_PARENTS_MISMATCH=Partial declarations must not specify different b PARAMETER_{0}_HAS_TYPE_{1}_FROM_UNIT_{2}=Parameter {0} has type {1} from unit {2}. Add unit {2} to uses section. PARTIAL_CLASS_PREDEFINITION_NOT_ALLOWED=Predefinitions of partial classes are not allowed AMBIGUOUS_DELEGATES=Ambiguous delegates detected +INTERFACE_AWAITED=Interface expected %PREFIX%=COMPILATIONERROR_ UNIT_MODULE_EXPECTED_LIBRARY_FOUND=Unit expected, library found ASSEMBLY_{0}_READING_ERROR=Error by reading assembly '{0}' diff --git a/bin/Lng/Rus/SemanticErrors_ib.dat b/bin/Lng/Rus/SemanticErrors_ib.dat index 6c6126a37..b5e13848a 100644 --- a/bin/Lng/Rus/SemanticErrors_ib.dat +++ b/bin/Lng/Rus/SemanticErrors_ib.dat @@ -164,6 +164,7 @@ PARTIAL_CLASS_PARENTS_MISMATCH=partial-класс не может иметь и PARAMETER_{0}_HAS_TYPE_{1}_FROM_UNIT_{2}=Параметр {0} имеет тип {1} из неподключенного модуля {2}. Добавьте модуль {2} в секцию uses. PARTIAL_CLASS_PREDEFINITION_NOT_ALLOWED=Предописания partial-классов недопустимы AMBIGUOUS_DELEGATES=Невозможно выбрать конкретный делегат из перегруженных +INTERFACE_AWAITED=Ожидалось имя интерфейса %PREFIX%=COMPILATIONERROR_ UNIT_MODULE_EXPECTED_LIBRARY_FOUND=Ожидался модуль, а встречена библиотека ASSEMBLY_{0}_READING_ERROR=Ошибка при чтении сборки '{0}' diff --git a/bin/Lng/Ukr/SemanticErrors_ib.dat b/bin/Lng/Ukr/SemanticErrors_ib.dat index ab476e2da..358d0974c 100644 --- a/bin/Lng/Ukr/SemanticErrors_ib.dat +++ b/bin/Lng/Ukr/SemanticErrors_ib.dat @@ -161,6 +161,7 @@ PARTIAL_CLASS_PARENTS_MISMATCH=partial-класс не может иметь и PARAMETER_{0}_HAS_TYPE_{1}_FROM_UNIT_{2}=Параметр {0} имеет тип {1} из неподключенного модуля {2}. Добавьте модуль {2} в секцию uses. PARTIAL_CLASS_PREDEFINITION_NOT_ALLOWED=Предописания partial-классов недопустимы# AMBIGUOUS_DELEGATES=Невозможно выбрать конкретный делегат из перегруженных +INTERFACE_AWAITED=Ожидалось имя интерфейса %PREFIX%=COMPILATIONERROR_ UNIT_MODULE_EXPECTED_LIBRARY_FOUND=Очікувався модуль, а зустріли бібліотеку ASSEMBLY_{0}_READING_ERROR=Помилка при читанні збірки '{0}'