| | | 1 | | namespace FSharp.Interop.Dlr |
| | | 2 | | |
| | | 3 | | open System |
| | | 4 | | open System.Collections.Concurrent |
| | | 5 | | open System.Reflection |
| | | 6 | | open FSharp.Quotations |
| | | 7 | | open FSharp.Quotations.Patterns |
| | | 8 | | open FSharp.Quotations.ExprShape |
| | | 9 | | |
| | | 10 | | /// Finds the quoted body of a `dlr { }` block from the type of its state machine (Release) or its |
| | | 11 | | /// Delay closure (Debug, and the one shape Release leaves to the closure), using the |
| | | 12 | | /// `[<ReflectedDefinition>]` of the enclosing member. |
| | | 13 | | module internal Discover = |
| | | 14 | | |
| | | 15 | | let private all = |
| | | 16 | | BindingFlags.Static ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlag |
| | | 17 | | |
| | | 18 | | /// Members with a reflected definition on `t` and every type nested in it (closures of a |
| | | 19 | | /// class member are nested in the enclosing module, not the class). Decoding a reflected |
| | | 20 | | /// definition costs microseconds and a module has one per member, so the result is kept |
| | | 21 | | /// per type: later blocks in the same type find their body without decoding again. |
| | | 22 | | let private reflectedCache = ConcurrentDictionary<Type, (MethodBase * Expr) list>() |
| | | 23 | | |
| | | 24 | | /// Members whose stored quotation FSharp.Core could not decode, per type: some |
| | | 25 | | /// compiler-generated members have one (a [<CLIEvent>] accessor), and so can a member of the |
| | | 26 | | /// user's whose body FSharp.Core refuses (`typeof<System.Void>` in it). Neither is fatal here |
| | | 27 | | /// — the block may be elsewhere — but when no body is found, the failure is the likely reason. |
| | | 28 | | let private undecodable = ConcurrentDictionary<Type, (MethodBase * exn) list>() |
| | | 29 | | |
| | | 30 | | let private tryReflected (m: MethodBase) = |
| | 197620 | 31 | | try Choice1Of2(Expr.TryGetReflectedDefinition m) with e -> Choice2Of2 e |
| | | 32 | | |
| | | 33 | | let rec private reflected (t: Type) : (MethodBase * Expr) list = |
| | 44227 | 34 | | reflectedCache.GetOrAdd(t, fun t -> |
| | 32005 | 35 | | let failures = ResizeArray() |
| | 32005 | 36 | | let found = |
| | 256953 | 37 | | [ for m in Seq.append (t.GetMethods all |> Seq.cast<MethodBase>) (t.GetConstructors all |> Seq.cast<Meth |
| | 197532 | 38 | | match tryReflected m with |
| | 6332 | 39 | | | Choice1Of2(Some q) -> yield m, q |
| | 55080 | 40 | | | Choice1Of2 None -> () |
| | 4 | 41 | | | Choice2Of2 e -> failures.Add((m, e)) |
| | 127268 | 42 | | for n in t.GetNestedTypes all do |
| | 63258 | 43 | | yield! reflected n ] |
| | 32009 | 44 | | if failures.Count > 0 then undecodable.[t] <- List.ofSeq failures |
| | 76232 | 45 | | found) |
| | | 46 | | |
| | | 47 | | /// The decode failures recorded for `types` and their nested types, for the not-found message. |
| | | 48 | | let rec private failuresIn (types: seq<Type>) : (MethodBase * exn) list = |
| | 256176 | 49 | | [ for t in types do |
| | 128076 | 50 | | match undecodable.TryGetValue t with |
| | 12 | 51 | | | true, fs -> yield! fs |
| | 64036 | 52 | | | _ -> () |
| | 128084 | 53 | | yield! failuresIn (t.GetNestedTypes all) ] |
| | | 54 | | |
| | | 55 | | /// Every `builder.Run(builder.Delay(fun () -> body), file, line)` in `e` at this file and line. |
| | | 56 | | let rec private runsAt (builderType: Type) (file: string) (line: int) (e: Expr) : Expr list = |
| | 371858956 | 57 | | match e with |
| | | 58 | | | Call(Some receiver, mi, [ Call(_, delay, [ Lambda(_, body) ]); Value(f, _); Value(l, _) ]) |
| | 15821568 | 59 | | when receiver.Type = builderType && mi.Name = "Run" && delay.Name = "Delay" |
| | 5282462 | 60 | | && unbox<int> l = line && unbox<string> f = file -> |
| | | 61 | | // Blocks nested inside this one compile with it (see Translate), so do not list them. |
| | 8522 | 62 | | [ body ] |
| | 92009628 | 63 | | | ShapeVar _ -> [] |
| | 82718038 | 64 | | | ShapeLambda(_, body) -> runsAt builderType file line body |
| | 295674234 | 65 | | | ShapeCombination(_, args) -> args |> List.collect (runsAt builderType file line) |
| | | 66 | | |
| | | 67 | | /// What a block needs from its enclosing member's reflected definition. |
| | | 68 | | type Found = |
| | | 69 | | { /// Type declaring the enclosing member: the binder's accessibility context, as in C#. |
| | | 70 | | Context: Type |
| | | 71 | | /// The whole reflected body of the enclosing member, for resolving let-bound values |
| | | 72 | | /// the optimizer inlined instead of capturing. |
| | | 73 | | MemberBody: Expr |
| | | 74 | | /// The block's body (the Delay lambda's body). |
| | | 75 | | Body: Expr } |
| | | 76 | | |
| | | 77 | | /// For a block inside a generic member, the closure class carries the member's type parameters |
| | | 78 | | /// under the same names, instantiated. Rebuild the member with those arguments so its reflected |
| | | 79 | | /// definition comes back with concrete types. A parameter the closure does not carry is unused |
| | | 80 | | /// by the block, so any instantiation will do. |
| | | 81 | | let private instantiate (closureType: Type) (m: MethodBase) : MethodBase = |
| | 33836 | 82 | | if not (m.IsGenericMethodDefinition || m.DeclaringType.IsGenericTypeDefinition) then m |
| | | 83 | | else |
| | | 84 | | let concrete = |
| | 20 | 85 | | if closureType.IsGenericType then |
| | 20 | 86 | | Array.zip (closureType.GetGenericTypeDefinition().GetGenericArguments()) (closureType.GetGenericArgu |
| | 44 | 87 | | |> Array.map (fun (p, a) -> p.Name, a) |
| | 20 | 88 | | |> dict |
| | 0 | 89 | | else dict [] |
| | 96 | 90 | | let resolve (p: Type) = match concrete.TryGetValue p.Name with | true, t -> t | _ -> typeof<obj> |
| | | 91 | | let onType = |
| | 20 | 92 | | if m.DeclaringType.IsGenericTypeDefinition then |
| | 42 | 93 | | let constructed = m.DeclaringType.MakeGenericType(m.DeclaringType.GetGenericArguments() |> Array.map |
| | 14 | 94 | | MethodBase.GetMethodFromHandle(m.MethodHandle, constructed.TypeHandle) |
| | 6 | 95 | | else m |
| | 20 | 96 | | match onType with |
| | 20 | 97 | | | :? MethodInfo as mi when mi.IsGenericMethodDefinition -> |
| | 30 | 98 | | mi.MakeGenericMethod(mi.GetGenericArguments() |> Array.map resolve) :> MethodBase |
| | 10 | 99 | | | other -> other |
| | | 100 | | |
| | | 101 | | /// The block whose Delay closure has type `closureType`, at `file:line`. |
| | | 102 | | let findBody (builderType: Type) (closureType: Type) (file: string) (line: int) : Found = |
| | 16972 | 103 | | let holder = if isNull closureType.DeclaringType then closureType else closureType.DeclaringType |
| | | 104 | | let search (types: seq<Type>) = |
| | 8510 | 105 | | types |
| | 8510 | 106 | | |> Seq.collect reflected |
| | 6615845 | 107 | | |> Seq.collect (fun (m, q) -> runsAt builderType file line q |> List.map (fun b -> m, q, b)) |
| | 8510 | 108 | | |> List.ofSeq |
| | 8486 | 109 | | let searched = ResizeArray<Type>() |
| | | 110 | | let matches = |
| | 8486 | 111 | | searched.Add holder |
| | 8486 | 112 | | match search [ holder ] with |
| | | 113 | | | [] -> |
| | | 114 | | // A member of a type declared in a namespace gets its closures nested in the file's |
| | | 115 | | // <StartupCode$…> class, not in the type: fall back to the whole assembly. |
| | 192030 | 116 | | let all = closureType.Assembly.GetTypes() |> Seq.filter (fun t -> not t.IsNested) |> List.ofSeq |
| | 24 | 117 | | searched.AddRange all |
| | 24 | 118 | | search all |
| | 8462 | 119 | | | found -> found |
| | 8486 | 120 | | match matches with |
| | | 121 | | | [ m, memberBody, body ] -> |
| | | 122 | | let m, memberBody, body = |
| | 8474 | 123 | | match instantiate closureType m with |
| | 16908 | 124 | | | inst when obj.ReferenceEquals(inst, m) -> m, memberBody, body |
| | | 125 | | | inst -> |
| | 40 | 126 | | match tryReflected inst with |
| | | 127 | | | Choice1Of2(Some q) -> |
| | 40 | 128 | | match runsAt builderType file line q with |
| | 40 | 129 | | | [ b ] -> inst, q, b |
| | 0 | 130 | | | _ -> m, memberBody, body |
| | 0 | 131 | | | _ -> m, memberBody, body |
| | 8474 | 132 | | { Context = m.DeclaringType; MemberBody = memberBody; Body = body } |
| | | 133 | | | [] -> |
| | | 134 | | // A member with the attribute whose quotation would not decode is the other reason a |
| | | 135 | | // body is not found — when it is the member the closure belongs to: the compiler |
| | | 136 | | // names a block's closure `<member>@<line>`. |
| | | 137 | | let undecoded = |
| | 24 | 138 | | match failuresIn searched |> List.tryFind (fun (m, _) -> closureType.Name.StartsWith(m.Name + "@")) with |
| | 4 | 139 | | | Some(m, e) -> sprintf " The block is in %s.%s, whose reflected definition could not be decoded (%s): i |
| | 4 | 140 | | | None -> "" |
| | | 141 | | // A trimmed publish keeps the stored definitions but not what FSharp.Core matches them |
| | | 142 | | // by, so the block is not found although the attribute is there: say so where the |
| | | 143 | | // assembly holds reflected definitions at all. |
| | | 144 | | let trimmed = |
| | 20 | 145 | | if holder.Assembly.GetManifestResourceNames() |> Array.exists (fun n -> n.StartsWith "ReflectedDefinitio |
| | 8 | 146 | | " If the attribute is there and the app is published trimmed (PublishTrimmed), trimming is the cause |
| | 0 | 147 | | else "" |
| | 8 | 148 | | raise (DlrTranslationException( |
| | 8 | 149 | | sprintf "dlr { } at %s:%d needs [<ReflectedDefinition>] on the function or member that contains it, |
| | 8 | 150 | | file line closureType.Name holder.FullName undecoded trimmed)) |
| | | 151 | | | many -> |
| | 4 | 152 | | raise (DlrTranslationException( |
| | 4 | 153 | | sprintf "%d dlr { } blocks share %s:%d; put each dlr { } on its own line." many.Length file line)) |