| | | 1 | | namespace FSharp.Interop.Dlr |
| | | 2 | | |
| | | 3 | | open System |
| | | 4 | | open System.Linq.Expressions |
| | | 5 | | open FSharp.Quotations |
| | | 6 | | open FSharp.Quotations.Patterns |
| | | 7 | | open FSharp.Quotations.DerivedPatterns |
| | | 8 | | open FSharp.Quotations.ExprShape |
| | | 9 | | open FSharp.Reflection |
| | | 10 | | open Microsoft.FSharp.Linq.RuntimeHelpers |
| | | 11 | | open System.Runtime.CompilerServices |
| | | 12 | | |
| | | 13 | | /// Turns the reflected body of a `dlr { }` block into a delegate over the block's compiler-generated |
| | | 14 | | /// container — a `DlrReader<'SM, 'T>` over its state machine struct, or a `Func<obj, 'T>` over its |
| | | 15 | | /// Delay closure — with the DLR call sites baked in as constants. |
| | | 16 | | module internal Translate = |
| | | 17 | | open TranslatePatterns |
| | | 18 | | open SiteHoisting |
| | | 19 | | open TranslateBlock |
| | | 20 | | open TranslateMembers |
| | | 21 | | |
| | | 22 | | /// A compiled `dlr { }` site: a `DlrReader<'SM, 'T>` over the state machine struct, or in the |
| | | 23 | | /// fallback path a `Func<obj, 'T>` over the Delay closure object. |
| | | 24 | | type Compiled = { Delegate: Delegate } |
| | | 25 | | |
| | | 26 | | /// Receives each block's expression tree, with the block's container type, once its sites are |
| | | 27 | | /// hoisted: on the state-machine path that is before the by-reference wrapper, which only |
| | | 28 | | /// copies the machine into the lambda's `sm` and is what `Compile()` then gets. Null, and then |
| | | 29 | | /// free, unless set: `docs/trees` sets it by reflection to generate the docs' examples. |
| | 0 | 30 | | type TreeHook private () = |
| | | 31 | | static member val Sink : Action<Type, LambdaExpression> = null with get, set |
| | | 32 | | |
| | | 33 | | /// Compiles the reflected body of one `dlr { }` block. `closureType` is the block's |
| | | 34 | | /// compiler-generated container — its state machine struct, or in the fallback path the |
| | | 35 | | /// class of its `Delay` closure: its fields, named after the captured variables, are where |
| | | 36 | | /// the body's free variables are read from at call time. |
| | | 37 | | let translate (name: string) (builderType: Type) (context: Type) (memberBody: Expr) (closureType: Type) (resultType: |
| | 16948 | 38 | | let closure = if closureType.IsValueType then Var("sm", closureType) else Var("closure", typeof<obj>) |
| | 8474 | 39 | | let fields = Captures.fields closureType |
| | 8474 | 40 | | let reached, aliases = Captures.reached fields memberBody body |
| | 8474 | 41 | | let block = |
| | 8474 | 42 | | { BuilderType = builderType |
| | 8474 | 43 | | Context = context |
| | 8474 | 44 | | MemberBody = memberBody |
| | 8474 | 45 | | ClosureType = closureType |
| | 8474 | 46 | | Closure = closure |
| | 8474 | 47 | | Fields = fields |
| | 8474 | 48 | | Substituted = aliases |
| | 8474 | 49 | | Ambiguous = |
| | 8474 | 50 | | reached |
| | 44976 | 51 | | |> List.countBy (fun v -> v.Name) |> List.filter (fun (_, n) -> n > 1) |> List.map fst |> Set.ofList |
| | 8474 | 52 | | // Only an optimized build splits a tuple (the state machine, or in Release the closure |
| | 8474 | 53 | | // of `(dlr { … } : unit -> R) ()`), and not one it captures whole as a field. |
| | 8474 | 54 | | |> Set.union ( |
| | 8474 | 55 | | let optimized = |
| | 8474 | 56 | | closureType.IsValueType |
| | 8506 | 57 | | || not (closureType.Assembly.GetCustomAttributes(typeof<Diagnostics.DebuggableAttribute>, fals |
| | 12784 | 58 | | |> Seq.exists (fun a -> (a :?> Diagnostics.DebuggableAttribute).IsJITOptimizerDisabled |
| | 23811 | 59 | | if optimized then Captures.elementNameClashes (fun t -> not (fields.ContainsKey t)) memberBody els |
| | 8474 | 60 | | Name = name |
| | 8474 | 61 | | Names = Collections.Generic.Dictionary() } |
| | | 62 | | |
| | | 63 | | /// Variables bound inside the expression being rewritten are left alone; anything else |
| | | 64 | | /// that is not the builder comes from the closure or the enclosing member. |
| | 27527 | 65 | | let isCaptured (bound: Set<Var>) (v: Var) = not (bound.Contains v) && v.Type <> block.BuilderType |
| | | 66 | | |
| | | 67 | | let isBuilder (receiver: Expr option) = |
| | 41415 | 68 | | match receiver with |
| | 15730 | 69 | | | Some r -> r.Type = block.BuilderType |
| | 25685 | 70 | | | None -> false |
| | | 71 | | |
| | | 72 | | /// Builder calls and marker operations go to their sections; everything else is generic |
| | | 73 | | /// rewriting: captured variables become closure reads, and the structure is rebuilt as-is |
| | | 74 | | /// except where the expression tree has no form for it. |
| | | 75 | | let rec rewriteIn (bound: Set<Var>) (e: Expr) : Expr = |
| | 154561 | 76 | | let rewrite = rewriteIn bound |
| | 154561 | 77 | | match e with |
| | 55029 | 78 | | | Call(receiver, mi, args) when isBuilder receiver -> Plumbing.call block rewriteIn bound mi args e |
| | | 79 | | | _ -> |
| | 140947 | 80 | | match Members.tryOperation block rewriteIn bound e with |
| | 10114 | 81 | | | Some rewritten -> rewritten |
| | | 82 | | | None -> |
| | | 83 | | // A mutable struct captured from outside the block, mutated in place (see `inPlace`). |
| | 131819 | 84 | | match inPlace (fun v -> isCaptured bound v && Captures.isCell block v) (Captures.read block rewrite) (Captur |
| | 28 | 85 | | | Some written -> written |
| | | 86 | | | None -> |
| | | 87 | | // An element of a captured tuple the optimizer split into a field per element, read |
| | | 88 | | // directly or through what it inlines: a local function applied to unit, or an |
| | | 89 | | // immutable alias of an immutable variable (that value) whose name is no other's. |
| | | 90 | | let rec tupleVar (e: Expr) : Var option = |
| | 1760 | 91 | | match e with |
| | 1840 | 92 | | | Var v when isCaptured bound v && FSharp.Reflection.FSharpType.IsTuple v.Type -> |
| | 84 | 93 | | match letDefinition v memberBody with |
| | 0 | 94 | | | Some(Var y as d) when block.Substituted.Contains v || (not v.IsMutable && not y.IsMutable && not ( |
| | 0 | 95 | | tupleVar d |> Option.orElse (Some v) |
| | 84 | 96 | | | _ -> Some v |
| | 12 | 97 | | | Application(Var f, Value(_, t)) when t = typeof<unit> && isCaptured bound f && not (block.Fields.Conta |
| | 2 | 98 | | match letDefinition f memberBody with |
| | 2 | 99 | | | Some(Lambda(_, b)) -> tupleVar b |
| | 0 | 100 | | | _ -> None |
| | 1674 | 101 | | | _ -> None |
| | | 102 | | let element = |
| | 130679 | 103 | | match e with |
| | | 104 | | | TupleGet(inner, i) -> |
| | 2524 | 105 | | tupleVar inner |> Option.bind (fun v -> Captures.element block v i) |
| | 9236 | 106 | | | Call(None, mi, [ inner ]) when mi.DeclaringType.FullName = "Microsoft.FSharp.Core.Operators" && (mi.Na |
| | 346 | 107 | | tupleVar inner |> Option.bind (fun v -> Captures.element block v (if mi.Name = "Fst" then 0 else 1)) |
| | 128921 | 108 | | | _ -> None |
| | 130673 | 109 | | match element with |
| | 20 | 110 | | | Some read -> read |
| | | 111 | | | None -> |
| | 130653 | 112 | | match e with |
| | 46050 | 113 | | | Var v when isCaptured bound v -> Captures.read block (rewriteIn bound) v |
| | 264 | 114 | | | VarSet(v, value) when isCaptured bound v -> Captures.assign block v (rewrite value) |
| | 34630 | 115 | | | ShapeVar _ -> e |
| | | 116 | | // A resumable-code-typed leftover of the builder's shape (see `codeType`): the |
| | | 117 | | // compiler's `null` after the rethrow in an unmatched `try … with` arm. |
| | 2446 | 118 | | | Value(null, t) when isCode t -> defaultOf (codeType t) |
| | | 119 | | // A `let mutable` of the block has no expression-tree form: loop and try bodies are |
| | | 120 | | // compiled into delegates, and a tree variable cannot be assigned from inside one. So |
| | | 121 | | // it lives in a reference cell, as the compiler does for a captured mutable, with |
| | | 122 | | // reads and writes going through the cell. |
| | 13474 | 123 | | | Let(v, def, letBody) when v.IsMutable -> |
| | 1782 | 124 | | let cell = Var(v.Name, typedefof<Ref<_>>.MakeGenericType v.Type) |
| | 1782 | 125 | | let value = cell.Type.GetProperty("Value") |
| | | 126 | | let rec subst (e: Expr) = |
| | 49106 | 127 | | match inPlace ((=) v) (fun _ -> Expr.PropertyGet(Expr.Var cell, value)) (fun _ x -> Expr.PropertySet |
| | 960 | 128 | | | Some written -> written |
| | | 129 | | | None -> |
| | 46226 | 130 | | match e with |
| | 2516 | 131 | | | VarSet(v', x) when v' = v -> Expr.PropertySet(Expr.Var cell, value, subst x) |
| | 17230 | 132 | | | Var v' when v' = v -> Expr.PropertyGet(Expr.Var cell, value) |
| | 42508 | 133 | | | _ -> Quotation.rebuild subst e |
| | 1782 | 134 | | Expr.Let(cell, Expr.NewObject(cell.Type.GetConstructor([| v.Type |]), [ rewrite def ]), rewriteIn (bound |
| | 11692 | 135 | | | Let(v, def, letBody) -> Expr.Let(v, rewrite def, rewriteIn (bound.Add v) letBody) |
| | | 136 | | // `let rec` has no expression-tree form; tie the knot through reference cells, as the |
| | | 137 | | // compiler does: each binding becomes a cell, uses read the cell, and the definitions |
| | | 138 | | // are assigned after all cells exist so mutual recursion works too. |
| | | 139 | | | LetRecursive(bindings, letBody) -> |
| | 620 | 140 | | let cells = [ for (v, _) in bindings -> v, Var(v.Name + "'", typedefof<Ref<_>>.MakeGenericType v.Type) ] |
| | 250 | 141 | | let readCell (cell: Var) = Expr.PropertyGet(Expr.Var cell, cell.Type.GetProperty("Value")) |
| | 3904 | 142 | | let viaCells (e: Expr) = e.Substitute(fun v -> cells |> List.tryFind (fun (rv, _) -> rv = v) |> Option.m |
| | 306 | 143 | | let bound = cells |> List.fold (fun (b: Set<Var>) (_, c) -> b.Add c) bound |
| | 120 | 144 | | let assignments = |
| | 370 | 145 | | [ for (_, def), (_, cell) in List.zip bindings cells -> |
| | 250 | 146 | | Expr.PropertySet(Expr.Var cell, cell.Type.GetProperty("Value"), rewriteIn bound (viaCells def)) |
| | 120 | 147 | | let body = rewriteIn bound (viaCells letBody) |
| | 186 | 148 | | let inner = List.foldBack (fun assign rest -> Expr.Sequential(assign, rest)) assignments body |
| | 120 | 149 | | List.foldBack |
| | 120 | 150 | | (fun (v: Var, cell: Var) rest -> |
| | 130 | 151 | | Expr.Let(cell, Expr.NewObject(cell.Type.GetConstructor [| v.Type |], [ Expr.Value(null, v.Type) |
| | 120 | 152 | | cells inner |
| | | 153 | | // A `try` that is not the builder's (under a lambda, inside a delegate literal, or a |
| | | 154 | | // `try … with` used as a value): LeafExpressionConverter has no form for it, so it runs |
| | | 155 | | // through the same delegates as the block's own (#158). F#'s filter only repeats the |
| | | 156 | | // handler's match, which ends in `reraise ()` where no case fits; the handler alone does. |
| | | 157 | | | TryWith(body, _, _, ex, handler) -> |
| | 256 | 158 | | let func = Plumbing.func block rewriteIn bound |
| | 512 | 159 | | Expr.Call(tryWith.MakeGenericMethod(e.Type), [ func [] body; func [ ex ] (Plumbing.rethrowing ex handler |
| | | 160 | | // `while` and `for i in a .. b` that are not the builder's (under a lambda, in a delegate |
| | | 161 | | // literal, inside an expression): no LINQ form either, so the same delegates (#162). |
| | | 162 | | | WhileLoop(guard, body) -> |
| | 48 | 163 | | let func = Plumbing.func block rewriteIn bound |
| | 96 | 164 | | Expr.Call(whileLoop, [ func [] guard; func [] body ]) |
| | | 165 | | | ForIntegerRangeLoop(i, low, high, body) -> |
| | 50 | 166 | | let func = Plumbing.func block rewriteIn bound |
| | 100 | 167 | | Expr.Call(forRange, [ rewrite low; rewrite high; func [ i ] body ]) |
| | | 168 | | // An element of a struct tuple: the converter's TupleGet looks for a reference tuple's |
| | | 169 | | // property and rejects a ValueTuple's index (#162), so it is the field itself |
| | | 170 | | // (`Item1`…`Item7`, then `Rest`), as the byref holder reads it. |
| | 1680 | 171 | | | TupleGet(tuple, index) when tuple.Type.IsValueType -> |
| | 480 | 172 | | Binders.byRefHolderPath tuple.Type index |> List.fold (fun e f -> Expr.FieldGet(e, f)) (rewrite tuple) |
| | | 173 | | | TryFinally(body, compensation) -> |
| | 100 | 174 | | let func = Plumbing.func block rewriteIn bound |
| | | 175 | | // `use`'s compensation is `if (d :? IDisposable) then d.Dispose() else ()`: a void |
| | | 176 | | // call and `()` as the branches, which the converter rejects as mismatched. |
| | | 177 | | let rec unitBranches (c: Expr) = |
| | 400 | 178 | | match c with |
| | 200 | 179 | | | IfThenElse(cond, a, b) when c.Type = typeof<unit> -> Expr.IfThenElse(cond, unitBranches a, unitBra |
| | 400 | 180 | | | _ when isUnitCall c -> Expr.Sequential(c, Expr.Value(())) |
| | 200 | 181 | | | _ -> c |
| | 200 | 182 | | Expr.Call(tryFinally.MakeGenericMethod(e.Type), [ func [] body; func [] (unitBranches compensation) ]) |
| | | 183 | | | NewDelegate(t, vars, delegateBody) -> |
| | | 184 | | // A delegate literal's lambda is the delegate itself, not an F# function: keep it |
| | | 185 | | // whole (on wasm, made capturing: see `capturing`). The quotation may give the |
| | | 186 | | // parameters as nested lambdas in the body rather than in `vars`. |
| | 1030 | 187 | | let n = (DelegateMembers.invokeOf t).GetParameters().Length |
| | | 188 | | let rec peel k (e: Expr) acc = |
| | 1030 | 189 | | match e with |
| | 0 | 190 | | | Lambda(v, b) when k > 0 -> peel (k - 1) b (v :: acc) |
| | 1030 | 191 | | | _ -> List.rev acc, e |
| | 1030 | 192 | | let peeled, body = peel (n - vars.Length) delegateBody [] |
| | 1030 | 193 | | let allVars = vars @ peeled |
| | 2755 | 194 | | let inner = allVars |> List.fold (fun b v -> Set.add v b) bound |
| | 1030 | 195 | | let body = capturing block (asUnit (rewriteIn inner body)) |
| | | 196 | | // .NET Framework's Expression.Lambda finds `Invoke` by public lookup only, and an F# |
| | | 197 | | // `internal` delegate's is internal: there, the lambda is at the public delegate type |
| | | 198 | | // of the same signature and the delegate is bound over it (#125). Past sixteen |
| | | 199 | | // parameters that stand-in is emitted at run time, which a quotation must not name |
| | | 200 | | // on wasm (see Binders.WideSite) — never reached there: .NET Framework only. |
| | 1030 | 201 | | let standIn = DelegateMembers.standIn t |
| | 1030 | 202 | | let literalOf = typedefof<DelegateLiteral<_>>.MakeGenericType t |
| | 1030 | 203 | | match standIn with |
| | 16 | 204 | | | Some standIn -> Expr.Call(literalOf.GetMethod("From"), [ Expr.Coerce(Expr.NewDelegate(standIn, allVars |
| | | 205 | | // Re-wrapped so `.Method` is the delegate type's own `Invoke` (see `DelegateLiteral`). |
| | 1014 | 206 | | | None -> Expr.Call(literalOf.GetMethod("Over"), [ Expr.NewDelegate(t, allVars, body) ]) |
| | 13064 | 207 | | | ShapeLambda(v, lambdaBody) -> Expr.Lambda(v, capturing block (asUnit (rewriteIn (bound.Add v) lambdaBody)) |
| | | 208 | | // A void call where a `unit` value is expected (`ignore (list.Add x)`, `f (list.Add x)`): |
| | | 209 | | // the converter has no value for it, so run it, then `()`. |
| | 30889 | 210 | | | Call(receiver, mi, args) when args |> List.exists isUnitCall -> |
| | 14 | 211 | | let args' = args |> List.map (fun a -> if isUnitCall a then asUnit (rewrite a) else rewrite a) |
| | 4 | 212 | | match receiver with |
| | 0 | 213 | | | Some r -> Expr.Call(rewrite r, mi, args') |
| | 4 | 214 | | | None -> Expr.Call(mi, args') |
| | 594 | 215 | | | Application(f, arg) when isUnitCall arg -> Expr.Application(rewrite f, asUnit (rewrite arg)) |
| | 61345 | 216 | | | _ -> Quotation.rebuild rewrite e |
| | | 217 | | |
| | 8474 | 218 | | let delegateType = typedefof<Func<_, _>>.MakeGenericType(closure.Type, resultType) |
| | | 219 | | let compiled = |
| | 8474 | 220 | | try |
| | 8474 | 221 | | let rewritten = asUnit (rewriteIn Set.empty (normalize body)) |
| | 8348 | 222 | | let lambda = Expr.NewDelegate(delegateType, [ closure ], rewritten) |
| | 8348 | 223 | | let linq = LeafExpressionConverter.QuotationToExpression lambda :?> LambdaExpression |
| | 8348 | 224 | | let hoisted = nameNested block.NameFor (SiteHoister().Visit linq :?> LambdaExpression) |
| | 8348 | 225 | | match TreeHook.Sink with |
| | 8348 | 226 | | | null -> () |
| | 0 | 227 | | | sink -> sink.Invoke(closureType, hoisted) |
| | 8348 | 228 | | if closureType.IsValueType then |
| | | 229 | | // The machine comes by reference (a quotation variable cannot be byref): |
| | | 230 | | // copy it into the by-value local the body was converted against. A byref |
| | | 231 | | // cannot be closed over, and the copy is free; the reads are off the local. |
| | 4124 | 232 | | let machine = hoisted.Parameters.[0] |
| | 4124 | 233 | | let byRef = Expression.Parameter(closureType.MakeByRefType(), "machine") |
| | 4124 | 234 | | let readerType = typedefof<DlrReader<_, _>>.MakeGenericType(closureType, resultType) |
| | 4124 | 235 | | Expression.Lambda(readerType, Expression.Block(resultType, [ machine ], Expression.Assign(machine, b |
| | 4224 | 236 | | else Expression.Lambda(hoisted.Type, hoisted.Body, name, hoisted.Parameters).Compile() |
| | 252 | 237 | | with :? DlrTranslationException -> reraise () |
| | | 238 | | // A static member resolved here by reflection and missing is the binder's kind of |
| | | 239 | | // error, as it would be at the call for an instance target. |
| | 0 | 240 | | | :? Microsoft.CSharp.RuntimeBinder.RuntimeBinderException -> reraise () |
| | 0 | 241 | | | ex -> raise (DlrTranslationException(sprintf "dlr { } could not compile this body: %s\n%A" ex.Message b |
| | 8422 | 242 | | { Delegate = compiled } |