如何使这个 F# 函数不会导致堆栈溢出

Question

我在 F# 中编写了一个有趣的函数，它可以遍历和映射任何数据结构（很像 Haskell 的 Scrap Your Boilerplate 中提供的无处不在的函数）。不幸的是，即使是相当小的数据结构，它也会很快导致堆栈溢出。我想知道如何将它转换为尾递归版本、延续传递样式版本或命令式等效算法。我相信 F# 支持 monad，所以 continuation monad 是一种选择。

// These are used for a 50% speedup
let mutable tupleReaders : List<System.Type * (obj -> obj[])> = []
let mutable unionTagReaders : List<System.Type * (obj -> int)> = []
let mutable unionReaders : List<(System.Type * int) * (obj -> obj[])> = []
let mutable unionCaseInfos : List<System.Type * Microsoft.FSharp.Reflection.UnionCaseInfo[]> = []
let mutable recordReaders : List<System.Type * (obj -> obj[])> = []

(*
    Traverses any data structure in a preorder traversal
    Calls f, g, h, i, j which determine the mapping of the current node being considered

    WARNING: Not able to handle option types
    At runtime, option None values are represented as null and so you cannot determine their runtime type.

    See http://stackoverflow.com/questions/21855356/dynamically-determine-type-of-option-when-it-has-value-none
    http://stackoverflow.com/questions/13366647/how-to-generalize-f-option
*)
open Microsoft.FSharp.Reflection
let map5<'a,'b,'c,'d,'e,'z> (f:'a->'a) (g:'b->'b) (h:'c->'c) (i:'d->'d) (j:'e->'e) (src:'z) =
    let ft = typeof<'a>
    let gt = typeof<'b>
    let ht = typeof<'c>
    let it = typeof<'d>
    let jt = typeof<'e>

    let rec drill (o:obj) : obj =
        if o = null then
            o
        else
            let ot = o.GetType()
            if FSharpType.IsUnion(ot) then
                let tag = match List.tryFind (fst >> ot.Equals) unionTagReaders with
                              | Some (_, reader) ->
                                   reader o
                              | None ->
                                   let newReader = FSharpValue.PreComputeUnionTagReader(ot)
                                   unionTagReaders <- (ot, newReader)::unionTagReaders
                                   newReader o
                let info = match List.tryFind (fst >> ot.Equals) unionCaseInfos with
                               | Some (_, caseInfos) ->
                                   Array.get caseInfos tag
                               | None ->
                                   let newCaseInfos = FSharpType.GetUnionCases(ot)
                                   unionCaseInfos <- (ot, newCaseInfos)::unionCaseInfos
                                   Array.get newCaseInfos tag
                let vals = match List.tryFind (fun ((tau, tag'), _) -> ot.Equals tau && tag = tag') unionReaders with
                               | Some (_, reader) ->
                                   reader o
                               | None ->
                                   let newReader = FSharpValue.PreComputeUnionReader info
                                   unionReaders <- ((ot, tag), newReader)::unionReaders
                                   newReader o
                FSharpValue.MakeUnion(info, Array.map traverse vals)
            elif FSharpType.IsTuple(ot) then
                let fields = match List.tryFind (fst >> ot.Equals) tupleReaders with
                                 | Some (_, reader) ->
                                     reader o
                                 | None ->
                                     let newReader = FSharpValue.PreComputeTupleReader(ot)
                                     tupleReaders <- (ot, newReader)::tupleReaders
                                     newReader o
                FSharpValue.MakeTuple(Array.map traverse fields, ot)
            elif FSharpType.IsRecord(ot) then
                let fields = match List.tryFind (fst >> ot.Equals) recordReaders with
                                 | Some (_, reader) ->
                                     reader o
                                 | None ->
                                     let newReader = FSharpValue.PreComputeRecordReader(ot)
                                     recordReaders <- (ot, newReader)::recordReaders
                                     newReader o
                FSharpValue.MakeRecord(ot, Array.map traverse fields)
            else
                o

    and traverse (o:obj) =
        let parent =
            if o = null then
                o
            else
                let ot = o.GetType()
                if ft = ot || ot.IsSubclassOf(ft) then
                    f (o :?> 'a) |> box
                elif gt = ot || ot.IsSubclassOf(gt) then
                    g (o :?> 'b) |> box
                elif ht = ot || ot.IsSubclassOf(ht) then
                    h (o :?> 'c) |> box
                elif it = ot || ot.IsSubclassOf(it) then
                    i (o :?> 'd) |> box
                elif jt = ot || ot.IsSubclassOf(jt) then
                    j (o :?> 'e) |> box
                else
                    o
        drill parent
    traverse src |> unbox : 'z

Answer 1

试试这个（我只是使用延续函数作为参数）：

namespace Solution

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<AutoOpen>]
module Solution =

    // These are used for a 50% speedup
    let mutable tupleReaders : List<System.Type * (obj -> obj[])> = []
    let mutable unionTagReaders : List<System.Type * (obj -> int)> = []
    let mutable unionReaders : List<(System.Type * int) * (obj -> obj[])> = []
    let mutable unionCaseInfos : List<System.Type * Microsoft.FSharp.Reflection.UnionCaseInfo[]> = []
    let mutable recordReaders : List<System.Type * (obj -> obj[])> = []

    (*
        Traverses any data structure in a preorder traversal
        Calls f, g, h, i, j which determine the mapping of the current node being considered

        WARNING: Not able to handle option types
        At runtime, option None values are represented as null and so you cannot determine their runtime type.

        See http://stackoverflow.com/questions/21855356/dynamically-determine-type-of-option-when-it-has-value-none
        http://stackoverflow.com/questions/13366647/how-to-generalize-f-option
    *)
    open Microsoft.FSharp.Reflection
    let map5<'a,'b,'c,'d,'e,'z> (f:'a->'a) (g:'b->'b) (h:'c->'c) (i:'d->'d) (j:'e->'e) (src:'z) =
        let ft = typeof<'a>
        let gt = typeof<'b>
        let ht = typeof<'c>
        let it = typeof<'d>
        let jt = typeof<'e>

        let rec drill (o:obj) =
            if o = null then
                (None, fun _ -> o)
            else
                let ot = o.GetType()
                if FSharpType.IsUnion(ot) then
                    let tag = match List.tryFind (fst >> ot.Equals) unionTagReaders with
                                  | Some (_, reader) ->
                                       reader o
                                  | None ->
                                       let newReader = FSharpValue.PreComputeUnionTagReader(ot)
                                       unionTagReaders <- (ot, newReader)::unionTagReaders
                                       newReader o
                    let info = match List.tryFind (fst >> ot.Equals) unionCaseInfos with
                                   | Some (_, caseInfos) ->
                                       Array.get caseInfos tag
                                   | None ->
                                       let newCaseInfos = FSharpType.GetUnionCases(ot)
                                       unionCaseInfos <- (ot, newCaseInfos)::unionCaseInfos
                                       Array.get newCaseInfos tag
                    let vals = match List.tryFind (fun ((tau, tag'), _) -> ot.Equals tau && tag = tag') unionReaders with
                                   | Some (_, reader) ->
                                       reader o
                                   | None ->
                                       let newReader = FSharpValue.PreComputeUnionReader info
                                       unionReaders <- ((ot, tag), newReader)::unionReaders
                                       newReader o
//                    (Some(vals), FSharpValue.MakeUnion(info, Array.map traverse vals))
                    (Some(vals), (fun x -> FSharpValue.MakeUnion(info, x)))
                elif FSharpType.IsTuple(ot) then
                    let fields = match List.tryFind (fst >> ot.Equals) tupleReaders with
                                     | Some (_, reader) ->
                                         reader o
                                     | None ->
                                         let newReader = FSharpValue.PreComputeTupleReader(ot)
                                         tupleReaders <- (ot, newReader)::tupleReaders
                                         newReader o
//                    (FSharpValue.MakeTuple(Array.map traverse fields, ot)
                    (Some(fields), (fun x -> FSharpValue.MakeTuple(x, ot)))
                elif FSharpType.IsRecord(ot) then
                    let fields = match List.tryFind (fst >> ot.Equals) recordReaders with
                                     | Some (_, reader) ->
                                         reader o
                                     | None ->
                                         let newReader = FSharpValue.PreComputeRecordReader(ot)
                                         recordReaders <- (ot, newReader)::recordReaders
                                         newReader o
//                    FSharpValue.MakeRecord(ot, Array.map traverse fields)
                    (Some(fields), (fun x -> FSharpValue.MakeRecord(ot, x)))
                else
                    (None, (fun _ -> o))



        and traverse (o:obj) cont =
            let parent =
                if o = null then
                    o
                else
                    let ot = o.GetType()
                    if ft = ot || ot.IsSubclassOf(ft) then
                        f (o :?> 'a) |> box
                    elif gt = ot || ot.IsSubclassOf(gt) then
                        g (o :?> 'b) |> box
                    elif ht = ot || ot.IsSubclassOf(ht) then
                        h (o :?> 'c) |> box
                    elif it = ot || ot.IsSubclassOf(it) then
                        i (o :?> 'd) |> box
                    elif jt = ot || ot.IsSubclassOf(jt) then
                        j (o :?> 'e) |> box
                    else
                        o
            let child, f = drill parent

            match child with 
                | None -> 
                    f [||] |> cont
                | Some(x) -> 

                    match x.Length with
                        | len when len > 1 ->
                            let resList = System.Collections.Generic.List<obj>()
                            let continuation = Array.foldBack (fun t s -> (fun mC -> resList.Add(mC); traverse t s) ) 
                                                              (x.[1..]) 
                                                              (fun mC -> resList.Add(mC); resList.ToArray() |> f |> cont)
                            traverse (x.[0]) continuation
                        | _ -> traverse x (fun mC -> 
                                            match mC with
                                                | :? (obj[]) as mC -> f mC |> cont
                                                | _ -> f [|mC|] |> cont
                                          )

        traverse src (fun x -> x) |> unbox : 'z

您应该使用启用Generate tail calls 选项来构建它（默认情况下，此选项在调试模式下禁用，但在发布中启用）。

例子：

type A1 =
    | A of A2
    | B of int

and A2 =
    | A of A1
    | B of int

and Root = 
    | A1 of A1
    | A2 of A2

[<EntryPoint>]
let main args =
    let rec build (elem: Root) n = 
        if n = 0 then elem
        else 
            match elem with
                | A1(x) -> build (Root.A2(A2.A(x))) (n-1)
                | A2(x) -> build (Root.A1(A1.A(x))) (n-1)
    let tree = build (Root.A1(A1.B(2))) 100000

    let a = map5 (fun x -> x) (fun x -> x) (fun x -> x) (fun x -> x) (fun x -> x) tree
    printf "%A" a
    0

此代码在没有堆栈溢出异常的情况下完成。

Answer 2

我最终将代码转换为命令式样式以避免堆栈溢出：

open Microsoft.FSharp.Reflection

let mutable tupleReaders : List<System.Type * (obj -> obj[])> = []
let mutable unionTagReaders : List<System.Type * (obj -> int)> = []
let mutable unionReaders : List<(System.Type * int) * (obj -> obj[])> = []
let mutable unionCaseInfos : List<System.Type * Microsoft.FSharp.Reflection.UnionCaseInfo[]> = []
let mutable recordReaders : List<System.Type * (obj -> obj[])> = []

type StructureInfo = Union of UnionCaseInfo
                   | Tuple of System.Type
                   | Record of System.Type
                   | Leaf

let map5<'a,'b,'c,'d,'e,'z> (f:'a->'a) (g:'b->'b) (h:'c->'c) (i:'d->'d) (j:'e->'e) (src:'z) : 'z =
    let ft = typeof<'a>
    let gt = typeof<'b>
    let ht = typeof<'c>
    let it = typeof<'d>
    let jt = typeof<'e>

    let getStructureInfo (o : obj) =
        if o = null then
            (Leaf, [||])
        else
            let ot = o.GetType()
            if FSharpType.IsUnion(ot) then
                let tag = match List.tryFind (fst >> ot.Equals) unionTagReaders with
                                | Some (_, reader) ->
                                    reader o
                                | None ->
                                    let newReader = FSharpValue.PreComputeUnionTagReader(ot)
                                    unionTagReaders <- (ot, newReader)::unionTagReaders
                                    newReader o
                let info = match List.tryFind (fst >> ot.Equals) unionCaseInfos with
                                | Some (_, caseInfos) ->
                                    Array.get caseInfos tag
                                | None ->
                                    let newCaseInfos = FSharpType.GetUnionCases(ot)
                                    unionCaseInfos <- (ot, newCaseInfos)::unionCaseInfos
                                    Array.get newCaseInfos tag
                let children =
                    match List.tryFind (fun ((tau, tag'), _) -> ot.Equals tau && tag = tag') unionReaders with
                        | Some (_, reader) ->
                            reader o
                        | None ->
                            let newReader = FSharpValue.PreComputeUnionReader info
                            unionReaders <- ((ot, tag), newReader)::unionReaders
                            newReader o
                (Union info, children)
            elif FSharpType.IsTuple(ot) then
                let children =
                    match List.tryFind (fst >> ot.Equals) tupleReaders with
                        | Some (_, reader) ->
                            reader o
                        | None ->
                            let newReader = FSharpValue.PreComputeTupleReader(ot)
                            tupleReaders <- (ot, newReader)::tupleReaders
                            newReader o
                (Tuple ot, children)
            elif FSharpType.IsRecord(ot) then
                let children =
                    match List.tryFind (fst >> ot.Equals) recordReaders with
                        | Some (_, reader) ->
                            reader o
                        | None ->
                            let newReader = FSharpValue.PreComputeRecordReader(ot)
                            recordReaders <- (ot, newReader)::recordReaders
                            newReader o
                (Record ot, children)
            else
                (Leaf, [||])

    let root = src |> box |> ref
    let mutable nodes = [root]
    let mutable completedNodes = []
    while not (List.isEmpty nodes) do
        let node = List.head nodes
        nodes <- List.tail nodes
        let o = !node
        let o' = if o = null then
                     o
                 else
                     let ot = o.GetType()
                     if ft = ot || ot.IsSubclassOf(ft) then
                         f (o :?> 'a) |> box
                     elif gt = ot || ot.IsSubclassOf(gt) then
                         g (o :?> 'b) |> box
                     elif ht = ot || ot.IsSubclassOf(ht) then
                         h (o :?> 'c) |> box
                     elif it = ot || ot.IsSubclassOf(it) then
                         i (o :?> 'd) |> box
                     elif jt = ot || ot.IsSubclassOf(jt) then
                         j (o :?> 'e) |> box
                     else
                         o
        node := o'
        let (structure, children) = getStructureInfo o'
        let childrenContainers = children |> Array.map ref
        completedNodes <- (node, structure, childrenContainers)::completedNodes
        nodes <- List.append (List.ofArray childrenContainers) nodes

    completedNodes |> List.iter
        (fun (oContainer, structureInfo, childrenContainers) ->
            let children = Array.map (!) childrenContainers
            match structureInfo with
                | Union info ->
                    oContainer := FSharpValue.MakeUnion(info, children)
                | Tuple ot ->
                    oContainer := FSharpValue.MakeTuple(children, ot)
                | Record ot ->
                    oContainer := FSharpValue.MakeRecord(ot, children)
                | Leaf -> ())
    (unbox !root) : 'z