如何并行执行创建大量对象的函数？

Question

我在函数上使用Array.Parallel.map但发现它没有在接近完整处理器容量的任何地方执行。我假设这是因为该函数在运行List.map和List.map2时会创建大量对象。这是否会导致同步问题，是否有更合适的方法？目前，我能想到解决这个问题的唯一方法是在Linux下使用xargs之类的东西将每个进程作为单独的可执行文件运行。

我把下面的脚本放在一起来演示问题。它是一个非常基本的数据分类程序，它依赖于具有特定值的字段作为规则来确定它是否会预测某个类别：

open System

type CategoryAssessment =
    { fieldIndex: int
      value: int
      ruleAssessments: list<int> }

let InitAssessment categorizeFields rules =
    let ruleAssessments = List.init (List.length rules) (fun x -> 0)
    List.map (fun categorizeField ->
                 let fieldIndex, categoryValue = categorizeField
                 { CategoryAssessment.fieldIndex = fieldIndex;
                   value = categoryValue;
                   ruleAssessments = ruleAssessments })
              categorizeFields

let AssessCategory ruleMatches (row : int[]) categoryAssessment =
    let fieldIndex = categoryAssessment.fieldIndex
    let categoryValue = categoryAssessment.value
    let categoryMatch = categoryValue = row.[fieldIndex]
    let newRuleAssessments =
        List.map2 (fun ruleAssessment ruleMatch ->
                       if ruleMatch = categoryMatch then
                           ruleAssessment + 1
                       else
                           ruleAssessment)
                  categoryAssessment.ruleAssessments
                  ruleMatches
    { categoryAssessment with ruleAssessments = newRuleAssessments }

let MatchRule (row : int[]) rule =
    let fieldIndex, eqVal = rule
    row.[fieldIndex] = eqVal

let Assess categorizeFields rules input =
  printfn "START - Assess"
  let d = 
    Array.fold (fun categoryAssessment row ->
                 let ruleMatches = List.map (MatchRule row) rules
                 List.map (AssessCategory ruleMatches row) categoryAssessment)
             (InitAssessment categorizeFields rules)
             input
  printfn "END - Assess"
  d

let JoinAssessments assessments =
    let numAssessments = Array.length assessments
    Array.fold (fun accAssessment assessment ->
                    List.map2 (fun accCategory category ->
                                   let newRuleAssessments =
                                       List.map2 (+)
                                                 accCategory.ruleAssessments
                                                 category.ruleAssessments
                                   { accCategory with
                                         ruleAssessments = newRuleAssessments })
                              accAssessment
                              assessment)
               assessments.[0]
               assessments.[1..(numAssessments-1)]


let numRecords = 10000
let numFields = 20
let numSplits = 10
let numRules = 10000
let inputs = Array.create numSplits
                          [| for i in 1 .. (numRecords / numSplits) ->
                                [| for j in 1 .. numFields ->
                                       (i % 10) + j |] |]
let categorizeFields = [ (1, 6); (2, 3); (2, 4); (3, 2) ]
let rules = [ for i in 1 .. numRules -> (i % numFields, i) ]
let assessments =
    Array.Parallel.map (Assess categorizeFields rules) inputs
    |> JoinAssessments
printfn "Assessments: %A" assessments
0

Answer 1

经过一番调查后，我的问题的最终答案似乎是找到一种不创造大量物品的方法。执行此操作的最简单的更改是使用数组而不是列表。我在一篇文章Beware of Immutable Lists for F# Parallel Processing中更全面地写了我的发现。

上面的程序改变如下，在线程之间运行得更好，即使在单个线程上也运行得更快。如参考文章中所示，可以通过使ruleAssessments字段可变进行进一步的改进。

open System

type CategoryAssessment =
    { fieldIndex: int
      value: int
      ruleAssessments: int[] }

let InitAssessment categorizeFields rules =
    let ruleAssessments = Array.create (Array.length rules) 0
    Array.map (fun categorizeField ->
                   let fieldIndex, categoryValue = categorizeField
                   { CategoryAssessment.fieldIndex = fieldIndex;
                     value = categoryValue;
                     ruleAssessments = ruleAssessments })
              categorizeFields

let AssessCategory ruleMatches (row : int[]) categoryAssessment =
    let fieldIndex = categoryAssessment.fieldIndex
    let categoryValue = categoryAssessment.value
    let categoryMatch = categoryValue = row.[fieldIndex]
    let newRuleAssessments =
        Array.map2 (fun ruleAssessment ruleMatch ->
                        if ruleMatch = categoryMatch then
                            ruleAssessment + 1
                        else
                            ruleAssessment)
                   categoryAssessment.ruleAssessments
                   ruleMatches
    { categoryAssessment with ruleAssessments = newRuleAssessments }

let MatchRule (row : int[]) rule =
    let fieldIndex, eqVal = rule
    row.[fieldIndex] = eqVal

let Assess categorizeFields rules input =
  printfn "START - Assess"
  let d =
    Array.fold (fun categoryAssessment row ->
                 let ruleMatches = Array.map (MatchRule row) rules
                 Array.map (AssessCategory ruleMatches row) categoryAssessment)
               (InitAssessment categorizeFields rules)
               input
  printfn "END - Assess"
  d

let JoinAssessments assessments =
    let numAssessments = Array.length assessments
    Array.fold (fun accAssessment assessment ->
                    Array.map2 (fun accCategory category ->
                                    let newRuleAssessments =
                                        Array.map2 (+)
                                                   accCategory.ruleAssessments
                                                   category.ruleAssessments
                                    { accCategory with
                                          ruleAssessments = newRuleAssessments })
                               accAssessment
                               assessment)
               assessments.[0]
               assessments.[1..(numAssessments-1)]


let numRecords = 10000
let numFields = 20
let numSplits = 10
let numRules = 10000
let inputs = Array.create numSplits
                          [| for i in 1 .. (numRecords / numSplits) ->
                                [| for j in 1 .. numFields ->
                                       (i % 10) + j |] |]
let categorizeFields = [| (1, 6); (2, 3); (2, 4); (3, 2) |]
let rules = [| for i in 1 .. numRules -> (i % numFields, i) |]

let assessments =
    Array.Parallel.map (Assess categorizeFields rules) inputs
    |> JoinAssessments
printfn "Assessments: %A" assessments
0

Answer 2

这是您的程序版本，不需要可变性，并且几乎可以使用iMac上的所有4个cpu。

为了实现这一目标，它是通过并行评估每个规则而不是通过处理记录来推动的。这也需要转换输入数组，使其成为记录字段。

open System

type CategoryAssessment =
    { fieldIndex: int
      value: int
      ruleAssessments: list<int> }

let MatchRule rVal fVal  =
        rVal = fVal

let AssessRule cMatches (inputs:int[][]) (rIndex, rVal) =
//    printfn "START - Assess"  // uses more cpu than the code itself
    let matches = inputs.[rIndex] |> 
                  Array.map2 (fun cVal fVal -> (MatchRule rVal fVal) = cVal) cMatches
    let assessment = matches |> 
                     Array.map ( fun v -> if v then 1 else 0  ) |> 
                     Array.sum
//    printfn "END - Assess"
    assessment

let Assess categorizeFields rules (inputs:int[][]) =
    categorizeFields |> List.map (fun (catIndex, catValue) ->
        let catMatches = inputs.[catIndex] |> Array.map( fun v -> v = catValue )
        let assessments = rules |> Array.Parallel.map 
                                    (AssessRule catMatches inputs) 
                                 |> Array.toList
        { CategoryAssessment.fieldIndex = catIndex; 
          value = catValue; 
          ruleAssessments = assessments }  
    )

let numRecords = 10000
let numFields = 20
let numRules = 10000
let inputs = [| for j in 1 .. numFields ->
                [| for i in 1 .. numRecords -> (i % 10) + j |] |]
let categorizeFields = [ (1, 6); (2, 3); (2, 4); (3, 2) ]
let rules = [| for i in 1 .. numRules -> (i % numFields, i) |]
let assessments = Assess categorizeFields rules inputs
printfn "Assessments: %A" assessments

按规则进行评估允许对给定规则的所有记录求和一个整数，避免可变状态和额外内存分配。

我使用了大量的数组迭代来提高速度，但没有删除所有列表。

我担心我在重构时会改变功能或做出无法应用于实际问题的假设，但我希望这是一个有用的例子。