| | | 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 | | /// <summary>The state machine's data slot; the builder's <c>Return</c> writes it so the value stays live in the compile |
| | | 14 | | /// <remarks>Not part of the supported API: public only because compiled blocks call it, and it may change in any releas |
| | | 15 | | [<Struct; NoComparison; NoEquality; System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Nev |
| | | 16 | | type DlrData<'T> = |
| | | 17 | | [<DefaultValue(false)>] |
| | | 18 | | val mutable Result: 'T |
| | | 19 | | |
| | | 20 | | /// <summary>Where a block is: its outermost <c>Delay</c>, run while this thread is probing, records |
| | | 21 | | /// its caller's file and line here and returns without running the body. Thread-static rather |
| | | 22 | | /// than in <c>DlrData</c>: a field there would grow every state machine, and the boxed copy of it |
| | | 23 | | /// a compiled loop or <c>try</c> makes per call.</summary> |
| | | 24 | | /// <remarks>Not part of the supported API: public only because compiled blocks call it, and it may change in any releas |
| | | 25 | | [<Sealed; AbstractClass; System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>] |
| | | 26 | | type DlrLocation = |
| | | 27 | | [<ThreadStatic; DefaultValue>] |
| | | 28 | | static val mutable private probing: bool |
| | | 29 | | [<ThreadStatic; DefaultValue>] |
| | | 30 | | static val mutable private file: string |
| | | 31 | | [<ThreadStatic; DefaultValue>] |
| | | 32 | | static val mutable private line: int |
| | | 33 | | |
| | | 34 | | /// Whether this thread is probing for a block's location. |
| | 13469 | 35 | | static member Probing = DlrLocation.probing |
| | | 36 | | |
| | | 37 | | /// The probed block's answer. |
| | | 38 | | static member Answer(file: string, line: int) = |
| | 13469 | 39 | | DlrLocation.file <- file |
| | 13469 | 40 | | DlrLocation.line <- line |
| | | 41 | | |
| | | 42 | | /// Runs `run` (the block's code) as a probe and returns what its Delay answered. |
| | | 43 | | static member internal Probe(run: unit -> unit) : struct (string * int) = |
| | 13473 | 44 | | DlrLocation.probing <- true |
| | 13473 | 45 | | DlrLocation.file <- null |
| | 13473 | 46 | | DlrLocation.line <- -1 |
| | 13473 | 47 | | try |
| | 13473 | 48 | | run () |
| | 13473 | 49 | | struct (DlrLocation.file, DlrLocation.line) |
| | 13473 | 50 | | finally |
| | 13473 | 51 | | DlrLocation.probing <- false |
| | 13473 | 52 | | DlrLocation.file <- null |
| | | 53 | | |
| | | 54 | | /// <summary>The compiled block over its state machine, by reference: no copy of the struct at the call, |
| | | 55 | | /// none of the delegate-with-a-struct-argument cost a <c>Func<'SM, 'T></c> has (measured 4x slower). |
| | | 56 | | /// Public, and not for direct use: an F# <c>internal</c> delegate's <c>Invoke</c> is internal too, and |
| | | 57 | | /// .NET Framework's <c>Expression.Lambda</c> finds <c>Invoke</c> by public lookup only (#125).</summary> |
| | | 58 | | /// <remarks>Not part of the supported API: public only because compiled blocks call it, and it may change in any releas |
| | | 59 | | [<System.ComponentModel.EditorBrowsable(System.ComponentModel.EditorBrowsableState.Never)>] |
| | | 60 | | type DlrReader<'SM, 'T> = delegate of inref<'SM> -> 'T |
| | | 61 | | |
| | | 62 | | /// The translator's view of a reflected body: the markers (`opMethod`), the member-operation |
| | | 63 | | /// patterns, evaluation order (`sequenced`) and `normalize`, which applies a piped or curried |
| | | 64 | | /// marker to its arguments before any other rewrite. |
| | | 65 | | module internal TranslatePatterns = |
| | | 66 | | let unsupported (what: string) (e: Expr) = |
| | | 67 | | raise (DlrTranslationException(sprintf "dlr { } does not support %s: %A" what e)) |
| | | 68 | | |
| | | 69 | | let genericDef (mi: Reflection.MethodInfo) = |
| | | 70 | | if mi.IsGenericMethod then mi.GetGenericMethodDefinition() else mi |
| | | 71 | | |
| | | 72 | | /// The generic definition of the method a marker quotation calls. Curried static members |
| | | 73 | | /// quote as applications of an inner lambda, so this looks for the first call anywhere. |
| | | 74 | | let opMethod (e: Expr<_>) = genericDef (Quotation.methodOf e) |
| | | 75 | | |
| | | 76 | | let opDynamic = opMethod <@ fun (t: obj) (n: string) -> ((?) t n) : obj @> |
| | | 77 | | let opDynamicAssign = opMethod <@ fun (t: obj) (n: string) (v: obj) -> (?<-) t n v @> |
| | | 78 | | let opCall = opMethod <@ fun (t: obj) -> (Dlr.call t) : obj @> |
| | | 79 | | let opApply = opMethod <@ fun (a: obj) (t: obj) -> (Dlr.apply a t) : obj @> |
| | | 80 | | let opNamed = opMethod <@ fun (r: obj) -> Dlr.named r @> |
| | | 81 | | let opNamedOf = opMethod <@ fun (l: (string * obj) list) -> Dlr.namedOf l @> |
| | | 82 | | let opArgsOf = opMethod <@ fun (l: obj list) -> Dlr.argsOf l @> |
| | | 83 | | /// `Dlr.new'<T>(a, b, …)`: the type and the arguments (each unboxed to its static type). |
| | | 84 | | let (|New|_|) (e: Expr) = |
| | | 85 | | match e with |
| | | 86 | | | Call(None, mi, args) when mi.DeclaringType = typeof<Dlr> && mi.Name = "new'" -> |
| | | 87 | | Some(mi.GetGenericArguments().[0], [ for a in args -> match a with Coerce(inner, t) when t = typeof<obj> -> |
| | | 88 | | | _ -> None |
| | | 89 | | let opCast = opMethod <@ fun (v: obj) -> Dlr.cast<obj> v @> |
| | | 90 | | let opImplicit = opMethod <@ fun (v: obj) -> (Dlr.implicit v) : obj @> |
| | | 91 | | let opGet = opMethod <@ fun (n: string) (t: obj) -> (Dlr.get n t) : obj @> |
| | | 92 | | let opSet = opMethod <@ fun (n: string) (v: obj) (t: obj) -> Dlr.set n v t @> |
| | | 93 | | let opAddAssign = opMethod <@ fun (n: string) (v: obj) (t: obj) -> Dlr.addAssign n v t @> |
| | | 94 | | let opSubtractAssign = opMethod <@ fun (n: string) (v: obj) (t: obj) -> Dlr.subtractAssign n v t @> |
| | | 95 | | let opInvoke = opMethod <@ fun (n: string) (a: obj) (t: obj) -> (Dlr.invoke n a t) : obj @> |
| | | 96 | | let unaryOps = |
| | | 97 | | dict [ |
| | | 98 | | opMethod <@ fun (v: obj) -> (Dlr.neg v) : obj @>, ExpressionType.Negate |
| | | 99 | | opMethod <@ fun (v: obj) -> (Dlr.not v) : obj @>, ExpressionType.Not |
| | | 100 | | opMethod <@ fun (v: obj) -> (Dlr.complement v) : obj @>, ExpressionType.OnesComplement |
| | | 101 | | ] |
| | | 102 | | let forEach = opMethod <@ fun (items: seq<obj>) (body: Func<obj, unit>) -> DlrRuntime.forEach items body @> |
| | | 103 | | let whileLoop = opMethod <@ fun (guard: Func<bool>) (body: Func<unit>) -> DlrRuntime.whileLoop guard body @> |
| | | 104 | | let forRange = opMethod <@ fun (low: int) (high: int) (body: Func<int, unit>) -> DlrRuntime.forRange low high body @ |
| | | 105 | | let tryWith = opMethod <@ fun (body: Func<obj>) (handler: Func<exn, obj>) -> DlrRuntime.tryWith body handler @> |
| | | 106 | | let tryFinally = opMethod <@ fun (body: Func<obj>) (fin: Func<unit>) -> DlrRuntime.tryFinally body fin @> |
| | | 107 | | let rethrow = opMethod <@ fun (e: exn) -> (DlrRuntime.rethrow e : obj) @> |
| | | 108 | | let reraiseMethod = typeof<unit>.Assembly.GetType("Microsoft.FSharp.Core.Operators").GetMethod("Reraise") |
| | | 109 | | let using = opMethod <@ fun (r: IDisposable) (body: Func<IDisposable, obj>) -> DlrRuntime.using r body @> |
| | | 110 | | |
| | | 111 | | /// FSharp.Core's typed ranges (`RangeInt32`, …, `RangeChar`) by element type. |
| | | 112 | | let private typedRanges = |
| | | 113 | | typeof<unit>.Assembly.GetType("Microsoft.FSharp.Core.Operators+OperatorIntrinsics").GetMethods() |
| | | 114 | | |> Array.filter (fun m -> m.Name.StartsWith "Range" && not m.IsGenericMethodDefinition) |
| | | 115 | | |> Array.map (fun m -> m.ReturnType.GetGenericArguments().[0], m) |
| | | 116 | | |> dict |
| | | 117 | | |
| | | 118 | | /// A range on a primitive, `a .. b` or `a .. step .. b`, as the typed range the compiler inlines |
| | | 119 | | /// it to. Compiled from a quotation, the generic `op_Range`/`op_RangeStep` runs FSharp.Core's |
| | | 120 | | /// non-inlined form instead, whose every step is a dynamic addition and comparison, a few |
| | | 121 | | /// hundred bytes per element (#240). |
| | | 122 | | let (|PrimitiveRange|_|) (e: Expr) = |
| | | 123 | | match e with |
| | | 124 | | | Call(None, mi, args) when mi.IsGenericMethod && mi.DeclaringType.FullName = "Microsoft.FSharp.Core.Operators" |
| | | 125 | | let t = mi.GetGenericArguments().[0] |
| | | 126 | | let one () = |
| | | 127 | | if t = typeof<nativeint> then box 1n |
| | | 128 | | elif t = typeof<unativeint> then box 1un |
| | | 129 | | else Convert.ChangeType(1, t) |
| | | 130 | | match mi.Name, args, typedRanges.TryGetValue t with |
| | | 131 | | | "op_Range", [ low; high ], (true, m) when m.GetParameters().Length = 2 -> Some(m, [ low; high ]) // Rang |
| | | 132 | | | "op_Range", [ low; high ], (true, m) -> Some(m, [ low; Expr.Value(one (), t); high ]) |
| | | 133 | | | "op_RangeStep", [ low; step; high ], (true, m) when step.Type = t && m.GetParameters().Length = 3 -> Some( |
| | | 134 | | | _ -> None |
| | | 135 | | | _ -> None |
| | | 136 | | let opItem = opMethod <@ fun (i: obj) (t: obj) -> (Dlr.item i t) : obj @> |
| | | 137 | | let opSetItem = opMethod <@ fun (i: obj) (v: obj) (t: obj) -> Dlr.setItem i v t @> |
| | | 138 | | |
| | | 139 | | let binaryOps = |
| | | 140 | | dict [ |
| | | 141 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?%? r) : obj @>, ExpressionType.Modulo |
| | | 142 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?*? r) : obj @>, ExpressionType.Multiply |
| | | 143 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?+? r) : obj @>, ExpressionType.Add |
| | | 144 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?-? r) : obj @>, ExpressionType.Subtract |
| | | 145 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?/? r) : obj @>, ExpressionType.Divide |
| | | 146 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?&&&? r) : obj @>, ExpressionType.And |
| | | 147 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?|||? r) : obj @>, ExpressionType.Or |
| | | 148 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?^^^? r) : obj @>, ExpressionType.ExclusiveOr |
| | | 149 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?<<<? r) : obj @>, ExpressionType.LeftShift |
| | | 150 | | opMethod <@ fun (l: obj) (r: obj) -> (l ?>>>? r) : obj @>, ExpressionType.RightShift |
| | | 151 | | opMethod <@ fun (l: obj) (r: obj) -> l ?<=? r @>, ExpressionType.LessThanOrEqual |
| | | 152 | | opMethod <@ fun (l: obj) (r: obj) -> l ?<>? r @>, ExpressionType.NotEqual |
| | | 153 | | opMethod <@ fun (l: obj) (r: obj) -> l ?<? r @>, ExpressionType.LessThan |
| | | 154 | | opMethod <@ fun (l: obj) (r: obj) -> l ?=? r @>, ExpressionType.Equal |
| | | 155 | | opMethod <@ fun (l: obj) (r: obj) -> l ?>? r @>, ExpressionType.GreaterThan |
| | | 156 | | opMethod <@ fun (l: obj) (r: obj) -> l ?>=? r @>, ExpressionType.GreaterThanOrEqual |
| | | 157 | | ] |
| | | 158 | | |
| | | 159 | | /// A literal `[ typeof<A>; typeof<B>; … ]`. |
| | | 160 | | let rec (|TypeOfList|_|) (e: Expr) = |
| | | 161 | | match e with |
| | | 162 | | | NewUnionCase(empty, []) when empty.Name = "Empty" -> Some [] |
| | | 163 | | | NewUnionCase(cons, [ Call(None, mi, []); TypeOfList rest ]) when cons.Name = "Cons" && mi.Name = "TypeOf" && m |
| | | 164 | | Some(mi.GetGenericArguments().[0] :: rest) |
| | | 165 | | | _ -> None |
| | | 166 | | |
| | | 167 | | /// The explicit type arguments of a call: known at translation time (`Dlr.typeArgs<A, B>()`, |
| | | 168 | | /// or `Dlr.typeArgsOf` with a literal list of `typeof`s, which folds to the same), or an |
| | | 169 | | /// expression evaluated per call (`Dlr.typeArgsOf ts`), which keys a SiteCache like a |
| | | 170 | | /// computed name does. |
| | | 171 | | type TypeArgsSpec = |
| | | 172 | | | StaticTypes of Type list |
| | | 173 | | | RuntimeTypes of Expr |
| | | 174 | | |
| | | 175 | | let (|TypeArgs|_|) (e: Expr) = |
| | | 176 | | match e with |
| | | 177 | | | Call(None, mi, []) when mi.DeclaringType = typeof<Dlr> && mi.Name = "typeArgs" -> Some(StaticTypes(List.ofArra |
| | | 178 | | | Call(None, mi, [ TypeOfList ts ]) when mi.DeclaringType = typeof<Dlr> && mi.Name = "typeArgsOf" -> Some(Static |
| | | 179 | | | Call(None, mi, [ types ]) when mi.DeclaringType = typeof<Dlr> && mi.Name = "typeArgsOf" -> Some(RuntimeTypes t |
| | | 180 | | | _ -> None |
| | | 181 | | |
| | | 182 | | /// `Static<T>.Overloads` as a target: the type. |
| | | 183 | | let (|StaticTarget|_|) (e: Expr) = |
| | | 184 | | match e with |
| | | 185 | | | PropertyGet(None, pi, []) when pi.Name = "Overloads" && pi.DeclaringType.IsGenericType && pi.DeclaringType.Get |
| | | 186 | | Some(pi.DeclaringType.GetGenericArguments().[0]) |
| | | 187 | | | _ -> None |
| | | 188 | | |
| | | 189 | | let (|Op|_|) (def: Reflection.MethodInfo) (e: Expr) = |
| | | 190 | | match e with |
| | | 191 | | | Call(None, mi, args) when genericDef mi = def -> Some args |
| | | 192 | | | _ -> None |
| | | 193 | | |
| | | 194 | | /// `Dlr.namedOf pairs`: the list expression. |
| | | 195 | | let (|NamedOf|_|) (e: Expr) = |
| | | 196 | | match e with |
| | | 197 | | | Op opNamedOf [ pairs ] -> Some pairs |
| | | 198 | | | _ -> None |
| | | 199 | | |
| | | 200 | | /// `Dlr.argsOf values`: the list expression. |
| | | 201 | | let (|ArgsOf|_|) (e: Expr) = |
| | | 202 | | match e with |
| | | 203 | | | Op opArgsOf [ values ] -> Some values |
| | | 204 | | | _ -> None |
| | | 205 | | |
| | | 206 | | /// Either splat marker. |
| | | 207 | | let isSplat (e: Expr) = match e with NamedOf _ | ArgsOf _ -> true | _ -> false |
| | | 208 | | |
| | | 209 | | /// `Dlr.out` / `Dlr.outAs<'T> ()`: an out argument, its value returned in the result tuple; with |
| | | 210 | | /// the type the out states (`outAs`), or None for the result's shape to infer. |
| | | 211 | | let (|OutMarker|_|) (e: Expr) = |
| | | 212 | | match e with |
| | | 213 | | | PropertyGet(None, p, []) when p.DeclaringType = typeof<Dlr> && p.Name = "out" -> Some None |
| | | 214 | | | Call(None, mi, []) when mi.DeclaringType = typeof<Dlr> && mi.Name = "outAs" -> Some(Some(mi.GetGenericArgument |
| | | 215 | | | _ -> None |
| | | 216 | | |
| | | 217 | | /// `Dlr.ref v`: a ref argument over the variable `v`. |
| | | 218 | | let (|RefMarker|_|) (e: Expr) = |
| | | 219 | | match e with |
| | | 220 | | | Call(None, mi, [ v ]) when mi.DeclaringType = typeof<Dlr> && mi.Name = "ref" -> Some v |
| | | 221 | | | _ -> None |
| | | 222 | | |
| | | 223 | | let isByRefMarker (e: Expr) = match e with OutMarker _ | RefMarker _ -> true | _ -> false |
| | | 224 | | let unboxTo = opMethod <@ fun (o: obj) -> unbox<int> o @> |
| | | 225 | | |
| | | 226 | | let (|UnaryOp|_|) (e: Expr) = |
| | | 227 | | match e with |
| | | 228 | | | Call(None, mi, [ v ]) -> |
| | | 229 | | match unaryOps.TryGetValue(genericDef mi) with |
| | | 230 | | | true, op -> Some(op, v) |
| | | 231 | | | _ -> None |
| | | 232 | | | _ -> None |
| | | 233 | | |
| | | 234 | | let (|BinaryOp|_|) (e: Expr) = |
| | | 235 | | match e with |
| | | 236 | | | Call(None, mi, [ l; r ]) -> |
| | | 237 | | match binaryOps.TryGetValue(genericDef mi) with |
| | | 238 | | | true, op -> Some(op, l, r) |
| | | 239 | | | _ -> None |
| | | 240 | | | _ -> None |
| | | 241 | | |
| | | 242 | | let (|Literal|_|) (e: Expr) = |
| | | 243 | | match e with |
| | | 244 | | | Value(o, _) -> Some o |
| | | 245 | | | _ -> None |
| | | 246 | | |
| | | 247 | | |
| | | 248 | | /// Strips the boxing F# inserts on the way to an `obj` parameter, so the binder can see the |
| | | 249 | | /// real static type. |
| | | 250 | | let (|Unboxed|) (e: Expr) = |
| | | 251 | | match e with |
| | | 252 | | | Coerce(inner, t) when t = typeof<obj> -> inner |
| | | 253 | | | _ -> e |
| | | 254 | | |
| | | 255 | | /// `Dlr.named {| a = x; b = y |}`: the field names and values. F# evaluates the fields in |
| | | 256 | | /// source order through `let` temporaries and then builds the record in its own (sorted) |
| | | 257 | | /// field order, so the temporaries come back as bindings to wrap around the call. |
| | | 258 | | let (|NamedRecord|_|) (e: Expr) = |
| | | 259 | | let rec peel (bindings: (Var * Expr) list) (e: Expr) = |
| | | 260 | | match e with |
| | | 261 | | | Let(v, value, body) -> peel ((v, value) :: bindings) body |
| | | 262 | | | Op opNamed [ inner ] -> peel bindings inner |
| | | 263 | | | NewRecord(recordType, values) -> |
| | | 264 | | let fields = FSharpType.GetRecordFields recordType |
| | | 265 | | Some(List.rev bindings, List.zip [ for f in fields -> f.Name ] values) |
| | | 266 | | | other -> unsupported "Dlr.named applied to anything but an anonymous record literal" other |
| | | 267 | | match e with |
| | | 268 | | | Op opNamed _ -> peel [] e |
| | | 269 | | | _ -> None |
| | | 270 | | |
| | | 271 | | /// The compiler eta-expands a dynamic member used as a statement: |
| | | 272 | | /// `let clo = x?Foo in fun a -> clo a` applied to `()`. Fold it back to `x?Foo`. |
| | | 273 | | let rec (|EtaReduced|) (e: Expr) = |
| | | 274 | | match e with |
| | | 275 | | | Let(v, value, Lambda(x, Application(Var v', Var x'))) when v = v' && x = x' -> value |
| | | 276 | | | _ -> e |
| | | 277 | | |
| | | 278 | | /// `let a0 = x.0 in … let an = x.n in v (a0, …, an)`: the lambda body of the tupled |
| | | 279 | | /// eta-expansion the compiler makes of a call with a tuple of arguments on a target whose |
| | | 280 | | /// static type is not `obj` — a struct or class expression, a typed variable — (`let clo = |
| | | 281 | | /// (f ())?M in fun tupledArg -> …` applied to the tuple). |
| | | 282 | | let retuples (v: Var) (x: Var) (body: Expr) = |
| | | 283 | | let rec peel (elements: Var list) (e: Expr) = |
| | | 284 | | match e with |
| | | 285 | | | Let(a, TupleGet(Var x', i), rest) when x' = x && i = elements.Length -> peel (elements @ [ a ]) rest |
| | | 286 | | | Application(Var v', NewTuple items) when v' = v -> |
| | | 287 | | items.Length = elements.Length && List.forall2 (fun (item: Expr) (a: Var) -> item = Expr.Var a) items el |
| | | 288 | | | _ -> false |
| | | 289 | | peel [] body |
| | | 290 | | |
| | | 291 | | /// One of the member operations, whichever way it was spelled: `x?Name` / `(?) x name` / |
| | | 292 | | /// `Dlr.get name x`, those applied to arguments (`x?Name(a)`, `(Dlr.get name x)(a)`) or |
| | | 293 | | /// `Dlr.invoke name a x`, and `x?Name <- v` / `Dlr.set name v x`. Target, name |
| | | 294 | | /// expression, and the argument expression (for an invocation) or value (for a set). |
| | | 295 | | type MemberOp = |
| | | 296 | | | GetMember of target: Expr * name: Expr |
| | | 297 | | | InvokeMember of target: Expr * name: Expr * args: Expr |
| | | 298 | | | SetMember of target: Expr * name: Expr * value: Expr |
| | | 299 | | |
| | | 300 | | let (|MemberOp|_|) (e: Expr) = |
| | | 301 | | match e with |
| | | 302 | | | Application(EtaReduced(Op opDynamic [ Unboxed target; name ]), args) -> Some(InvokeMember(target, name, args)) |
| | | 303 | | | Op opDynamic [ Unboxed target; name ] -> Some(GetMember(target, name)) |
| | | 304 | | | Op opDynamicAssign [ Unboxed target; name; value ] -> Some(SetMember(target, name, value)) |
| | | 305 | | | Application(EtaReduced(Op opGet [ name; Unboxed target ]), args) -> Some(InvokeMember(target, name, args)) |
| | | 306 | | | Op opGet [ name; Unboxed target ] -> Some(GetMember(target, name)) |
| | | 307 | | | Op opInvoke [ name; args; Unboxed target ] -> Some(InvokeMember(target, name, args)) |
| | | 308 | | | Op opSet [ name; value; Unboxed target ] -> Some(SetMember(target, name, value)) |
| | | 309 | | | _ -> None |
| | | 310 | | |
| | | 311 | | /// `x?Foo()` applies unit; `x?Foo(a, b)` applies a tuple; `x?Foo(a)` applies one value. As in |
| | | 312 | | /// F#'s own method calls (`w.Add args` with `args: int * int`), an expression whose static |
| | | 313 | | /// type is a reference tuple is several arguments too: it is bound once and split with |
| | | 314 | | /// `TupleGet`, each element keeping its static type. A struct tuple is one value, as in F#; |
| | | 315 | | /// `box t` passes a tuple as one dynamic argument. Returns the binding, if any, and the items. |
| | | 316 | | let splitArgs (e: Expr) : (Var * Expr) list * Expr list = |
| | | 317 | | match e with |
| | | 318 | | // `()`, or a `unit`-typed variable (a generic parameter instantiated to unit, `let args = ()`): |
| | | 319 | | // no arguments, and nothing to evaluate. |
| | | 320 | | | Value(_, t) when t = typeof<unit> -> [], [] |
| | | 321 | | | Var v when v.Type = typeof<unit> -> [], [] |
| | | 322 | | // A unit-valued expression: evaluated for its effect, and no arguments. A void call |
| | | 323 | | // cannot be let-bound (the converter has no value for it), so `()` follows it. |
| | | 324 | | | e when e.Type = typeof<unit> -> [ Var("effect", typeof<unit>), Expr.Sequential(e, Expr.Value(())) ], [] |
| | | 325 | | | NewTuple items -> [], items |
| | | 326 | | | _ when FSharpType.IsTuple e.Type && not e.Type.IsValueType -> |
| | | 327 | | let v = Var("args", e.Type) |
| | | 328 | | [ v, e ], [ for i in 0 .. FSharpType.GetTupleElements(e.Type).Length - 1 -> Expr.TupleGet(Expr.Var v, i) ] |
| | | 329 | | | single -> [], [ single ] |
| | | 330 | | |
| | | 331 | | /// Whether evaluating `e` has no effect and no order to keep: an immutable variable, a |
| | | 332 | | /// literal, a lambda, a read-only field, a tuple or coercion of such. A mutable (a captured |
| | | 333 | | /// `let mutable`, a mutable field) is not: an argument may assign it. Anything else is bound |
| | | 334 | | /// in source order by `sequenced`. |
| | | 335 | | let rec isPure (e: Expr) = |
| | | 336 | | match e with |
| | | 337 | | | Var v -> not v.IsMutable |
| | | 338 | | | Value _ | Lambda _ | StaticTarget _ -> true |
| | | 339 | | | FieldGet(None, f) -> f.IsInitOnly || f.IsLiteral |
| | | 340 | | | FieldGet(Some inner, f) -> f.IsInitOnly && isPure inner |
| | | 341 | | | Coerce(inner, _) | TupleGet(inner, _) -> isPure inner |
| | | 342 | | | NewTuple items -> List.forall isPure items |
| | | 343 | | | _ -> false |
| | | 344 | | |
| | | 345 | | /// Whether a form's arguments make it hoist something ahead of its site call: a `Dlr.named` |
| | | 346 | | /// record's field temporaries, a splat list, a tuple bound by `splitArgs`. |
| | | 347 | | let hoists (tupleBindings: (Var * Expr) list) (argExprs: Expr list) = |
| | | 348 | | not tupleBindings.IsEmpty |
| | | 349 | | || argExprs |> List.exists (fun a -> match a with NamedOf _ | ArgsOf _ -> true | NamedRecord(lets, _) -> not let |
| | | 350 | | |
| | | 351 | | /// C#'s evaluation order — the target, then the arguments left to right — kept where a form |
| | | 352 | | /// hoists something ahead of its site call (`hoists`), which would otherwise run first: |
| | | 353 | | /// every impure expression is bound to a variable in source order, so the hoisted ones take |
| | | 354 | | /// their own place. The tuple of `splitArgs` goes after the target, where the arguments are; |
| | | 355 | | /// a computed name or type list (`keys`) between the target and the arguments, where |
| | | 356 | | /// `(?) x name args` writes them. Returns the bindings, the variables to add to the bound |
| | | 357 | | /// set, and the target, keys and arguments rewritten over the variables. |
| | | 358 | | let sequenced (target: Expr option) (keys: Expr list) (tupleBindings: (Var * Expr) list) (argExprs: Expr list) = |
| | | 359 | | let bindings = ResizeArray<Var * Expr>() |
| | | 360 | | let place (name: string) (e: Expr) = |
| | | 361 | | if isPure e then e |
| | | 362 | | else |
| | | 363 | | let v = Var(name, e.Type) |
| | | 364 | | bindings.Add((v, e)) |
| | | 365 | | Expr.Var v |
| | | 366 | | let target' = target |> Option.map (place "target") |
| | | 367 | | let keys' = keys |> List.mapi (fun i k -> place (sprintf "key%d" i) k) |
| | | 368 | | bindings.AddRange tupleBindings |
| | | 369 | | let args' = |
| | | 370 | | argExprs |> List.mapi (fun i a -> |
| | | 371 | | match a with |
| | | 372 | | // The record's temporaries at the record's place; the record itself then holds |
| | | 373 | | // only variables and pure values. |
| | | 374 | | | NamedRecord(lets, _) when not lets.IsEmpty -> |
| | | 375 | | let rec strip (e: Expr) = |
| | | 376 | | match e with |
| | | 377 | | | Let(_, _, body) -> strip body |
| | | 378 | | | Call(None, mi, [ inner ]) -> Expr.Call(mi, [ strip inner ]) |
| | | 379 | | | e -> e |
| | | 380 | | bindings.AddRange lets |
| | | 381 | | strip a |
| | | 382 | | | NamedRecord _ -> a |
| | | 383 | | | Call(None, mi, [ list ]) when isSplat a -> Expr.Call(mi, [ place (sprintf "list%d" i) list ]) |
| | | 384 | | // A byref marker stays where it is: the translator reads a ref's variable at the |
| | | 385 | | // call, after every other argument (a C# ref is a reference: the callee sees each |
| | | 386 | | // argument's write to it). |
| | | 387 | | | OutMarker _ | RefMarker _ -> a |
| | | 388 | | | a -> place (sprintf "arg%d" i) a) |
| | | 389 | | let bound = bindings |> Seq.map fst |> Set.ofSeq |
| | | 390 | | List.ofSeq bindings, bound, target', keys', args' |
| | | 391 | | |
| | | 392 | | /// The definition of a let-bound variable somewhere in `e` (quotation Vars are identity-based, |
| | | 393 | | /// so shadowing is not a concern). A `let rec` one is its whole group, `let rec … in v`: its |
| | | 394 | | /// own references stay bound to it rather than recovered again (#198). |
| | | 395 | | let rec letDefinition (v: Var) (e: Expr) : Expr option = |
| | | 396 | | match e with |
| | | 397 | | | Let(v', def, _) when v' = v -> Some def |
| | | 398 | | | LetRecursive(bindings, _) when bindings |> List.exists (fun (v', _) -> v' = v) -> Some(Expr.LetRecursive(bindi |
| | | 399 | | | ShapeVar _ -> None |
| | | 400 | | | ShapeLambda(_, body) -> letDefinition v body |
| | | 401 | | | ShapeCombination(_, args) -> args |> List.tryPick (letDefinition v) |
| | | 402 | | |
| | | 403 | | // `|>` is inlined inside a quotation literal, so these come from reflection instead. |
| | | 404 | | let fsharpOperators = typeof<obj list>.Assembly.GetType("Microsoft.FSharp.Core.Operators") |
| | | 405 | | let pipeRight = fsharpOperators.GetMethod("op_PipeRight") |
| | | 406 | | let pipeLeft = fsharpOperators.GetMethod("op_PipeLeft") |
| | | 407 | | |
| | | 408 | | /// The argument a parameter of a let-bound local function takes, when the member body |
| | | 409 | | /// applies that function exactly once — or of a lambda applied on the spot, |
| | | 410 | | /// `(fun k -> …) 1`: the optimizer inlines such a function at its call site, so its |
| | | 411 | | /// parameters become that call's arguments and are never captured. |
| | | 412 | | let parameterArgument (v: Var) (memberBody: Expr) : Expr option = |
| | | 413 | | let rec lambdaParams (e: Expr) = |
| | | 414 | | match e with |
| | | 415 | | | Lambda(p, body) -> let ps, inner = lambdaParams body in p :: ps, inner |
| | | 416 | | | _ -> [], e |
| | | 417 | | let rec applications (f: Var) (e: Expr) : Expr list list = |
| | | 418 | | // Full application chains f a1 a2 … of `f`, innermost first; a pipe is one more |
| | | 419 | | // application, `a |> f` or `f <| a` (#252). |
| | | 420 | | let rec chain (e: Expr) (acc: Expr list) = |
| | | 421 | | match e with |
| | | 422 | | | Application(inner, arg) -> chain inner (arg :: acc) |
| | | 423 | | | Op pipeRight [ arg; inner ] -> chain inner (arg :: acc) |
| | | 424 | | | Op pipeLeft [ inner; arg ] -> chain inner (arg :: acc) |
| | | 425 | | | Var f' when f' = f -> Some acc |
| | | 426 | | | _ -> None |
| | | 427 | | match chain e [] with |
| | | 428 | | | Some args when not args.IsEmpty -> [ args ] |
| | | 429 | | | _ -> |
| | | 430 | | match e with |
| | | 431 | | | ShapeVar _ -> [] |
| | | 432 | | | ShapeLambda(_, body) -> applications f body |
| | | 433 | | | ShapeCombination(_, args) -> args |> List.collect (applications f) |
| | | 434 | | /// `(fun p1 p2 -> body) a1 a2`: the lambda chain and its arguments, in order. A pipe is |
| | | 435 | | /// the same application, `a |> (fun p -> …)` or `(fun p -> …) <| a` (#252). |
| | | 436 | | let rec applied (e: Expr) (acc: Expr list) = |
| | | 437 | | match e with |
| | | 438 | | | Application(inner, arg) -> applied inner (arg :: acc) |
| | | 439 | | | Op pipeRight [ arg; f ] -> applied f (arg :: acc) |
| | | 440 | | | Op pipeLeft [ f; arg ] -> applied f (arg :: acc) |
| | | 441 | | | Lambda _ when not acc.IsEmpty -> Some(e, acc) |
| | | 442 | | | _ -> None |
| | | 443 | | /// The argument `v` takes in a lambda applied on the spot, if `e` is one binding `v`. |
| | | 444 | | let appliedArgument (e: Expr) : Expr option = |
| | | 445 | | match applied e [] with |
| | | 446 | | | Some(f, args) -> |
| | | 447 | | let ps, _ = lambdaParams f |
| | | 448 | | match List.tryFindIndex ((=) v) ps with |
| | | 449 | | | Some i when i < args.Length -> Some args.[i] |
| | | 450 | | | _ -> None |
| | | 451 | | | None -> None |
| | | 452 | | let rec search (e: Expr) : Expr option = |
| | | 453 | | match e with |
| | | 454 | | | Let(f, def, rest) when (let ps, _ = lambdaParams def in List.contains v ps) -> |
| | | 455 | | let ps, _ = lambdaParams def |
| | | 456 | | let index = List.findIndex ((=) v) ps |
| | | 457 | | match applications f rest with |
| | | 458 | | | [ args ] when args.Length > index -> Some args.[index] |
| | | 459 | | | [] -> None |
| | | 460 | | | _ -> None |
| | | 461 | | | (Application _ | Op pipeRight _ | Op pipeLeft _) when (appliedArgument e).IsSome -> appliedArgument e |
| | | 462 | | | ShapeVar _ -> None |
| | | 463 | | | ShapeLambda(_, body) -> search body |
| | | 464 | | | ShapeCombination(_, args) -> args |> List.tryPick search |
| | | 465 | | search memberBody |
| | | 466 | | |
| | | 467 | | |
| | | 468 | | /// `x |> f` in a reflected body is `op_PipeRight(x, let name = "A" in fun target -> …)`, and a |
| | | 469 | | /// curried marker applied to its arguments is `Application(Lambda(name, Lambda(target, …)), …)`. |
| | | 470 | | /// Apply such functions to their arguments and inline `let`s of literals and variables, so |
| | | 471 | | /// `w |> Dlr.get "A"` becomes the plain `Dlr.get "A" w` call the member-op patterns recognise, |
| | | 472 | | /// with the name a literal and a tuple argument still a tuple. An argument is substituted for |
| | | 473 | | /// its parameter only when that cannot change what runs: it is a variable or a literal, or it |
| | | 474 | | /// is used exactly once and not under a lambda (where it would run per invocation). Otherwise |
| | | 475 | | /// it is let-bound, so it is evaluated once — including when the parameter is never used. |
| | | 476 | | let rec normalize (e: Expr) : Expr = |
| | | 477 | | /// Occurrences of `v`, with any occurrence under a lambda counted as many. |
| | | 478 | | let rec occurrences (v: Var) (e: Expr) = |
| | | 479 | | match e with |
| | | 480 | | | Var v' when v' = v -> 1 |
| | | 481 | | | ShapeVar _ -> 0 |
| | | 482 | | | ShapeLambda(_, body) -> occurrences v body * 2 |
| | | 483 | | | ShapeCombination(_, args) -> args |> List.sumBy (occurrences v) |
| | | 484 | | /// The same, but lambdas on the spine of a curried function (`fun a -> fun b -> …`, each |
| | | 485 | | /// applied exactly once by the next argument) do not count as "under a lambda". |
| | | 486 | | let rec spineOccurrences (v: Var) (e: Expr) = |
| | | 487 | | match e with |
| | | 488 | | | Lambda(_, body) -> spineOccurrences v body |
| | | 489 | | | _ -> occurrences v e |
| | | 490 | | let pure' (x: Expr) = match x with Var v -> not v.IsMutable | Value _ -> true | _ -> false |
| | | 491 | | let rec apply (f: Expr) (x: Expr) : Expr = |
| | | 492 | | match f with |
| | | 493 | | | Let(v, value, body) -> Expr.Let(v, value, apply body x) |
| | | 494 | | | Lambda(p, body) -> |
| | | 495 | | if pure' x || spineOccurrences p body = 1 then body.Substitute(fun v -> if v = p then Some x else None) |
| | | 496 | | // A `unit` argument may compile to a void site call, which cannot be let-bound: |
| | | 497 | | // run it, then the body with `()` for the parameter. |
| | | 498 | | elif x.Type = typeof<unit> then Expr.Sequential(x, body.Substitute(fun v -> if v = p then Some(Expr.Valu |
| | | 499 | | else Expr.Let(p, x, body) |
| | | 500 | | | _ -> Expr.Application(f, x) |
| | | 501 | | let applied (f: Expr) (x: Expr) = |
| | | 502 | | match normalize f, normalize x with |
| | | 503 | | | (Lambda _ | Let _ as f), x -> normalize (apply f x) |
| | | 504 | | | f, x -> Expr.Application(f, x) |
| | | 505 | | match e with |
| | | 506 | | | Op pipeRight [ x; f ] -> applied f x |
| | | 507 | | | Op pipeLeft [ f; x ] -> applied f x |
| | | 508 | | // The tupled eta-expansion of a member call: back to the member applied to the tuple, |
| | | 509 | | // before the tuple would be let-bound under the lambda and its markers lost. |
| | | 510 | | | Application(Let(v, value, Lambda(x, body)), arg) when retuples v x body -> applied value arg |
| | | 511 | | | Application(f, x) -> applied f x |
| | | 512 | | // A `let` of a literal or an immutable variable is inlined; a snapshot of a mutable |
| | | 513 | | // (`let y = n` with `n` mutable) is not, since `n` may change before `y` is used. |
| | | 514 | | | Let(v, (Value _ | Var _ as value), body) when not v.IsMutable && pure' value -> normalize (body.Substitute(fun |
| | | 515 | | // The eta-expanded statement form `let clo = x?Foo in clo ()` once its lambda is applied. |
| | | 516 | | | Let(v, value, Application(Var v', arg)) when v = v' -> applied value arg |
| | | 517 | | // A parameterless delegate literal (`Func<int>(fun () -> 7)`, `Action(fun () -> …)`): F# |
| | | 518 | | // quotes it with no parameter and a bare body, a node FSharp.Core takes apart as the lambda |
| | | 519 | | // `fun () -> body` but rebuilds only from the bare body, so no rewrite can pass it through |
| | | 520 | | // (#156). It becomes `ParameterlessLiteral<D, R>.Of (fun () -> body)`, an ordinary call |
| | | 521 | | // that makes the delegate by its own type. |
| | | 522 | | | NewDelegate(t, [], body) -> |
| | | 523 | | let body = normalize body |
| | | 524 | | let thunk = Expr.Lambda(Var("unitVar", typeof<unit>), body) |
| | | 525 | | let literal = typedefof<ParameterlessLiteral<_, _>>.MakeGenericType(t, body.Type) |
| | | 526 | | Expr.Call(literal.GetMethod("Of"), [ thunk ]) |
| | | 527 | | | _ -> Quotation.rebuild normalize e |