diff --git a/src/FSharp.Core/QueryExtensions.fs b/src/FSharp.Core/QueryExtensions.fs index 7da5831e478f506799e569da67117b294afc38c4..d7aead4813b0f1368c5826d84675a9213248b0da 100644 --- a/src/FSharp.Core/QueryExtensions.fs +++ b/src/FSharp.Core/QueryExtensions.fs @@ -21,14 +21,13 @@ open System.Linq.Expressions /// on a result of a query. type Grouping<'K, 'T>(key:'K, values:seq<'T>) = interface System.Linq.IGrouping<'K, 'T> with - member x.Key = key + member _.Key = key interface System.Collections.IEnumerable with - member x.GetEnumerator() = values.GetEnumerator() :> System.Collections.IEnumerator + member _.GetEnumerator() = values.GetEnumerator() :> System.Collections.IEnumerator interface System.Collections.Generic.IEnumerable<'T> with - member x.GetEnumerator() = values.GetEnumerator() - + member _.GetEnumerator() = values.GetEnumerator() module internal Adapters = diff --git a/src/FSharp.Core/SI.fs b/src/FSharp.Core/SI.fs index 83791bfa85bd42b3c1d7d694e1a4e9c7dcb3afc8..bf88a63006d982e29f4b51bdea529103efdc37ac 100644 --- a/src/FSharp.Core/SI.fs +++ b/src/FSharp.Core/SI.fs @@ -2,222 +2,223 @@ // The International System of Units (SI) namespace Microsoft.FSharp.Data.UnitSystems.SI.UnitNames - open Microsoft.FSharp.Core - /// The SI unit of length - [] - type metre +open Microsoft.FSharp.Core - /// The SI unit of length - [] - type meter = metre +/// The SI unit of length +[] +type metre - /// The SI unit of mass - [] - type kilogram +/// The SI unit of length +[] +type meter = metre - /// The SI unit of time - [] - type second +/// The SI unit of mass +[] +type kilogram - /// The SI unit of electric current - [] - type ampere +/// The SI unit of time +[] +type second - /// The SI unit of thermodynamic temperature - [] - type kelvin +/// The SI unit of electric current +[] +type ampere - /// The SI unit of amount of substance - [] - type mole +/// The SI unit of thermodynamic temperature +[] +type kelvin - /// The SI unit of luminous intensity - [] - type candela +/// The SI unit of amount of substance +[] +type mole - /// The SI unit of frequency - [] - type hertz = / second +/// The SI unit of luminous intensity +[] +type candela - /// The SI unit of force - [] - type newton = kilogram metre / second^2 +/// The SI unit of frequency +[] +type hertz = / second - /// The SI unit of pressure, stress - [] - type pascal = newton / metre^2 +/// The SI unit of force +[] +type newton = kilogram metre / second^2 - /// The SI unit of energy, work, amount of heat - [] - type joule = newton metre +/// The SI unit of pressure, stress +[] +type pascal = newton / metre^2 - /// The SI unit of power, radiant flux - [] - type watt = joule / second +/// The SI unit of energy, work, amount of heat +[] +type joule = newton metre - /// The SI unit of electric charge, amount of electricity - [] - type coulomb = second ampere +/// The SI unit of power, radiant flux +[] +type watt = joule / second - /// The SI unit of electric potential difference, electromotive force - [] - type volt = watt/ampere +/// The SI unit of electric charge, amount of electricity +[] +type coulomb = second ampere - /// The SI unit of capacitance - [] - type farad = coulomb/volt +/// The SI unit of electric potential difference, electromotive force +[] +type volt = watt/ampere - /// The SI unit of electric resistance - [] - type ohm = volt/ampere +/// The SI unit of capacitance +[] +type farad = coulomb/volt - /// The SI unit of electric conductance - [] - type siemens = ampere/volt +/// The SI unit of electric resistance +[] +type ohm = volt/ampere - /// The SI unit of magnetic flux - [] - type weber = volt second +/// The SI unit of electric conductance +[] +type siemens = ampere/volt - /// The SI unit of magnetic flux density - [] - type tesla = weber/metre^2 +/// The SI unit of magnetic flux +[] +type weber = volt second - /// The SI unit of inductance - [] - type henry = weber/ampere +/// The SI unit of magnetic flux density +[] +type tesla = weber/metre^2 - /// The SI unit of luminous flux - [] - type lumen = candela +/// The SI unit of inductance +[] +type henry = weber/ampere - /// The SI unit of illuminance - [] - type lux = lumen/metre^2 +/// The SI unit of luminous flux +[] +type lumen = candela - /// The SI unit of activity referred to a radionuclide - [] - type becquerel = second^-1 +/// The SI unit of illuminance +[] +type lux = lumen/metre^2 - /// The SI unit of absorbed dose - [] - type gray = joule/kilogram +/// The SI unit of activity referred to a radionuclide +[] +type becquerel = second^-1 - /// The SI unit of does equivalent - [] - type sievert = joule/kilogram +/// The SI unit of absorbed dose +[] +type gray = joule/kilogram - /// The SI unit of catalytic activity - [] - type katal = mole/second +/// The SI unit of does equivalent +[] +type sievert = joule/kilogram +/// The SI unit of catalytic activity +[] +type katal = mole/second // Common abbreviations for the International System of Units (SI) namespace Microsoft.FSharp.Data.UnitSystems.SI.UnitSymbols - open Microsoft.FSharp.Core - open Microsoft.FSharp.Data.UnitSystems.SI.UnitNames - /// A synonym for Metre, the SI unit of length - [] - type m = metre +open Microsoft.FSharp.Core +open Microsoft.FSharp.Data.UnitSystems.SI.UnitNames - /// A synonym for kilogram, the SI unit of mass - [] - type kg = kilogram +/// A synonym for Metre, the SI unit of length +[] +type m = metre - /// A synonym for second, the SI unit of time - [] - type s = second +/// A synonym for kilogram, the SI unit of mass +[] +type kg = kilogram - /// A synonym for ampere, the SI unit of electric current - [] - type A = ampere +/// A synonym for second, the SI unit of time +[] +type s = second - /// A synonym for kelvin, the SI unit of thermodynamic temperature - [] - type K = kelvin +/// A synonym for ampere, the SI unit of electric current +[] +type A = ampere - /// A synonym for mole, the SI unit of amount of substance - [] - type mol = mole +/// A synonym for kelvin, the SI unit of thermodynamic temperature +[] +type K = kelvin - /// A synonym for candela, the SI unit of luminous intensity - [] - type cd = candela +/// A synonym for mole, the SI unit of amount of substance +[] +type mol = mole - /// A synonym for hertz, the SI unit of frequency - [] - type Hz = hertz +/// A synonym for candela, the SI unit of luminous intensity +[] +type cd = candela - /// A synonym for newton, the SI unit of force - [] - type N = newton +/// A synonym for hertz, the SI unit of frequency +[] +type Hz = hertz - /// A synonym for pascal, the SI unit of pressure, stress - [] - type Pa = pascal +/// A synonym for newton, the SI unit of force +[] +type N = newton - /// A synonym for joule, the SI unit of energy, work, amount of heat - [] - type J = joule +/// A synonym for pascal, the SI unit of pressure, stress +[] +type Pa = pascal - /// A synonym for watt, the SI unit of power, radiant flux - [] - type W = watt +/// A synonym for joule, the SI unit of energy, work, amount of heat +[] +type J = joule - /// A synonym for coulomb, the SI unit of electric charge, amount of electricity - [] - type C = coulomb +/// A synonym for watt, the SI unit of power, radiant flux +[] +type W = watt - /// A synonym for volt, the SI unit of electric potential difference, electromotive force - [] - type V = volt +/// A synonym for coulomb, the SI unit of electric charge, amount of electricity +[] +type C = coulomb - /// A synonym for farad, the SI unit of capacitance - [] - type F = farad +/// A synonym for volt, the SI unit of electric potential difference, electromotive force +[] +type V = volt - /// A synonym for siemens, the SI unit of electric conductance - [] - type S = siemens +/// A synonym for farad, the SI unit of capacitance +[] +type F = farad - /// A synonym for UnitNames.ohm, the SI unit of electric resistance. - [] - type ohm = Microsoft.FSharp.Data.UnitSystems.SI.UnitNames.ohm +/// A synonym for siemens, the SI unit of electric conductance +[] +type S = siemens - /// A synonym for weber, the SI unit of magnetic flux - [] - type Wb = weber +/// A synonym for UnitNames.ohm, the SI unit of electric resistance. +[] +type ohm = Microsoft.FSharp.Data.UnitSystems.SI.UnitNames.ohm - /// A synonym for tesla, the SI unit of magnetic flux density - [] - type T = tesla +/// A synonym for weber, the SI unit of magnetic flux +[] +type Wb = weber - /// A synonym for lumen, the SI unit of luminous flux - [] - type lm = lumen +/// A synonym for tesla, the SI unit of magnetic flux density +[] +type T = tesla - /// A synonym for lux, the SI unit of illuminance - [] - type lx = lux +/// A synonym for lumen, the SI unit of luminous flux +[] +type lm = lumen - /// A synonym for becquerel, the SI unit of activity referred to a radionuclide - [] - type Bq = becquerel +/// A synonym for lux, the SI unit of illuminance +[] +type lx = lux - /// A synonym for gray, the SI unit of absorbed dose - [] - type Gy = gray +/// A synonym for becquerel, the SI unit of activity referred to a radionuclide +[] +type Bq = becquerel - /// A synonym for sievert, the SI unit of does equivalent - [] - type Sv = sievert +/// A synonym for gray, the SI unit of absorbed dose +[] +type Gy = gray - /// A synonym for katal, the SI unit of catalytic activity - [] - type kat = katal +/// A synonym for sievert, the SI unit of does equivalent +[] +type Sv = sievert - /// A synonym for henry, the SI unit of inductance - [] - type H = henry +/// A synonym for katal, the SI unit of catalytic activity +[] +type kat = katal + +/// A synonym for henry, the SI unit of inductance +[] +type H = henry diff --git a/src/FSharp.Core/array2.fs b/src/FSharp.Core/array2.fs index 7f161eac4a6e55cfb29a0761edb4126987ec1832..1820a66cee1897b62b0c8add313a25cd88c93fdb 100644 --- a/src/FSharp.Core/array2.fs +++ b/src/FSharp.Core/array2.fs @@ -2,159 +2,159 @@ namespace Microsoft.FSharp.Collections - open System - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.Operators.Checked +open System +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Core.Operators.Checked - #nowarn "3218" // mismatch of parameter name where 'count1' --> 'length1' would shadow function in module of same name +#nowarn "3218" // mismatch of parameter name where 'count1' --> 'length1' would shadow function in module of same name - [] - [] - module Array2D = +[] +[] +module Array2D = - let inline checkNonNull argName arg = - if isNull arg then - nullArg argName + let inline checkNonNull argName arg = + if isNull arg then + nullArg argName - // Define the primitive operations. - // Note: the "type" syntax is for the type parameter for inline - // polymorphic IL. This helps the compiler inline these fragments, - // i.e. work out the correspondence between IL and F# type variables. + // Define the primitive operations. + // Note: the "type" syntax is for the type parameter for inline + // polymorphic IL. This helps the compiler inline these fragments, + // i.e. work out the correspondence between IL and F# type variables. - [] - let length1 (array: 'T[,]) = (# "ldlen.multi 2 0" array : int #) + [] + let length1 (array: 'T[,]) = (# "ldlen.multi 2 0" array : int #) - [] - let length2 (array: 'T[,]) = (# "ldlen.multi 2 1" array : int #) + [] + let length2 (array: 'T[,]) = (# "ldlen.multi 2 1" array : int #) - [] - let base1 (array: 'T[,]) = array.GetLowerBound(0) + [] + let base1 (array: 'T[,]) = array.GetLowerBound(0) - [] - let base2 (array: 'T[,]) = array.GetLowerBound(1) + [] + let base2 (array: 'T[,]) = array.GetLowerBound(1) - [] - let get (array: 'T[,]) (index1:int) (index2:int) = - (# "ldelem.multi 2 !0" type ('T) array index1 index2 : 'T #) + [] + let get (array: 'T[,]) (index1:int) (index2:int) = + (# "ldelem.multi 2 !0" type ('T) array index1 index2 : 'T #) - [] - let set (array: 'T[,]) (index1:int) (index2:int) (value:'T) = - (# "stelem.multi 2 !0" type ('T) array index1 index2 value #) + [] + let set (array: 'T[,]) (index1:int) (index2:int) (value:'T) = + (# "stelem.multi 2 !0" type ('T) array index1 index2 value #) - [] - let zeroCreate (length1: int) (length2: int) = - if length1 < 0 then invalidArgInputMustBeNonNegative "length1" length1 - if length2 < 0 then invalidArgInputMustBeNonNegative "length2" length2 - (# "newarr.multi 2 !0" type ('T) length1 length2 : 'T[,] #) + [] + let zeroCreate (length1: int) (length2: int) = + if length1 < 0 then invalidArgInputMustBeNonNegative "length1" length1 + if length2 < 0 then invalidArgInputMustBeNonNegative "length2" length2 + (# "newarr.multi 2 !0" type ('T) length1 length2 : 'T[,] #) - [] - let zeroCreateBased (base1:int) (base2:int) (length1:int) (length2:int) = - if base1 = 0 && base2 = 0 then + [] + let zeroCreateBased (base1:int) (base2:int) (length1:int) (length2:int) = + if base1 = 0 && base2 = 0 then #if NETSTANDARD - zeroCreate length1 length2 + zeroCreate length1 length2 #else - // Note: this overload is available on Compact Framework and Silverlight, but not Portable - (System.Array.CreateInstance(typeof<'T>, [|length1;length2|]) :?> 'T[,]) + // Note: this overload is available on Compact Framework and Silverlight, but not Portable + (System.Array.CreateInstance(typeof<'T>, [|length1;length2|]) :?> 'T[,]) #endif - else - (Array.CreateInstance(typeof<'T>, [|length1;length2|], [|base1;base2|]) :?> 'T[,]) - - [] - let createBased base1 base2 length1 length2 (initial:'T) = - let array = (zeroCreateBased base1 base2 length1 length2 : 'T[,]) - for i = base1 to base1 + length1 - 1 do - for j = base2 to base2 + length2 - 1 do - array.[i, j] <- initial - array - - [] - let initBased base1 base2 length1 length2 initializer = - let array = (zeroCreateBased base1 base2 length1 length2 : 'T[,]) - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(initializer) - for i = base1 to base1 + length1 - 1 do - for j = base2 to base2 + length2 - 1 do - array.[i, j] <- f.Invoke(i, j) - array - - [] - let create length1 length2 (value:'T) = - createBased 0 0 length1 length2 value - - [] - let init length1 length2 initializer = - initBased 0 0 length1 length2 initializer - - [] - let iter action array = - checkNonNull "array" array - let count1 = length1 array - let count2 = length2 array - let b1 = base1 array - let b2 = base2 array - for i = b1 to b1 + count1 - 1 do - for j = b2 to b2 + count2 - 1 do - action array.[i, j] - - [] - let iteri (action : int -> int -> 'T -> unit) (array:'T[,]) = - checkNonNull "array" array - let count1 = length1 array - let count2 = length2 array - let b1 = base1 array - let b2 = base2 array - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(action) - for i = b1 to b1 + count1 - 1 do - for j = b2 to b2 + count2 - 1 do - f.Invoke(i, j, array.[i, j]) - - [] - let map mapping array = - checkNonNull "array" array - initBased (base1 array) (base2 array) (length1 array) (length2 array) (fun i j -> mapping array.[i,j]) - - [] - let mapi mapping array = - checkNonNull "array" array - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(mapping) - initBased (base1 array) (base2 array) (length1 array) (length2 array) (fun i j -> f.Invoke(i, j, array.[i,j])) - - [] - let copy array = - checkNonNull "array" array - initBased (base1 array) (base2 array) (length1 array) (length2 array) (fun i j -> array.[i,j]) - - [] - let rebase array = - checkNonNull "array" array - let b1 = base1 array - let b2 = base2 array - init (length1 array) (length2 array) (fun i j -> array.[b1 + i, b2 + j]) - - [] - let blit (source : 'T[,]) sourceIndex1 sourceIndex2 (target: 'T[,]) targetIndex1 targetIndex2 count1 count2 = - checkNonNull "source" source - checkNonNull "target" target - - let sourceX0, sourceY0 = source.GetLowerBound 0, source.GetLowerBound 1 - let sourceXN, sourceYN = (length1 source) + sourceX0, (length2 source) + sourceY0 - let targetX0, targetY0 = target.GetLowerBound 0, target.GetLowerBound 1 - let targetXN, targetYN = (length1 target) + targetX0, (length2 target) + targetY0 - - if sourceIndex1 < sourceX0 then invalidArgOutOfRange "sourceIndex1" sourceIndex1 "source axis-0 lower bound" sourceX0 - if sourceIndex2 < sourceY0 then invalidArgOutOfRange "sourceIndex2" sourceIndex2 "source axis-1 lower bound" sourceY0 - if targetIndex1 < targetX0 then invalidArgOutOfRange "targetIndex1" targetIndex1 "target axis-0 lower bound" targetX0 - if targetIndex2 < targetY0 then invalidArgOutOfRange "targetIndex2" targetIndex2 "target axis-1 lower bound" targetY0 - if sourceIndex1 + count1 > sourceXN then - invalidArgOutOfRange "count1" count1 ("source axis-0 end index = " + string(sourceIndex1 + count1) + " source axis-0 upper bound") sourceXN - if sourceIndex2 + count2 > sourceYN then - invalidArgOutOfRange "count2" count2 ("source axis-1 end index = " + string(sourceIndex2 + count2) + " source axis-1 upper bound") sourceYN - if targetIndex1 + count1 > targetXN then - invalidArgOutOfRange "count1" count1 ("target axis-0 end index = " + string(targetIndex1 + count1) + " target axis-0 upper bound") targetXN - if targetIndex2 + count2 > targetYN then - invalidArgOutOfRange "count2" count2 ("target axis-1 end index = " + string(targetIndex2 + count2) + " target axis-1 upper bound") targetYN - - for i = 0 to count1 - 1 do - for j = 0 to count2 - 1 do - target.[targetIndex1 + i, targetIndex2 + j] <- source.[sourceIndex1 + i, sourceIndex2 + j] + else + (Array.CreateInstance(typeof<'T>, [|length1;length2|], [|base1;base2|]) :?> 'T[,]) + + [] + let createBased base1 base2 length1 length2 (initial:'T) = + let array = (zeroCreateBased base1 base2 length1 length2 : 'T[,]) + for i = base1 to base1 + length1 - 1 do + for j = base2 to base2 + length2 - 1 do + array.[i, j] <- initial + array + + [] + let initBased base1 base2 length1 length2 initializer = + let array = (zeroCreateBased base1 base2 length1 length2 : 'T[,]) + let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(initializer) + for i = base1 to base1 + length1 - 1 do + for j = base2 to base2 + length2 - 1 do + array.[i, j] <- f.Invoke(i, j) + array + + [] + let create length1 length2 (value:'T) = + createBased 0 0 length1 length2 value + + [] + let init length1 length2 initializer = + initBased 0 0 length1 length2 initializer + + [] + let iter action array = + checkNonNull "array" array + let count1 = length1 array + let count2 = length2 array + let b1 = base1 array + let b2 = base2 array + for i = b1 to b1 + count1 - 1 do + for j = b2 to b2 + count2 - 1 do + action array.[i, j] + + [] + let iteri (action : int -> int -> 'T -> unit) (array:'T[,]) = + checkNonNull "array" array + let count1 = length1 array + let count2 = length2 array + let b1 = base1 array + let b2 = base2 array + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(action) + for i = b1 to b1 + count1 - 1 do + for j = b2 to b2 + count2 - 1 do + f.Invoke(i, j, array.[i, j]) + + [] + let map mapping array = + checkNonNull "array" array + initBased (base1 array) (base2 array) (length1 array) (length2 array) (fun i j -> mapping array.[i,j]) + + [] + let mapi mapping array = + checkNonNull "array" array + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(mapping) + initBased (base1 array) (base2 array) (length1 array) (length2 array) (fun i j -> f.Invoke(i, j, array.[i,j])) + + [] + let copy array = + checkNonNull "array" array + initBased (base1 array) (base2 array) (length1 array) (length2 array) (fun i j -> array.[i,j]) + + [] + let rebase array = + checkNonNull "array" array + let b1 = base1 array + let b2 = base2 array + init (length1 array) (length2 array) (fun i j -> array.[b1 + i, b2 + j]) + + [] + let blit (source : 'T[,]) sourceIndex1 sourceIndex2 (target: 'T[,]) targetIndex1 targetIndex2 count1 count2 = + checkNonNull "source" source + checkNonNull "target" target + + let sourceX0, sourceY0 = source.GetLowerBound 0, source.GetLowerBound 1 + let sourceXN, sourceYN = (length1 source) + sourceX0, (length2 source) + sourceY0 + let targetX0, targetY0 = target.GetLowerBound 0, target.GetLowerBound 1 + let targetXN, targetYN = (length1 target) + targetX0, (length2 target) + targetY0 + + if sourceIndex1 < sourceX0 then invalidArgOutOfRange "sourceIndex1" sourceIndex1 "source axis-0 lower bound" sourceX0 + if sourceIndex2 < sourceY0 then invalidArgOutOfRange "sourceIndex2" sourceIndex2 "source axis-1 lower bound" sourceY0 + if targetIndex1 < targetX0 then invalidArgOutOfRange "targetIndex1" targetIndex1 "target axis-0 lower bound" targetX0 + if targetIndex2 < targetY0 then invalidArgOutOfRange "targetIndex2" targetIndex2 "target axis-1 lower bound" targetY0 + if sourceIndex1 + count1 > sourceXN then + invalidArgOutOfRange "count1" count1 ("source axis-0 end index = " + string(sourceIndex1 + count1) + " source axis-0 upper bound") sourceXN + if sourceIndex2 + count2 > sourceYN then + invalidArgOutOfRange "count2" count2 ("source axis-1 end index = " + string(sourceIndex2 + count2) + " source axis-1 upper bound") sourceYN + if targetIndex1 + count1 > targetXN then + invalidArgOutOfRange "count1" count1 ("target axis-0 end index = " + string(targetIndex1 + count1) + " target axis-0 upper bound") targetXN + if targetIndex2 + count2 > targetYN then + invalidArgOutOfRange "count2" count2 ("target axis-1 end index = " + string(targetIndex2 + count2) + " target axis-1 upper bound") targetYN + + for i = 0 to count1 - 1 do + for j = 0 to count2 - 1 do + target.[targetIndex1 + i, targetIndex2 + j] <- source.[sourceIndex1 + i, sourceIndex2 + j] diff --git a/src/FSharp.Core/array3.fs b/src/FSharp.Core/array3.fs index 6af3a650cf35e6eb0a73e1963f65c133d3942ff2..c92e46b8e57435068cf36afb6b91ceded4e549aa 100644 --- a/src/FSharp.Core/array3.fs +++ b/src/FSharp.Core/array3.fs @@ -2,159 +2,158 @@ namespace Microsoft.FSharp.Collections - open System.Diagnostics - open Microsoft.FSharp.Collections - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.Operators.Checked - - [] - [] - module Array3D = - - let inline checkNonNull argName arg = - if isNull arg then - nullArg argName - - [] - let length1 (array: 'T[,,]) = (# "ldlen.multi 3 0" array : int #) - - [] - let length2 (array: 'T[,,]) = (# "ldlen.multi 3 1" array : int #) - - [] - let length3 (array: 'T[,,]) = (# "ldlen.multi 3 2" array : int #) - - [] - let get (array: 'T[,,]) index1 index2 index3 = array.[index1,index2,index3] - - [] - let set (array: 'T[,,]) index1 index2 index3 value = array.[index1,index2,index3] <- value - - [] - let zeroCreate length1 length2 length3 = - if length1 < 0 then invalidArgInputMustBeNonNegative "n1" length1 - if length2 < 0 then invalidArgInputMustBeNonNegative "n2" length2 - if length3 < 0 then invalidArgInputMustBeNonNegative "n3" length3 - (# "newarr.multi 3 !0" type ('T) length1 length2 length3 : 'T[,,] #) - - [] - let create length1 length2 length3 (initial:'T) = - let arr = (zeroCreate length1 length2 length3 : 'T[,,]) - for i = 0 to length1 - 1 do - for j = 0 to length2 - 1 do - for k = 0 to length3 - 1 do - arr.[i,j,k] <- initial - arr - - [] - let init length1 length2 length3 initializer = - let arr = (zeroCreate length1 length2 length3 : 'T[,,]) - let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(initializer) - for i = 0 to length1 - 1 do - for j = 0 to length2 - 1 do - for k = 0 to length3 - 1 do - arr.[i,j,k] <- f.Invoke(i, j, k) - arr - - [] - let iter action array = - checkNonNull "array" array - let len1 = length1 array - let len2 = length2 array - let len3 = length3 array - for i = 0 to len1 - 1 do - for j = 0 to len2 - 1 do - for k = 0 to len3 - 1 do - action array.[i,j,k] - - [] - let map mapping array = - checkNonNull "array" array - let len1 = length1 array - let len2 = length2 array - let len3 = length3 array - let res = (zeroCreate len1 len2 len3 : 'b[,,]) - for i = 0 to len1 - 1 do - for j = 0 to len2 - 1 do - for k = 0 to len3 - 1 do - res.[i,j,k] <- mapping array.[i,j,k] - res - - [] - let iteri action array = - checkNonNull "array" array - let len1 = length1 array - let len2 = length2 array - let len3 = length3 array - let f = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(action) - for i = 0 to len1 - 1 do - for j = 0 to len2 - 1 do - for k = 0 to len3 - 1 do - f.Invoke(i, j, k, array.[i,j,k]) - - [] - let mapi mapping array = - checkNonNull "array" array - let len1 = length1 array - let len2 = length2 array - let len3 = length3 array - let res = (zeroCreate len1 len2 len3 : 'b[,,]) - let f = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(mapping) - for i = 0 to len1 - 1 do - for j = 0 to len2 - 1 do - for k = 0 to len3 - 1 do - res.[i,j,k] <- f.Invoke(i, j, k, array.[i,j,k]) - res - - [] - [] - module Array4D = - - [] - let length1 (array: 'T[,,,]) = (# "ldlen.multi 4 0" array : int #) - - [] - let length2 (array: 'T[,,,]) = (# "ldlen.multi 4 1" array : int #) - - [] - let length3 (array: 'T[,,,]) = (# "ldlen.multi 4 2" array : int #) - - [] - let length4 (array: 'T[,,,]) = (# "ldlen.multi 4 3" array : int #) - - [] - let zeroCreate length1 length2 length3 length4 = - if length1 < 0 then invalidArgInputMustBeNonNegative "n1" length1 - if length2 < 0 then invalidArgInputMustBeNonNegative "n2" length2 - if length3 < 0 then invalidArgInputMustBeNonNegative "n3" length3 - if length4 < 0 then invalidArgInputMustBeNonNegative "n4" length4 - (# "newarr.multi 4 !0" type ('T) length1 length2 length3 length4 : 'T[,,,] #) - - [] - let create length1 length2 length3 length4 (initial:'T) = - let arr = (zeroCreate length1 length2 length3 length4 : 'T[,,,]) - for i = 0 to length1 - 1 do - for j = 0 to length2 - 1 do - for k = 0 to length3 - 1 do - for m = 0 to length4 - 1 do - arr.[i,j,k,m] <- initial - arr - - [] - let init length1 length2 length3 length4 initializer = - let arr = (zeroCreate length1 length2 length3 length4 : 'T[,,,]) - let f = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(initializer) - for i = 0 to length1 - 1 do - for j = 0 to length2 - 1 do - for k = 0 to length3 - 1 do - for m = 0 to length4 - 1 do - arr.[i,j,k,m] <- f.Invoke(i, j, k, m) - arr - - [] - let get (array: 'T[,,,]) index1 index2 index3 index4 = array.[index1,index2,index3,index4] - - [] - let set (array: 'T[,,,]) index1 index2 index3 index4 value = array.[index1,index2,index3,index4] <- value +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Core.Operators.Checked + +[] +[] +module Array3D = + + let inline checkNonNull argName arg = + if isNull arg then + nullArg argName + + [] + let length1 (array: 'T[,,]) = (# "ldlen.multi 3 0" array : int #) + + [] + let length2 (array: 'T[,,]) = (# "ldlen.multi 3 1" array : int #) + + [] + let length3 (array: 'T[,,]) = (# "ldlen.multi 3 2" array : int #) + + [] + let get (array: 'T[,,]) index1 index2 index3 = array.[index1,index2,index3] + + [] + let set (array: 'T[,,]) index1 index2 index3 value = array.[index1,index2,index3] <- value + + [] + let zeroCreate length1 length2 length3 = + if length1 < 0 then invalidArgInputMustBeNonNegative "n1" length1 + if length2 < 0 then invalidArgInputMustBeNonNegative "n2" length2 + if length3 < 0 then invalidArgInputMustBeNonNegative "n3" length3 + (# "newarr.multi 3 !0" type ('T) length1 length2 length3 : 'T[,,] #) + + [] + let create length1 length2 length3 (initial:'T) = + let arr = (zeroCreate length1 length2 length3 : 'T[,,]) + for i = 0 to length1 - 1 do + for j = 0 to length2 - 1 do + for k = 0 to length3 - 1 do + arr.[i,j,k] <- initial + arr + + [] + let init length1 length2 length3 initializer = + let arr = (zeroCreate length1 length2 length3 : 'T[,,]) + let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(initializer) + for i = 0 to length1 - 1 do + for j = 0 to length2 - 1 do + for k = 0 to length3 - 1 do + arr.[i,j,k] <- f.Invoke(i, j, k) + arr + + [] + let iter action array = + checkNonNull "array" array + let len1 = length1 array + let len2 = length2 array + let len3 = length3 array + for i = 0 to len1 - 1 do + for j = 0 to len2 - 1 do + for k = 0 to len3 - 1 do + action array.[i,j,k] + + [] + let map mapping array = + checkNonNull "array" array + let len1 = length1 array + let len2 = length2 array + let len3 = length3 array + let res = (zeroCreate len1 len2 len3 : 'b[,,]) + for i = 0 to len1 - 1 do + for j = 0 to len2 - 1 do + for k = 0 to len3 - 1 do + res.[i,j,k] <- mapping array.[i,j,k] + res + + [] + let iteri action array = + checkNonNull "array" array + let len1 = length1 array + let len2 = length2 array + let len3 = length3 array + let f = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(action) + for i = 0 to len1 - 1 do + for j = 0 to len2 - 1 do + for k = 0 to len3 - 1 do + f.Invoke(i, j, k, array.[i,j,k]) + + [] + let mapi mapping array = + checkNonNull "array" array + let len1 = length1 array + let len2 = length2 array + let len3 = length3 array + let res = (zeroCreate len1 len2 len3 : 'b[,,]) + let f = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(mapping) + for i = 0 to len1 - 1 do + for j = 0 to len2 - 1 do + for k = 0 to len3 - 1 do + res.[i,j,k] <- f.Invoke(i, j, k, array.[i,j,k]) + res + +[] +[] +module Array4D = + + [] + let length1 (array: 'T[,,,]) = (# "ldlen.multi 4 0" array : int #) + + [] + let length2 (array: 'T[,,,]) = (# "ldlen.multi 4 1" array : int #) + + [] + let length3 (array: 'T[,,,]) = (# "ldlen.multi 4 2" array : int #) + + [] + let length4 (array: 'T[,,,]) = (# "ldlen.multi 4 3" array : int #) + + [] + let zeroCreate length1 length2 length3 length4 = + if length1 < 0 then invalidArgInputMustBeNonNegative "n1" length1 + if length2 < 0 then invalidArgInputMustBeNonNegative "n2" length2 + if length3 < 0 then invalidArgInputMustBeNonNegative "n3" length3 + if length4 < 0 then invalidArgInputMustBeNonNegative "n4" length4 + (# "newarr.multi 4 !0" type ('T) length1 length2 length3 length4 : 'T[,,,] #) + + [] + let create length1 length2 length3 length4 (initial:'T) = + let arr = (zeroCreate length1 length2 length3 length4 : 'T[,,,]) + for i = 0 to length1 - 1 do + for j = 0 to length2 - 1 do + for k = 0 to length3 - 1 do + for m = 0 to length4 - 1 do + arr.[i,j,k,m] <- initial + arr + + [] + let init length1 length2 length3 length4 initializer = + let arr = (zeroCreate length1 length2 length3 length4 : 'T[,,,]) + let f = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(initializer) + for i = 0 to length1 - 1 do + for j = 0 to length2 - 1 do + for k = 0 to length3 - 1 do + for m = 0 to length4 - 1 do + arr.[i,j,k,m] <- f.Invoke(i, j, k, m) + arr + + [] + let get (array: 'T[,,,]) index1 index2 index3 index4 = array.[index1,index2,index3,index4] + + [] + let set (array: 'T[,,,]) index1 index2 index3 index4 value = array.[index1,index2,index3,index4] <- value diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index 0620810dac8ece8a2d2900683e6ef979e2c7dd66..73a229670b390d800e9ff6349bfe590d90609fcb 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -2,1613 +2,1674 @@ namespace Microsoft.FSharp.Control - #nowarn "40" - #nowarn "52" // The value has been copied to ensure the original is not mutated by this operation +#nowarn "40" +#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation - open System - open System.Diagnostics - open System.Reflection - open System.Runtime.CompilerServices - open System.Runtime.ExceptionServices - open System.Threading - open System.Threading.Tasks - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Control - open Microsoft.FSharp.Collections +open System +open System.Diagnostics +open System.Reflection +open System.Runtime.CompilerServices +open System.Runtime.ExceptionServices +open System.Threading +open System.Threading.Tasks +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections - type LinkedSubSource(cancellationToken: CancellationToken) = +type LinkedSubSource(cancellationToken: CancellationToken) = - let failureCTS = new CancellationTokenSource() + let failureCTS = new CancellationTokenSource() - let linkedCTS = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, failureCTS.Token) + let linkedCTS = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, failureCTS.Token) - member _.Token = linkedCTS.Token + member _.Token = linkedCTS.Token - member _.Cancel() = failureCTS.Cancel() + member _.Cancel() = failureCTS.Cancel() - member _.Dispose() = - linkedCTS.Dispose() - failureCTS.Dispose() + member _.Dispose() = + linkedCTS.Dispose() + failureCTS.Dispose() - interface IDisposable with - member this.Dispose() = this.Dispose() - - /// Global mutable state used to associate Exception - [] - module ExceptionDispatchInfoHelpers = - - let associationTable = ConditionalWeakTable() - - type ExceptionDispatchInfo with - - member edi.GetAssociatedSourceException() = - let exn = edi.SourceException - // Try to store the entry in the association table to allow us to recover it later. - try associationTable.Add(exn, edi) with _ -> () - exn - - // Capture, but prefer the saved information if available - [] - static member RestoreOrCapture exn = - match associationTable.TryGetValue exn with - | true, edi -> edi - | _ -> - ExceptionDispatchInfo.Capture exn - - member inline edi.ThrowAny() = - edi.Throw() - Unchecked.defaultof<'T> // Note, this line should not be reached, but gives a generic return type - - // F# don't always take tailcalls to functions returning 'unit' because this - // is represented as type 'void' in the underlying IL. - // Hence we don't use the 'unit' return type here, and instead invent our own type. - [] - type AsyncReturn = - | AsyncReturn - with - static member inline Fake() = Unchecked.defaultof - - type cont<'T> = ('T -> AsyncReturn) - type econt = (ExceptionDispatchInfo -> AsyncReturn) - type ccont = (OperationCanceledException -> AsyncReturn) - - [] - type Trampoline() = + interface IDisposable with + member this.Dispose() = this.Dispose() - [] - static let bindLimitBeforeHijack = 300 +/// Global mutable state used to associate Exception +[] +module ExceptionDispatchInfoHelpers = - [] - static val mutable private thisThreadHasTrampoline: bool + let associationTable = ConditionalWeakTable() - static member ThisThreadHasTrampoline = - Trampoline.thisThreadHasTrampoline + type ExceptionDispatchInfo with - let mutable storedCont = None - let mutable storedExnCont = None - let mutable bindCount = 0 + member edi.GetAssociatedSourceException() = + let exn = edi.SourceException + // Try to store the entry in the association table to allow us to recover it later. + try associationTable.Add(exn, edi) with _ -> () + exn - /// Use this trampoline on the synchronous stack if none exists, and execute - /// the given function. The function might write its continuation into the trampoline. + // Capture, but prefer the saved information if available [] - member _.Execute (firstAction: unit -> AsyncReturn) = - - let thisThreadHadTrampoline = Trampoline.thisThreadHasTrampoline - Trampoline.thisThreadHasTrampoline <- true - try - let mutable keepGoing = true - let mutable action = firstAction - while keepGoing do - try - action() |> ignore - match storedCont with - | None -> - keepGoing <- false - | Some cont -> - storedCont <- None - action <- cont - - // Catch exceptions at the trampoline to get a full .StackTrace entry - // This is because of this problem https://stackoverflow.com/questions/5301535/exception-call-stack-truncated-without-any-re-throwing - // where only a limited number of stack frames are included in the .StackTrace property - // of a .NET exception when it is thrown, up to the first catch handler. - // - // So when running async code, there aren't any intermediate catch handlers (though there - // may be intermediate try/finally frames), there is just this one catch handler at the - // base of the stack. - // - // If an exception is thrown we must have storedExnCont via OnExceptionRaised. - with exn -> - match storedExnCont with - | None -> - // Here, the exception escapes the trampoline. This should not happen since all - // exception-generating code should use ProtectCode. However some - // direct uses of combinators (not using async {...}) may cause - // code to execute unprotected, e.g. async.While((fun () -> failwith ".."), ...) executes the first - // guardExpr unprotected. - reraise() - - | Some econt -> - storedExnCont <- None - let edi = ExceptionDispatchInfo.RestoreOrCapture exn - action <- (fun () -> econt edi) - - finally - Trampoline.thisThreadHasTrampoline <- thisThreadHadTrampoline - AsyncReturn.Fake() - - /// Increment the counter estimating the size of the synchronous stack and - /// return true if time to jump on trampoline. - member _.IncrementBindCount() = - bindCount <- bindCount + 1 - bindCount >= bindLimitBeforeHijack - - /// Prepare to abandon the synchronous stack of the current execution and save the continuation in the trampoline. - member _.Set action = - assert storedCont.IsNone - bindCount <- 0 - storedCont <- Some action - AsyncReturn.Fake() - - /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member _.OnExceptionRaised (action: econt) = - assert storedExnCont.IsNone - storedExnCont <- Some action - - type TrampolineHolder() = - let mutable trampoline = null - - // On-demand allocate this delegate and keep it in the trampoline holder. - let mutable sendOrPostCallbackWithTrampoline : SendOrPostCallback = null - let getSendOrPostCallbackWithTrampoline(this: TrampolineHolder) = - match sendOrPostCallbackWithTrampoline with - | null -> - sendOrPostCallbackWithTrampoline <- - SendOrPostCallback (fun o -> + static member RestoreOrCapture exn = + match associationTable.TryGetValue exn with + | true, edi -> edi + | _ -> + ExceptionDispatchInfo.Capture exn + + member inline edi.ThrowAny() = + edi.Throw() + Unchecked.defaultof<'T> // Note, this line should not be reached, but gives a generic return type + +// F# don't always take tailcalls to functions returning 'unit' because this +// is represented as type 'void' in the underlying IL. +// Hence we don't use the 'unit' return type here, and instead invent our own type. +[] +type AsyncReturn = + | AsyncReturn + with + static member inline Fake() = Unchecked.defaultof + +type cont<'T> = ('T -> AsyncReturn) +type econt = (ExceptionDispatchInfo -> AsyncReturn) +type ccont = (OperationCanceledException -> AsyncReturn) + +[] +type Trampoline() = + + [] + static let bindLimitBeforeHijack = 300 + + [] + static val mutable private thisThreadHasTrampoline: bool + + static member ThisThreadHasTrampoline = + Trampoline.thisThreadHasTrampoline + + let mutable storedCont = None + let mutable storedExnCont = None + let mutable bindCount = 0 + + /// Use this trampoline on the synchronous stack if none exists, and execute + /// the given function. The function might write its continuation into the trampoline. + [] + member _.Execute (firstAction: unit -> AsyncReturn) = + + let thisThreadHadTrampoline = Trampoline.thisThreadHasTrampoline + Trampoline.thisThreadHasTrampoline <- true + try + let mutable keepGoing = true + let mutable action = firstAction + while keepGoing do + try + action() |> ignore + match storedCont with + | None -> + keepGoing <- false + | Some cont -> + storedCont <- None + action <- cont + + // Catch exceptions at the trampoline to get a full .StackTrace entry + // This is because of this problem https://stackoverflow.com/questions/5301535/exception-call-stack-truncated-without-any-re-throwing + // where only a limited number of stack frames are included in the .StackTrace property + // of a .NET exception when it is thrown, up to the first catch handler. + // + // So when running async code, there aren't any intermediate catch handlers (though there + // may be intermediate try/finally frames), there is just this one catch handler at the + // base of the stack. + // + // If an exception is thrown we must have storedExnCont via OnExceptionRaised. + with exn -> + match storedExnCont with + | None -> + // Here, the exception escapes the trampoline. This should not happen since all + // exception-generating code should use ProtectCode. However some + // direct uses of combinators (not using async {...}) may cause + // code to execute unprotected, e.g. async.While((fun () -> failwith ".."), ...) executes the first + // guardExpr unprotected. + reraise() + + | Some econt -> + storedExnCont <- None + let edi = ExceptionDispatchInfo.RestoreOrCapture exn + action <- (fun () -> econt edi) + + finally + Trampoline.thisThreadHasTrampoline <- thisThreadHadTrampoline + AsyncReturn.Fake() + + /// Increment the counter estimating the size of the synchronous stack and + /// return true if time to jump on trampoline. + member _.IncrementBindCount() = + bindCount <- bindCount + 1 + bindCount >= bindLimitBeforeHijack + + /// Prepare to abandon the synchronous stack of the current execution and save the continuation in the trampoline. + member _.Set action = + assert storedCont.IsNone + bindCount <- 0 + storedCont <- Some action + AsyncReturn.Fake() + + /// Save the exception continuation during propagation of an exception, or prior to raising an exception + member _.OnExceptionRaised (action: econt) = + assert storedExnCont.IsNone + storedExnCont <- Some action + +type TrampolineHolder() = + let mutable trampoline = null + + // On-demand allocate this delegate and keep it in the trampoline holder. + let mutable sendOrPostCallbackWithTrampoline : SendOrPostCallback = null + let getSendOrPostCallbackWithTrampoline(this: TrampolineHolder) = + match sendOrPostCallbackWithTrampoline with + | null -> + sendOrPostCallbackWithTrampoline <- + SendOrPostCallback (fun o -> + let f = unbox AsyncReturn> o + // Reminder: the ignore below ignores an AsyncReturn. + this.ExecuteWithTrampoline f |> ignore) + | _ -> () + sendOrPostCallbackWithTrampoline + + // On-demand allocate this delegate and keep it in the trampoline holder. + let mutable waitCallbackForQueueWorkItemWithTrampoline : WaitCallback = null + let getWaitCallbackForQueueWorkItemWithTrampoline(this: TrampolineHolder) = + match waitCallbackForQueueWorkItemWithTrampoline with + | null -> + waitCallbackForQueueWorkItemWithTrampoline <- + WaitCallback (fun o -> let f = unbox AsyncReturn> o - // Reminder: the ignore below ignores an AsyncReturn. this.ExecuteWithTrampoline f |> ignore) - | _ -> () - sendOrPostCallbackWithTrampoline - - // On-demand allocate this delegate and keep it in the trampoline holder. - let mutable waitCallbackForQueueWorkItemWithTrampoline : WaitCallback = null - let getWaitCallbackForQueueWorkItemWithTrampoline(this: TrampolineHolder) = - match waitCallbackForQueueWorkItemWithTrampoline with - | null -> - waitCallbackForQueueWorkItemWithTrampoline <- - WaitCallback (fun o -> - let f = unbox AsyncReturn> o - this.ExecuteWithTrampoline f |> ignore) - | _ -> () - waitCallbackForQueueWorkItemWithTrampoline - - // On-demand allocate this delegate and keep it in the trampoline holder. - let mutable threadStartCallbackForStartThreadWithTrampoline : ParameterizedThreadStart = null - let getThreadStartCallbackForStartThreadWithTrampoline(this: TrampolineHolder) = - match threadStartCallbackForStartThreadWithTrampoline with - | null -> - threadStartCallbackForStartThreadWithTrampoline <- - ParameterizedThreadStart (fun o -> - let f = unbox AsyncReturn> o - this.ExecuteWithTrampoline f |> ignore) - | _ -> () - threadStartCallbackForStartThreadWithTrampoline - - /// Execute an async computation after installing a trampoline on its synchronous stack. - [] - member _.ExecuteWithTrampoline firstAction = - trampoline <- Trampoline() - trampoline.Execute firstAction - - member this.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = - syncCtxt.Post (getSendOrPostCallbackWithTrampoline(this), state=(f |> box)) - AsyncReturn.Fake() - - member this.QueueWorkItemWithTrampoline (f: unit -> AsyncReturn) = - if not (ThreadPool.QueueUserWorkItem(getWaitCallbackForQueueWorkItemWithTrampoline(this), f |> box)) then - failwith "failed to queue user work item" - AsyncReturn.Fake() - - member this.PostOrQueueWithTrampoline (syncCtxt: SynchronizationContext) f = - match syncCtxt with - | null -> this.QueueWorkItemWithTrampoline f - | _ -> this.PostWithTrampoline syncCtxt f - - // This should be the only call to Thread.Start in this library. We must always install a trampoline. - member this.StartThreadWithTrampoline (f: unit -> AsyncReturn) = - Thread(getThreadStartCallbackForStartThreadWithTrampoline(this), IsBackground=true).Start(f|>box) - AsyncReturn.Fake() - - /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member inline _.OnExceptionRaised econt = - trampoline.OnExceptionRaised econt - - /// Call a continuation, but first check if an async computation should trampoline on its synchronous stack. - member inline _.HijackCheckThenCall (cont: 'T -> AsyncReturn) res = - if trampoline.IncrementBindCount() then - trampoline.Set (fun () -> cont res) - else - // NOTE: this must be a tailcall - cont res - - /// Represents rarely changing components of an in-flight async computation - [] - [] - type AsyncActivationAux = - { /// The active cancellation token - token: CancellationToken - - /// The exception continuation - econt: econt - - /// The cancellation continuation - ccont: ccont - - /// Holds some commonly-allocated callbacks and a mutable location to use for a trampoline - trampolineHolder: TrampolineHolder } - - /// Represents context for an in-flight async computation - [] - [] - type AsyncActivationContents<'T> = - { /// The success continuation - cont: cont<'T> - - /// The rarely changing components - aux: AsyncActivationAux } - - /// A struct wrapper around AsyncActivationContents. Using a struct wrapper allows us to change representation of the - /// contents at a later point, e.g. to change the contents to a .NET Task or some other representation. - [] - type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = - - /// Produce a new execution context for a composite async - member ctxt.WithCancellationContinuation ccont = AsyncActivation<'T> { contents with aux = { ctxt.aux with ccont = ccont } } - - /// Produce a new execution context for a composite async - member ctxt.WithExceptionContinuation econt = AsyncActivation<'T> { contents with aux = { ctxt.aux with econt = econt } } - - /// Produce a new execution context for a composite async - member _.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } - - /// Produce a new execution context for a composite async - member _.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } - - /// Produce a new execution context for a composite async - member ctxt.WithContinuations(cont, econt, ccont) = AsyncActivation<'T> { contents with cont = cont; aux = { ctxt.aux with econt = econt; ccont = ccont } } - - /// The extra information relevant to the execution of the async - member _.aux = contents.aux - - /// The success continuation relevant to the execution of the async - member _.cont = contents.cont - - /// The exception continuation relevant to the execution of the async - member _.econt = contents.aux.econt - - /// The cancellation continuation relevant to the execution of the async - member _.ccont = contents.aux.ccont + | _ -> () + waitCallbackForQueueWorkItemWithTrampoline + + // On-demand allocate this delegate and keep it in the trampoline holder. + let mutable threadStartCallbackForStartThreadWithTrampoline : ParameterizedThreadStart = null + let getThreadStartCallbackForStartThreadWithTrampoline(this: TrampolineHolder) = + match threadStartCallbackForStartThreadWithTrampoline with + | null -> + threadStartCallbackForStartThreadWithTrampoline <- + ParameterizedThreadStart (fun o -> + let f = unbox AsyncReturn> o + this.ExecuteWithTrampoline f |> ignore) + | _ -> () + threadStartCallbackForStartThreadWithTrampoline - /// The cancellation token relevant to the execution of the async - member _.token = contents.aux.token + /// Execute an async computation after installing a trampoline on its synchronous stack. + [] + member _.ExecuteWithTrampoline firstAction = + trampoline <- Trampoline() + trampoline.Execute firstAction - /// The trampoline holder being used to protect execution of the async - member _.trampolineHolder = contents.aux.trampolineHolder + member this.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = + syncCtxt.Post (getSendOrPostCallbackWithTrampoline(this), state=(f |> box)) + AsyncReturn.Fake() - /// Check if cancellation has been requested - member _.IsCancellationRequested = contents.aux.token.IsCancellationRequested + member this.QueueWorkItemWithTrampoline (f: unit -> AsyncReturn) = + if not (ThreadPool.QueueUserWorkItem(getWaitCallbackForQueueWorkItemWithTrampoline(this), f |> box)) then + failwith "failed to queue user work item" + AsyncReturn.Fake() - /// Call the cancellation continuation of the active computation - member _.OnCancellation () = - contents.aux.ccont (OperationCanceledException (contents.aux.token)) + member this.PostOrQueueWithTrampoline (syncCtxt: SynchronizationContext) f = + match syncCtxt with + | null -> this.QueueWorkItemWithTrampoline f + | _ -> this.PostWithTrampoline syncCtxt f + + // This should be the only call to Thread.Start in this library. We must always install a trampoline. + member this.StartThreadWithTrampoline (f: unit -> AsyncReturn) = + Thread(getThreadStartCallbackForStartThreadWithTrampoline(this), IsBackground=true).Start(f|>box) + AsyncReturn.Fake() + + /// Save the exception continuation during propagation of an exception, or prior to raising an exception + member inline _.OnExceptionRaised econt = + trampoline.OnExceptionRaised econt + + /// Call a continuation, but first check if an async computation should trampoline on its synchronous stack. + member inline _.HijackCheckThenCall (cont: 'T -> AsyncReturn) res = + if trampoline.IncrementBindCount() then + trampoline.Set (fun () -> cont res) + else + // NOTE: this must be a tailcall + cont res + +/// Represents rarely changing components of an in-flight async computation +[] +[] +type AsyncActivationAux = + { /// The active cancellation token + token: CancellationToken + + /// The exception continuation + econt: econt + + /// The cancellation continuation + ccont: ccont + + /// Holds some commonly-allocated callbacks and a mutable location to use for a trampoline + trampolineHolder: TrampolineHolder } + +/// Represents context for an in-flight async computation +[] +[] +type AsyncActivationContents<'T> = + { /// The success continuation + cont: cont<'T> + + /// The rarely changing components + aux: AsyncActivationAux } + +/// A struct wrapper around AsyncActivationContents. Using a struct wrapper allows us to change representation of the +/// contents at a later point, e.g. to change the contents to a .NET Task or some other representation. +[] +type AsyncActivation<'T>(contents: AsyncActivationContents<'T>) = + + /// Produce a new execution context for a composite async + member ctxt.WithCancellationContinuation ccont = AsyncActivation<'T> { contents with aux = { ctxt.aux with ccont = ccont } } + + /// Produce a new execution context for a composite async + member ctxt.WithExceptionContinuation econt = AsyncActivation<'T> { contents with aux = { ctxt.aux with econt = econt } } + + /// Produce a new execution context for a composite async + member _.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } + + /// Produce a new execution context for a composite async + member _.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } + + /// Produce a new execution context for a composite async + member ctxt.WithContinuations(cont, econt, ccont) = AsyncActivation<'T> { contents with cont = cont; aux = { ctxt.aux with econt = econt; ccont = ccont } } + + /// The extra information relevant to the execution of the async + member _.aux = contents.aux + + /// The success continuation relevant to the execution of the async + member _.cont = contents.cont + + /// The exception continuation relevant to the execution of the async + member _.econt = contents.aux.econt + + /// The cancellation continuation relevant to the execution of the async + member _.ccont = contents.aux.ccont + + /// The cancellation token relevant to the execution of the async + member _.token = contents.aux.token + + /// The trampoline holder being used to protect execution of the async + member _.trampolineHolder = contents.aux.trampolineHolder + + /// Check if cancellation has been requested + member _.IsCancellationRequested = contents.aux.token.IsCancellationRequested + + /// Call the cancellation continuation of the active computation + member _.OnCancellation () = + contents.aux.ccont (OperationCanceledException (contents.aux.token)) + + /// Check for trampoline hijacking. + // + // Note, this must make tailcalls, so may not be an instance member taking a byref argument, + // nor call any members taking byref arguments. + static member inline HijackCheckThenCall (ctxt: AsyncActivation<'T>) cont arg = + ctxt.aux.trampolineHolder.HijackCheckThenCall cont arg + + /// Call the success continuation of the asynchronous execution context after checking for + /// cancellation and trampoline hijacking. + // - Cancellation check + // - Hijack check + // + // Note, this must make tailcalls, so may not be an instance member taking a byref argument. + static member Success (ctxt: AsyncActivation<'T>) result = + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.cont result + + // For backwards API Compat + [] + member ctxt.OnSuccess (result: 'T) = AsyncActivation<'T>.Success ctxt result + + /// Save the exception continuation during propagation of an exception, or prior to raising an exception + member _.OnExceptionRaised() = + contents.aux.trampolineHolder.OnExceptionRaised contents.aux.econt + + /// Make an initial async activation. + static member Create cancellationToken trampolineHolder cont econt ccont : AsyncActivation<'T> = + AsyncActivation { cont = cont; aux = { token = cancellationToken; econt = econt; ccont = ccont; trampolineHolder = trampolineHolder } } + + /// Queue the success continuation of the asynchronous execution context as a work item in the thread pool + /// after installing a trampoline + member ctxt.QueueContinuationWithTrampoline (result: 'T) = + let cont = ctxt.cont + ctxt.aux.trampolineHolder.QueueWorkItemWithTrampoline(fun () -> cont result) + + /// Ensure that any exceptions raised by the immediate execution of "userCode" + /// are sent to the exception continuation. This is done by allowing the exception to propagate + /// to the trampoline, and the saved exception continuation is called there. + /// + /// It is also valid for MakeAsync primitive code to call the exception continuation directly. + [] + member ctxt.ProtectCode userCode = + let mutable ok = false + try + let res = userCode() + ok <- true + res + finally + if not ok then + ctxt.OnExceptionRaised() + + member ctxt.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = + let holder = contents.aux.trampolineHolder + ctxt.ProtectCode (fun () -> holder.PostWithTrampoline syncCtxt f) + + /// Call the success continuation of the asynchronous execution context + member ctxt.CallContinuation(result: 'T) = + ctxt.cont result + +/// Represents an asynchronous computation +[] +type Async<'T> = + { Invoke: (AsyncActivation<'T> -> AsyncReturn) } + +/// Mutable register to help ensure that code is only executed once +[] +type Latch() = + let mutable i = 0 + + /// Execute the latch + member _.Enter() = Interlocked.CompareExchange(&i, 1, 0) = 0 + +/// Represents the result of an asynchronous computation +[] +type AsyncResult<'T> = + | Ok of 'T + | Error of ExceptionDispatchInfo + | Canceled of OperationCanceledException + + /// Get the result of an asynchronous computation + [] + member res.Commit () = + match res with + | AsyncResult.Ok res -> res + | AsyncResult.Error edi -> edi.ThrowAny() + | AsyncResult.Canceled exn -> raise exn + +/// Primitives to execute asynchronous computations +module AsyncPrimitives = + + let inline fake () = Unchecked.defaultof + + let inline unfake (_: AsyncReturn) = () + + /// The mutable global CancellationTokenSource, see Async.DefaultCancellationToken + let mutable defaultCancellationTokenSource = new CancellationTokenSource() + + /// Primitive to invoke an async computation. + // + // Note: direct calls to this function may end up in user assemblies via inlining + [] + let Invoke (computation: Async<'T>) (ctxt: AsyncActivation<_>) : AsyncReturn = + AsyncActivation<'T>.HijackCheckThenCall ctxt computation.Invoke ctxt + + /// Apply 'userCode' to 'arg'. If no exception is raised then call the normal continuation. Used to implement + /// 'finally' and 'when cancelled'. + /// + /// - Apply 'userCode' to argument with exception protection + /// - Hijack check before invoking the continuation + [] + let CallThenContinue userCode arg (ctxt: AsyncActivation<_>) : AsyncReturn = + let mutable result = Unchecked.defaultof<_> + let mutable ok = false + + try + result <- userCode arg + ok <- true + finally + if not ok then + ctxt.OnExceptionRaised() + + if ok then + AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.cont result + else + fake() + + /// Apply 'part2' to 'result1' and invoke the resulting computation. + /// + /// Note: direct calls to this function end up in user assemblies via inlining + /// + /// - Apply 'part2' to argument with exception protection + /// - Hijack check before invoking the resulting computation + [] + let CallThenInvoke (ctxt: AsyncActivation<_>) result1 part2 : AsyncReturn = + let mutable result = Unchecked.defaultof<_> + let mutable ok = false + + try + result <- part2 result1 + ok <- true + finally + if not ok then + ctxt.OnExceptionRaised() + + if ok then + Invoke result ctxt + else + fake() + + /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) + [] + let CallThenInvokeNoHijackCheck (ctxt: AsyncActivation<_>) result1 userCode = + let mutable res = Unchecked.defaultof<_> + let mutable ok = false + + try + res <- userCode result1 + ok <- true + finally + if not ok then + ctxt.OnExceptionRaised() + + if ok then + res.Invoke ctxt + else + fake() + + /// Apply 'filterFunction' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' + /// then send 'result1' to the exception continuation. + /// + /// - Apply 'filterFunction' to argument with exception protection + /// - Hijack check before invoking the resulting computation or exception continuation + [] + let CallFilterThenInvoke (ctxt: AsyncActivation<'T>) filterFunction (edi: ExceptionDispatchInfo) : AsyncReturn = + let mutable resOpt = None + let mutable ok = false + + try + resOpt <- filterFunction (edi.GetAssociatedSourceException()) + ok <- true + finally + if not ok then + ctxt.OnExceptionRaised() + + if ok then + match resOpt with + | None -> + AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.econt edi + | Some res -> + Invoke res ctxt + else + fake() - /// Check for trampoline hijacking. - // - // Note, this must make tailcalls, so may not be an instance member taking a byref argument, - // nor call any members taking byref arguments. - static member inline HijackCheckThenCall (ctxt: AsyncActivation<'T>) cont arg = - ctxt.aux.trampolineHolder.HijackCheckThenCall cont arg + /// Build a primitive without any exception or resync protection + [] + let MakeAsync body = { Invoke = body } - /// Call the success continuation of the asynchronous execution context after checking for - /// cancellation and trampoline hijacking. - // - Cancellation check - // - Hijack check - // - // Note, this must make tailcalls, so may not be an instance member taking a byref argument. - static member Success (ctxt: AsyncActivation<'T>) result = + [] + let MakeAsyncWithCancelCheck body = + MakeAsync (fun ctxt -> if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.cont result - - // For backwards API Compat - [] - member ctxt.OnSuccess (result: 'T) = AsyncActivation<'T>.Success ctxt result - - /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member _.OnExceptionRaised() = - contents.aux.trampolineHolder.OnExceptionRaised contents.aux.econt - - /// Make an initial async activation. - static member Create cancellationToken trampolineHolder cont econt ccont : AsyncActivation<'T> = - AsyncActivation { cont = cont; aux = { token = cancellationToken; econt = econt; ccont = ccont; trampolineHolder = trampolineHolder } } - - /// Queue the success continuation of the asynchronous execution context as a work item in the thread pool - /// after installing a trampoline - member ctxt.QueueContinuationWithTrampoline (result: 'T) = - let cont = ctxt.cont - ctxt.aux.trampolineHolder.QueueWorkItemWithTrampoline(fun () -> cont result) - - /// Ensure that any exceptions raised by the immediate execution of "userCode" - /// are sent to the exception continuation. This is done by allowing the exception to propagate - /// to the trampoline, and the saved exception continuation is called there. - /// - /// It is also valid for MakeAsync primitive code to call the exception continuation directly. - [] - member ctxt.ProtectCode userCode = - let mutable ok = false - try - let res = userCode() - ok <- true - res - finally - if not ok then - ctxt.OnExceptionRaised() - - member ctxt.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = - let holder = contents.aux.trampolineHolder - ctxt.ProtectCode (fun () -> holder.PostWithTrampoline syncCtxt f) - - /// Call the success continuation of the asynchronous execution context - member ctxt.CallContinuation(result: 'T) = - ctxt.cont result - - /// Represents an asynchronous computation - [] - type Async<'T> = - { Invoke: (AsyncActivation<'T> -> AsyncReturn) } - - /// Mutable register to help ensure that code is only executed once - [] - type Latch() = - let mutable i = 0 - - /// Execute the latch - member _.Enter() = Interlocked.CompareExchange(&i, 1, 0) = 0 + body ctxt) + + /// Execute part1, then apply part2, then execute the result of that + /// + /// Note: direct calls to this function end up in user assemblies via inlining + /// - Initial cancellation check + /// - Initial hijack check (see Invoke) + /// - No hijack check after applying 'part2' to argument (see CallThenInvoke) + /// - No cancellation check after applying 'part2' to argument (see CallThenInvoke) + /// - Apply 'part2' to argument with exception protection (see CallThenInvoke) + [] + let Bind (ctxt: AsyncActivation<'T>) (part1: Async<'U>) (part2: 'U -> Async<'T>) : AsyncReturn = + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + // Note, no cancellation check is done before calling 'part2'. This is + // because part1 may bind a resource, while part2 is a try/finally, and, if + // the resource creation completes, we want to enter part2 before cancellation takes effect. + Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvokeNoHijackCheck ctxt result1 part2)) + + /// Re-route all continuations to execute the finally function. + /// - Cancellation check after 'entering' the try/finally and before running the body + /// - Hijack check after 'entering' the try/finally and before running the body (see Invoke) + /// - Run 'finallyFunction' with exception protection (see CallThenContinue) + /// - Hijack check before any of the continuations (see CallThenContinue) + [] + let TryFinally (ctxt: AsyncActivation<'T>) (computation: Async<'T>) finallyFunction = + // Note, we don't test for cancellation before entering a try/finally. This prevents + // a resource being created without being disposed. + + // The new continuation runs the finallyFunction and resumes the old continuation + // If an exception is thrown we continue with the previous exception continuation. + let cont result = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) + + // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. + // If an exception is thrown we continue with the previous exception continuation. + let econt edi = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt edi)) + + // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. + // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) + let ccont cexn = + CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) + + let ctxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + computation.Invoke ctxt + + /// Re-route the exception continuation to call to catchFunction. If catchFunction returns None then call the exception continuation. + /// If it returns Some, invoke the resulting async. + /// - Cancellation check before entering the try + /// - No hijack check after 'entering' the try/with + /// - Cancellation check before applying the 'catchFunction' + /// - Apply `catchFunction' to argument with exception protection (see CallFilterThenInvoke) + /// - Hijack check before invoking the resulting computation or exception continuation (see CallFilterThenInvoke) + [] + let TryWith (ctxt: AsyncActivation<'T>) (computation: Async<'T>) catchFunction = + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + let ctxt = + ctxt.WithExceptionContinuation(fun edi -> + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + CallFilterThenInvoke ctxt catchFunction edi) - /// Represents the result of an asynchronous computation - [] - type AsyncResult<'T> = - | Ok of 'T - | Error of ExceptionDispatchInfo - | Canceled of OperationCanceledException + computation.Invoke ctxt - /// Get the result of an asynchronous computation - [] - member res.Commit () = + /// Make an async for an AsyncResult + // - No cancellation check + // - No hijack check + let CreateAsyncResultAsync res = + MakeAsync (fun ctxt -> match res with - | AsyncResult.Ok res -> res - | AsyncResult.Error edi -> edi.ThrowAny() - | AsyncResult.Canceled exn -> raise exn - - /// Primitives to execute asynchronous computations - module AsyncPrimitives = - - let inline fake () = Unchecked.defaultof - - let inline unfake (_: AsyncReturn) = () - - /// The mutable global CancellationTokenSource, see Async.DefaultCancellationToken - let mutable defaultCancellationTokenSource = new CancellationTokenSource() - - /// Primitive to invoke an async computation. - // - // Note: direct calls to this function may end up in user assemblies via inlining - [] - let Invoke (computation: Async<'T>) (ctxt: AsyncActivation<_>) : AsyncReturn = - AsyncActivation<'T>.HijackCheckThenCall ctxt computation.Invoke ctxt - - /// Apply 'userCode' to 'arg'. If no exception is raised then call the normal continuation. Used to implement - /// 'finally' and 'when cancelled'. - /// - /// - Apply 'userCode' to argument with exception protection - /// - Hijack check before invoking the continuation - [] - let CallThenContinue userCode arg (ctxt: AsyncActivation<_>) : AsyncReturn = - let mutable result = Unchecked.defaultof<_> - let mutable ok = false - - try - result <- userCode arg - ok <- true - finally - if not ok then - ctxt.OnExceptionRaised() - - if ok then - AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.cont result - else - fake() - - /// Apply 'part2' to 'result1' and invoke the resulting computation. - /// - /// Note: direct calls to this function end up in user assemblies via inlining - /// - /// - Apply 'part2' to argument with exception protection - /// - Hijack check before invoking the resulting computation - [] - let CallThenInvoke (ctxt: AsyncActivation<_>) result1 part2 : AsyncReturn = - let mutable result = Unchecked.defaultof<_> - let mutable ok = false - - try - result <- part2 result1 - ok <- true - finally - if not ok then - ctxt.OnExceptionRaised() - - if ok then - Invoke result ctxt - else - fake() - - /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) - [] - let CallThenInvokeNoHijackCheck (ctxt: AsyncActivation<_>) result1 userCode = - let mutable res = Unchecked.defaultof<_> - let mutable ok = false - - try - res <- userCode result1 - ok <- true - finally - if not ok then - ctxt.OnExceptionRaised() - - if ok then - res.Invoke ctxt - else - fake() - - /// Apply 'filterFunction' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' - /// then send 'result1' to the exception continuation. - /// - /// - Apply 'filterFunction' to argument with exception protection - /// - Hijack check before invoking the resulting computation or exception continuation - [] - let CallFilterThenInvoke (ctxt: AsyncActivation<'T>) filterFunction (edi: ExceptionDispatchInfo) : AsyncReturn = - let mutable resOpt = None - let mutable ok = false - - try - resOpt <- filterFunction (edi.GetAssociatedSourceException()) - ok <- true - finally - if not ok then - ctxt.OnExceptionRaised() - - if ok then - match resOpt with - | None -> - AsyncActivation<'T>.HijackCheckThenCall ctxt ctxt.econt edi - | Some res -> - Invoke res ctxt - else - fake() - - /// Build a primitive without any exception or resync protection - [] - let MakeAsync body = { Invoke = body } - - [] - let MakeAsyncWithCancelCheck body = - MakeAsync (fun ctxt -> - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - body ctxt) - - /// Execute part1, then apply part2, then execute the result of that - /// - /// Note: direct calls to this function end up in user assemblies via inlining - /// - Initial cancellation check - /// - Initial hijack check (see Invoke) - /// - No hijack check after applying 'part2' to argument (see CallThenInvoke) - /// - No cancellation check after applying 'part2' to argument (see CallThenInvoke) - /// - Apply 'part2' to argument with exception protection (see CallThenInvoke) - [] - let Bind (ctxt: AsyncActivation<'T>) (part1: Async<'U>) (part2: 'U -> Async<'T>) : AsyncReturn = - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - // Note, no cancellation check is done before calling 'part2'. This is - // because part1 may bind a resource, while part2 is a try/finally, and, if - // the resource creation completes, we want to enter part2 before cancellation takes effect. - Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvokeNoHijackCheck ctxt result1 part2)) - - /// Re-route all continuations to execute the finally function. - /// - Cancellation check after 'entering' the try/finally and before running the body - /// - Hijack check after 'entering' the try/finally and before running the body (see Invoke) - /// - Run 'finallyFunction' with exception protection (see CallThenContinue) - /// - Hijack check before any of the continuations (see CallThenContinue) - [] - let TryFinally (ctxt: AsyncActivation<'T>) (computation: Async<'T>) finallyFunction = - // Note, we don't test for cancellation before entering a try/finally. This prevents - // a resource being created without being disposed. - - // The new continuation runs the finallyFunction and resumes the old continuation - // If an exception is thrown we continue with the previous exception continuation. - let cont result = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) - - // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. - // If an exception is thrown we continue with the previous exception continuation. - let econt edi = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt edi)) - - // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. - // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) - let ccont cexn = - CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) - - let ctxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - computation.Invoke ctxt - - /// Re-route the exception continuation to call to catchFunction. If catchFunction returns None then call the exception continuation. - /// If it returns Some, invoke the resulting async. - /// - Cancellation check before entering the try - /// - No hijack check after 'entering' the try/with - /// - Cancellation check before applying the 'catchFunction' - /// - Apply `catchFunction' to argument with exception protection (see CallFilterThenInvoke) - /// - Hijack check before invoking the resulting computation or exception continuation (see CallFilterThenInvoke) - [] - let TryWith (ctxt: AsyncActivation<'T>) (computation: Async<'T>) catchFunction = - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - let ctxt = - ctxt.WithExceptionContinuation(fun edi -> - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - CallFilterThenInvoke ctxt catchFunction edi) - - computation.Invoke ctxt + | AsyncResult.Ok r -> ctxt.cont r + | AsyncResult.Error edi -> ctxt.econt edi + | AsyncResult.Canceled cexn -> ctxt.ccont cexn) + + /// Generate async computation which calls its continuation with the given result + /// - Cancellation check (see OnSuccess) + /// - Hijack check (see OnSuccess) + let inline CreateReturnAsync res = + // Note: this code ends up in user assemblies via inlining + MakeAsync (fun ctxt -> AsyncActivation.Success ctxt res) + + /// Runs the first process, takes its result, applies f and then runs the new process produced. + /// - Initial cancellation check (see Bind) + /// - Initial hijack check (see Bind) + /// - No hijack check after applying 'part2' to argument (see Bind) + /// - No cancellation check after applying 'part2' to argument (see Bind) + /// - Apply 'part2' to argument with exception protection (see Bind) + let inline CreateBindAsync part1 part2 = + // Note: this code ends up in user assemblies via inlining + MakeAsync (fun ctxt -> + Bind ctxt part1 part2) + + /// Call the given function with exception protection. + /// - No initial cancellation check + /// - Hijack check after applying part2 to argument (see CallThenInvoke) + let inline CreateCallAsync part2 result1 = + // Note: this code ends up in user assemblies via inlining + MakeAsync (fun ctxt -> + CallThenInvoke ctxt result1 part2) + + /// Call the given function with exception protection. + /// - Initial cancellation check + /// - Hijack check after applying computation to argument (see CallThenInvoke) + /// - Apply 'computation' to argument with exception protection (see CallThenInvoke) + let inline CreateDelayAsync computation = + // Note: this code ends up in user assemblies via inlining + MakeAsyncWithCancelCheck (fun ctxt -> + CallThenInvoke ctxt () computation) + + /// Implements the sequencing construct of async computation expressions + /// - Initial cancellation check (see CreateBindAsync) + /// - Initial hijack check (see CreateBindAsync) + /// - No hijack check after applying 'part2' to argument (see CreateBindAsync) + /// - No cancellation check after applying 'part2' to argument (see CreateBindAsync) + /// - Apply 'part2' to argument with exception protection (see CreateBindAsync) + let inline CreateSequentialAsync part1 part2 = + // Note: this code ends up in user assemblies via inlining + CreateBindAsync part1 (fun () -> part2) + + /// Create an async for a try/finally + /// - Cancellation check after 'entering' the try/finally and before running the body + /// - Hijack check after 'entering' the try/finally and before running the body (see TryFinally) + /// - Apply 'finallyFunction' with exception protection (see TryFinally) + let inline CreateTryFinallyAsync finallyFunction computation = + MakeAsync (fun ctxt -> TryFinally ctxt computation finallyFunction) + + /// Create an async for a try/with filtering exceptions through a pattern match + /// - Cancellation check before entering the try (see TryWith) + /// - Cancellation check before entering the with (see TryWith) + /// - Apply `filterFunction' to argument with exception protection (see TryWith) + /// - Hijack check before invoking the resulting computation or exception continuation + let inline CreateTryWithFilterAsync filterFunction computation = + MakeAsync (fun ctxt -> TryWith ctxt computation filterFunction) + + /// Create an async for a try/with filtering + /// - Cancellation check before entering the try (see TryWith) + /// - Cancellation check before entering the with (see TryWith) + /// - Apply `catchFunction' to argument with exception protection (see TryWith) + /// - Hijack check before invoking the resulting computation or exception continuation + let inline CreateTryWithAsync catchFunction computation = + MakeAsync (fun ctxt -> TryWith ctxt computation (fun exn -> Some (catchFunction exn))) + + /// Call the finallyFunction if the computation results in a cancellation, and then continue with cancellation. + /// If the finally function gives an exception then continue with cancellation regardless. + /// - No cancellation check before entering the when-cancelled + /// - No hijack check before entering the when-cancelled + /// - Apply `finallyFunction' to argument with exception protection (see CallThenContinue) + /// - Hijack check before continuing with cancellation (see CallThenContinue) + let CreateWhenCancelledAsync (finallyFunction: OperationCanceledException -> unit) computation = + MakeAsync (fun ctxt -> + let ccont = ctxt.ccont + let ctxt = + ctxt.WithCancellationContinuation(fun cexn -> + CallThenContinue finallyFunction cexn (ctxt.WithContinuations(cont = (fun _ -> ccont cexn), econt = (fun _ -> ccont cexn)))) + computation.Invoke ctxt) + + /// A single pre-allocated computation that fetched the current cancellation token + let cancellationTokenAsync = + MakeAsync (fun ctxt -> ctxt.cont ctxt.aux.token) + + /// A single pre-allocated computation that returns a unit result + /// - Cancellation check (see CreateReturnAsync) + /// - Hijack check (see CreateReturnAsync) + let unitAsync = + CreateReturnAsync() + + /// Implement use/Dispose + /// + /// - No initial cancellation check before applying computation to its argument. See CreateTryFinallyAsync + /// and CreateCallAsync. We enter the try/finally before any cancel checks. + /// - Cancellation check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) + /// - Hijack check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) + /// - Run 'disposeFunction' with exception protection (see CreateTryFinallyAsync) + let CreateUsingAsync (resource:'T :> IDisposable) (computation:'T -> Async<'a>) : Async<'a> = + let disposeFunction () = Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource + CreateTryFinallyAsync disposeFunction (CreateCallAsync computation resource) + + /// - Initial cancellation check (see CreateBindAsync) + /// - Initial hijack check (see CreateBindAsync) + /// - Cancellation check after (see unitAsync) + /// - No hijack check after (see unitAsync) + let inline CreateIgnoreAsync computation = + CreateBindAsync computation (fun _ -> unitAsync) + + /// Implement the while loop construct of async computation expressions + /// - No initial cancellation check before first execution of guard + /// - No initial hijack check before first execution of guard + /// - No cancellation check before each execution of guard (see CreateBindAsync) + /// - Hijack check before each execution of guard (see CreateBindAsync) + /// - Cancellation check before each execution of the body after guard (CreateBindAsync) + /// - No hijack check before each execution of the body after guard (see CreateBindAsync) + /// - Cancellation check after guard fails (see unitAsync) + /// - Hijack check after guard fails (see unitAsync) + /// - Apply 'guardFunc' with exception protection (see ProtectCode) + // + // Note: There are allocations during loop set up, but no allocations during iterations of the loop + let CreateWhileAsync guardFunc computation = + if guardFunc() then + let mutable whileAsync = Unchecked.defaultof<_> + whileAsync <- CreateBindAsync computation (fun () -> if guardFunc() then whileAsync else unitAsync) + whileAsync + else + unitAsync - /// Make an async for an AsyncResult - // - No cancellation check - // - No hijack check - let CreateAsyncResultAsync res = - MakeAsync (fun ctxt -> - match res with - | AsyncResult.Ok r -> ctxt.cont r - | AsyncResult.Error edi -> ctxt.econt edi - | AsyncResult.Canceled cexn -> ctxt.ccont cexn) - - /// Generate async computation which calls its continuation with the given result - /// - Cancellation check (see OnSuccess) - /// - Hijack check (see OnSuccess) - let inline CreateReturnAsync res = - // Note: this code ends up in user assemblies via inlining - MakeAsync (fun ctxt -> AsyncActivation.Success ctxt res) - - /// Runs the first process, takes its result, applies f and then runs the new process produced. - /// - Initial cancellation check (see Bind) - /// - Initial hijack check (see Bind) - /// - No hijack check after applying 'part2' to argument (see Bind) - /// - No cancellation check after applying 'part2' to argument (see Bind) - /// - Apply 'part2' to argument with exception protection (see Bind) - let inline CreateBindAsync part1 part2 = - // Note: this code ends up in user assemblies via inlining - MakeAsync (fun ctxt -> - Bind ctxt part1 part2) +#if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER + /// Implement the while loop construct of async computation expressions + /// - Initial cancellation check before each execution of guard + /// - No initial hijack check before each execution of guard + /// - No cancellation check before each execution of the body after guard + /// - Hijack check before each execution of the body after guard (see Invoke) + /// - Cancellation check after guard fails (see OnSuccess) + /// - Hijack check after guard fails (see OnSuccess) + /// - Apply 'guardFunc' with exception protection (see ProtectCode) + // + // Note: There are allocations during loop set up, but no allocations during iterations of the loop + // One allocation for While async + // One allocation for While async context function + MakeAsync (fun ctxtGuard -> + // One allocation for ctxtLoop reference cell + let mutable ctxtLoop = Unchecked.defaultof<_> + // One allocation for While recursive closure + let rec WhileLoop () = + if ctxtGuard.IsCancellationRequested then + ctxtGuard.OnCancellation () + elif ctxtGuard.ProtectCode guardFunc then + Invoke computation ctxtLoop + else + ctxtGuard.OnSuccess () + // One allocation for While body activation context + ctxtLoop <- ctxtGuard.WithContinuation(WhileLoop) + WhileLoop ()) +#endif - /// Call the given function with exception protection. - /// - No initial cancellation check - /// - Hijack check after applying part2 to argument (see CallThenInvoke) - let inline CreateCallAsync part2 result1 = - // Note: this code ends up in user assemblies via inlining - MakeAsync (fun ctxt -> - CallThenInvoke ctxt result1 part2) - - /// Call the given function with exception protection. - /// - Initial cancellation check - /// - Hijack check after applying computation to argument (see CallThenInvoke) - /// - Apply 'computation' to argument with exception protection (see CallThenInvoke) - let inline CreateDelayAsync computation = - // Note: this code ends up in user assemblies via inlining - MakeAsyncWithCancelCheck (fun ctxt -> - CallThenInvoke ctxt () computation) - - /// Implements the sequencing construct of async computation expressions - /// - Initial cancellation check (see CreateBindAsync) - /// - Initial hijack check (see CreateBindAsync) - /// - No hijack check after applying 'part2' to argument (see CreateBindAsync) - /// - No cancellation check after applying 'part2' to argument (see CreateBindAsync) - /// - Apply 'part2' to argument with exception protection (see CreateBindAsync) - let inline CreateSequentialAsync part1 part2 = - // Note: this code ends up in user assemblies via inlining - CreateBindAsync part1 (fun () -> part2) - - /// Create an async for a try/finally - /// - Cancellation check after 'entering' the try/finally and before running the body - /// - Hijack check after 'entering' the try/finally and before running the body (see TryFinally) - /// - Apply 'finallyFunction' with exception protection (see TryFinally) - let inline CreateTryFinallyAsync finallyFunction computation = - MakeAsync (fun ctxt -> TryFinally ctxt computation finallyFunction) - - /// Create an async for a try/with filtering exceptions through a pattern match - /// - Cancellation check before entering the try (see TryWith) - /// - Cancellation check before entering the with (see TryWith) - /// - Apply `filterFunction' to argument with exception protection (see TryWith) - /// - Hijack check before invoking the resulting computation or exception continuation - let inline CreateTryWithFilterAsync filterFunction computation = - MakeAsync (fun ctxt -> TryWith ctxt computation filterFunction) - - /// Create an async for a try/with filtering - /// - Cancellation check before entering the try (see TryWith) - /// - Cancellation check before entering the with (see TryWith) - /// - Apply `catchFunction' to argument with exception protection (see TryWith) - /// - Hijack check before invoking the resulting computation or exception continuation - let inline CreateTryWithAsync catchFunction computation = - MakeAsync (fun ctxt -> TryWith ctxt computation (fun exn -> Some (catchFunction exn))) - - /// Call the finallyFunction if the computation results in a cancellation, and then continue with cancellation. - /// If the finally function gives an exception then continue with cancellation regardless. - /// - No cancellation check before entering the when-cancelled - /// - No hijack check before entering the when-cancelled - /// - Apply `finallyFunction' to argument with exception protection (see CallThenContinue) - /// - Hijack check before continuing with cancellation (see CallThenContinue) - let CreateWhenCancelledAsync (finallyFunction: OperationCanceledException -> unit) computation = - MakeAsync (fun ctxt -> - let ccont = ctxt.ccont - let ctxt = - ctxt.WithCancellationContinuation(fun cexn -> - CallThenContinue finallyFunction cexn (ctxt.WithContinuations(cont = (fun _ -> ccont cexn), econt = (fun _ -> ccont cexn)))) - computation.Invoke ctxt) - - /// A single pre-allocated computation that fetched the current cancellation token - let cancellationTokenAsync = - MakeAsync (fun ctxt -> ctxt.cont ctxt.aux.token) - - /// A single pre-allocated computation that returns a unit result - /// - Cancellation check (see CreateReturnAsync) - /// - Hijack check (see CreateReturnAsync) - let unitAsync = - CreateReturnAsync() - - /// Implement use/Dispose - /// - /// - No initial cancellation check before applying computation to its argument. See CreateTryFinallyAsync - /// and CreateCallAsync. We enter the try/finally before any cancel checks. - /// - Cancellation check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) - /// - Hijack check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) - /// - Run 'disposeFunction' with exception protection (see CreateTryFinallyAsync) - let CreateUsingAsync (resource:'T :> IDisposable) (computation:'T -> Async<'a>) : Async<'a> = - let disposeFunction () = Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource - CreateTryFinallyAsync disposeFunction (CreateCallAsync computation resource) - - /// - Initial cancellation check (see CreateBindAsync) - /// - Initial hijack check (see CreateBindAsync) - /// - Cancellation check after (see unitAsync) - /// - No hijack check after (see unitAsync) - let inline CreateIgnoreAsync computation = - CreateBindAsync computation (fun _ -> unitAsync) - - /// Implement the while loop construct of async computation expressions - /// - No initial cancellation check before first execution of guard - /// - No initial hijack check before first execution of guard - /// - No cancellation check before each execution of guard (see CreateBindAsync) - /// - Hijack check before each execution of guard (see CreateBindAsync) - /// - Cancellation check before each execution of the body after guard (CreateBindAsync) - /// - No hijack check before each execution of the body after guard (see CreateBindAsync) - /// - Cancellation check after guard fails (see unitAsync) - /// - Hijack check after guard fails (see unitAsync) - /// - Apply 'guardFunc' with exception protection (see ProtectCode) - // - // Note: There are allocations during loop set up, but no allocations during iterations of the loop - let CreateWhileAsync guardFunc computation = - if guardFunc() then - let mutable whileAsync = Unchecked.defaultof<_> - whileAsync <- CreateBindAsync computation (fun () -> if guardFunc() then whileAsync else unitAsync) - whileAsync - else - unitAsync + /// Implement the for loop construct of async commputation expressions + /// - No initial cancellation check before GetEnumerator call. + /// - No initial cancellation check before entering protection of implied try/finally + /// - Cancellation check after 'entering' the implied try/finally and before loop + /// - Hijack check after 'entering' the implied try/finally and after MoveNext call + /// - Do not apply 'GetEnumerator' with exception protection. However for an 'async' + /// in an 'async { ... }' the exception protection will be provided by the enclosing + /// Delay or Bind or similar construct. + /// - Apply 'MoveNext' with exception protection + /// - Apply 'Current' with exception protection + + // Note: No allocations during iterations of the loop apart from those from + // applying the loop body to the element + let CreateForLoopAsync (source: seq<_>) computation = + CreateUsingAsync (source.GetEnumerator()) (fun ie -> + CreateWhileAsync + (fun () -> ie.MoveNext()) + (CreateDelayAsync (fun () -> computation ie.Current))) #if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER - /// Implement the while loop construct of async computation expressions - /// - Initial cancellation check before each execution of guard - /// - No initial hijack check before each execution of guard - /// - No cancellation check before each execution of the body after guard - /// - Hijack check before each execution of the body after guard (see Invoke) - /// - Cancellation check after guard fails (see OnSuccess) - /// - Hijack check after guard fails (see OnSuccess) - /// - Apply 'guardFunc' with exception protection (see ProtectCode) - // - // Note: There are allocations during loop set up, but no allocations during iterations of the loop + CreateUsingAsync (source.GetEnumerator()) (fun ie -> // One allocation for While async // One allocation for While async context function MakeAsync (fun ctxtGuard -> // One allocation for ctxtLoop reference cell let mutable ctxtLoop = Unchecked.defaultof<_> - // One allocation for While recursive closure - let rec WhileLoop () = + // Two allocations for protected functions + let guardFunc() = ie.MoveNext() + let currentFunc() = ie.Current + // One allocation for ForLoop recursive closure + let rec ForLoop () = if ctxtGuard.IsCancellationRequested then ctxtGuard.OnCancellation () elif ctxtGuard.ProtectCode guardFunc then - Invoke computation ctxtLoop + let x = ctxtGuard.ProtectCode currentFunc + CallThenInvoke ctxtLoop x computation else ctxtGuard.OnSuccess () - // One allocation for While body activation context - ctxtLoop <- ctxtGuard.WithContinuation(WhileLoop) - WhileLoop ()) + // One allocation for loop activation context + ctxtLoop <- ctxtGuard.WithContinuation(ForLoop) + ForLoop ())) #endif - /// Implement the for loop construct of async commputation expressions - /// - No initial cancellation check before GetEnumerator call. - /// - No initial cancellation check before entering protection of implied try/finally - /// - Cancellation check after 'entering' the implied try/finally and before loop - /// - Hijack check after 'entering' the implied try/finally and after MoveNext call - /// - Do not apply 'GetEnumerator' with exception protection. However for an 'async' - /// in an 'async { ... }' the exception protection will be provided by the enclosing - /// Delay or Bind or similar construct. - /// - Apply 'MoveNext' with exception protection - /// - Apply 'Current' with exception protection - - // Note: No allocations during iterations of the loop apart from those from - // applying the loop body to the element - let CreateForLoopAsync (source: seq<_>) computation = - CreateUsingAsync (source.GetEnumerator()) (fun ie -> - CreateWhileAsync - (fun () -> ie.MoveNext()) - (CreateDelayAsync (fun () -> computation ie.Current))) + /// - Initial cancellation check + /// - Call syncCtxt.Post with exception protection. THis may fail as it is arbitrary user code + let CreateSwitchToAsync (syncCtxt: SynchronizationContext) = + MakeAsyncWithCancelCheck (fun ctxt -> + ctxt.PostWithTrampoline syncCtxt ctxt.cont) + + /// - Initial cancellation check + /// - Create Thread and call Start() with exception protection. We don't expect this + /// to fail but protect nevertheless. + let CreateSwitchToNewThreadAsync() = + MakeAsyncWithCancelCheck (fun ctxt -> + ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.StartThreadWithTrampoline ctxt.cont)) + + /// - Initial cancellation check + /// - Call ThreadPool.QueueUserWorkItem with exception protection. We don't expect this + /// to fail but protect nevertheless. + let CreateSwitchToThreadPoolAsync() = + MakeAsyncWithCancelCheck (fun ctxt -> + ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.QueueWorkItemWithTrampoline ctxt.cont)) + + /// Post back to the sync context regardless of which continuation is taken + /// - Call syncCtxt.Post with exception protection + let DelimitSyncContext (ctxt: AsyncActivation<_>) = + match SynchronizationContext.Current with + | null -> ctxt + | syncCtxt -> + ctxt.WithContinuations(cont = (fun x -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.cont x)), + econt = (fun edi -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.econt edi)), + ccont = (fun cexn -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont cexn))) -#if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER - CreateUsingAsync (source.GetEnumerator()) (fun ie -> - // One allocation for While async - // One allocation for While async context function - MakeAsync (fun ctxtGuard -> - // One allocation for ctxtLoop reference cell - let mutable ctxtLoop = Unchecked.defaultof<_> - // Two allocations for protected functions - let guardFunc() = ie.MoveNext() - let currentFunc() = ie.Current - // One allocation for ForLoop recursive closure - let rec ForLoop () = - if ctxtGuard.IsCancellationRequested then - ctxtGuard.OnCancellation () - elif ctxtGuard.ProtectCode guardFunc then - let x = ctxtGuard.ProtectCode currentFunc - CallThenInvoke ctxtLoop x computation - else - ctxtGuard.OnSuccess () - // One allocation for loop activation context - ctxtLoop <- ctxtGuard.WithContinuation(ForLoop) - ForLoop ())) -#endif + [] + [] + type SuspendedAsync<'T>(ctxt: AsyncActivation<'T>) = - /// - Initial cancellation check - /// - Call syncCtxt.Post with exception protection. THis may fail as it is arbitrary user code - let CreateSwitchToAsync (syncCtxt: SynchronizationContext) = - MakeAsyncWithCancelCheck (fun ctxt -> - ctxt.PostWithTrampoline syncCtxt ctxt.cont) - - /// - Initial cancellation check - /// - Create Thread and call Start() with exception protection. We don't expect this - /// to fail but protect nevertheless. - let CreateSwitchToNewThreadAsync() = - MakeAsyncWithCancelCheck (fun ctxt -> - ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.StartThreadWithTrampoline ctxt.cont)) - - /// - Initial cancellation check - /// - Call ThreadPool.QueueUserWorkItem with exception protection. We don't expect this - /// to fail but protect nevertheless. - let CreateSwitchToThreadPoolAsync() = - MakeAsyncWithCancelCheck (fun ctxt -> - ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.QueueWorkItemWithTrampoline ctxt.cont)) - - /// Post back to the sync context regardless of which continuation is taken - /// - Call syncCtxt.Post with exception protection - let DelimitSyncContext (ctxt: AsyncActivation<_>) = - match SynchronizationContext.Current with - | null -> ctxt - | syncCtxt -> - ctxt.WithContinuations(cont = (fun x -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.cont x)), - econt = (fun edi -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.econt edi)), - ccont = (fun cexn -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont cexn))) - - [] - [] - type SuspendedAsync<'T>(ctxt: AsyncActivation<'T>) = - - let syncCtxt = SynchronizationContext.Current - - let thread = - match syncCtxt with - | null -> null // saving a thread-local access - | _ -> Thread.CurrentThread - - let trampolineHolder = ctxt.trampolineHolder - - member _.ContinueImmediate res = - let action () = ctxt.cont res - let inline executeImmediately () = trampolineHolder.ExecuteWithTrampoline action - let currentSyncCtxt = SynchronizationContext.Current - match syncCtxt, currentSyncCtxt with - | null, null -> - executeImmediately () - // This logic was added in F# 2.0 though is incorrect from the perspective of - // how SynchronizationContext is meant to work. However the logic works for - // mainline scenarios (WinForms/WPF) and for compatibility reasons we won't change it. - | _ when Object.Equals(syncCtxt, currentSyncCtxt) && thread.Equals Thread.CurrentThread -> - executeImmediately () - | _ -> - trampolineHolder.PostOrQueueWithTrampoline syncCtxt action + let syncCtxt = SynchronizationContext.Current - member _.PostOrQueueWithTrampoline res = - trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> ctxt.cont res) + let thread = + match syncCtxt with + | null -> null // saving a thread-local access + | _ -> Thread.CurrentThread + + let trampolineHolder = ctxt.trampolineHolder + + member _.ContinueImmediate res = + let action () = ctxt.cont res + let inline executeImmediately () = trampolineHolder.ExecuteWithTrampoline action + let currentSyncCtxt = SynchronizationContext.Current + match syncCtxt, currentSyncCtxt with + | null, null -> + executeImmediately () + // This logic was added in F# 2.0 though is incorrect from the perspective of + // how SynchronizationContext is meant to work. However the logic works for + // mainline scenarios (WinForms/WPF) and for compatibility reasons we won't change it. + | _ when Object.Equals(syncCtxt, currentSyncCtxt) && thread.Equals Thread.CurrentThread -> + executeImmediately () + | _ -> + trampolineHolder.PostOrQueueWithTrampoline syncCtxt action - /// A utility type to provide a synchronization point between an asynchronous computation - /// and callers waiting on the result of that computation. - /// - /// Use with care! - [] - [] - type ResultCell<'T>() = + member _.PostOrQueueWithTrampoline res = + trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> ctxt.cont res) - let mutable result = None + /// A utility type to provide a synchronization point between an asynchronous computation + /// and callers waiting on the result of that computation. + /// + /// Use with care! + [] + [] + type ResultCell<'T>() = - // The continuations for the result - let mutable savedConts: SuspendedAsync<'T> list = [] + let mutable result = None - // The WaitHandle event for the result. Only created if needed, and set to null when disposed. - let mutable resEvent = null + // The continuations for the result + let mutable savedConts: SuspendedAsync<'T> list = [] - let mutable disposed = false + // The WaitHandle event for the result. Only created if needed, and set to null when disposed. + let mutable resEvent = null - // All writers of result are protected by lock on syncRoot. - let syncRoot = obj() + let mutable disposed = false - member x.GetWaitHandle() = - lock syncRoot (fun () -> - if disposed then - raise (System.ObjectDisposedException("ResultCell")) + // All writers of result are protected by lock on syncRoot. + let syncRoot = obj() + + member x.GetWaitHandle() = + lock syncRoot (fun () -> + if disposed then + raise (System.ObjectDisposedException("ResultCell")) + match resEvent with + | null -> + // Start in signalled state if a result is already present. + let ev = new ManualResetEvent(result.IsSome) + resEvent <- ev + (ev :> WaitHandle) + | ev -> + (ev :> WaitHandle)) + + member x.Close() = + lock syncRoot (fun () -> + if not disposed then + disposed <- true match resEvent with - | null -> - // Start in signalled state if a result is already present. - let ev = new ManualResetEvent(result.IsSome) - resEvent <- ev - (ev :> WaitHandle) + | null -> () | ev -> - (ev :> WaitHandle)) + ev.Close() + resEvent <- null) + + interface IDisposable with + member x.Dispose() = x.Close() + + member x.GrabResult() = + match result with + | Some res -> res + | None -> failwith "Unexpected no result" - member x.Close() = + /// Record the result in the ResultCell. + member x.RegisterResult (res:'T, reuseThread) = + let grabbedConts = lock syncRoot (fun () -> - if not disposed then - disposed <- true - match resEvent with - | null -> () - | ev -> - ev.Close() - resEvent <- null) - - interface IDisposable with - member x.Dispose() = x.Close() - - member x.GrabResult() = - match result with - | Some res -> res - | None -> failwith "Unexpected no result" - - /// Record the result in the ResultCell. - member x.RegisterResult (res:'T, reuseThread) = - let grabbedConts = - lock syncRoot (fun () -> - // Ignore multiple sets of the result. This can happen, e.g. for a race between a cancellation and a success - if x.ResultAvailable then - [] // invalidOp "multiple results registered for asynchronous operation" - else - // In this case the ResultCell has already been disposed, e.g. due to a timeout. - // The result is dropped on the floor. - if disposed then - [] - else - result <- Some res - // If the resEvent exists then set it. If not we can skip setting it altogether and it won't be - // created - match resEvent with - | null -> - () - | ev -> - // Setting the event need to happen under lock so as not to race with Close() - ev.Set () |> ignore - List.rev savedConts) - - // Run the action outside the lock - match grabbedConts with - | [] -> fake() - | [cont] -> - if reuseThread then - cont.ContinueImmediate res + // Ignore multiple sets of the result. This can happen, e.g. for a race between a cancellation and a success + if x.ResultAvailable then + [] // invalidOp "multiple results registered for asynchronous operation" else - cont.PostOrQueueWithTrampoline res - | otherwise -> - otherwise |> List.iter (fun cont -> cont.PostOrQueueWithTrampoline res |> unfake) |> fake - - member x.ResultAvailable = result.IsSome - - /// Await the result of a result cell, without a direct timeout or direct - /// cancellation. That is, the underlying computation must fill the result - /// if cancellation or timeout occurs. - member x.AwaitResult_NoDirectCancelOrTimeout = - MakeAsync (fun ctxt -> - // Check if a result is available synchronously - let resOpt = - match result with - | Some _ -> result - | None -> - lock syncRoot (fun () -> - match result with - | Some _ -> - result - | None -> - // Otherwise save the continuation and call it in RegisterResult - savedConts <- (SuspendedAsync<_>(ctxt)) :: savedConts - None - ) - match resOpt with - | Some res -> ctxt.cont res - | None -> fake() - ) + // In this case the ResultCell has already been disposed, e.g. due to a timeout. + // The result is dropped on the floor. + if disposed then + [] + else + result <- Some res + // If the resEvent exists then set it. If not we can skip setting it altogether and it won't be + // created + match resEvent with + | null -> + () + | ev -> + // Setting the event need to happen under lock so as not to race with Close() + ev.Set () |> ignore + List.rev savedConts) + + // Run the action outside the lock + match grabbedConts with + | [] -> fake() + | [cont] -> + if reuseThread then + cont.ContinueImmediate res + else + cont.PostOrQueueWithTrampoline res + | otherwise -> + otherwise |> List.iter (fun cont -> cont.PostOrQueueWithTrampoline res |> unfake) |> fake - member x.TryWaitForResultSynchronously (?timeout) : 'T option = - // Check if a result is available. + member x.ResultAvailable = result.IsSome + + /// Await the result of a result cell, without a direct timeout or direct + /// cancellation. That is, the underlying computation must fill the result + /// if cancellation or timeout occurs. + member x.AwaitResult_NoDirectCancelOrTimeout = + MakeAsync (fun ctxt -> + // Check if a result is available synchronously + let resOpt = + match result with + | Some _ -> result + | None -> + lock syncRoot (fun () -> + match result with + | Some _ -> + result + | None -> + // Otherwise save the continuation and call it in RegisterResult + savedConts <- (SuspendedAsync<_>(ctxt)) :: savedConts + None + ) + match resOpt with + | Some res -> ctxt.cont res + | None -> fake() + ) + + member x.TryWaitForResultSynchronously (?timeout) : 'T option = + // Check if a result is available. + match result with + | Some _ as r -> + r + | None -> + // Force the creation of the WaitHandle + let resHandle = x.GetWaitHandle() + // Check again. While we were in GetWaitHandle, a call to RegisterResult may have set result then skipped the + // Set because the resHandle wasn't forced. match result with | Some _ as r -> r | None -> - // Force the creation of the WaitHandle - let resHandle = x.GetWaitHandle() - // Check again. While we were in GetWaitHandle, a call to RegisterResult may have set result then skipped the - // Set because the resHandle wasn't forced. - match result with - | Some _ as r -> - r - | None -> - // OK, let's really wait for the Set signal. This may block. - let timeout = defaultArg timeout Threading.Timeout.Infinite - let ok = resHandle.WaitOne(millisecondsTimeout= timeout, exitContext=true) - if ok then - // Now the result really must be available - result - else - // timed out - None - - - /// Create an instance of an arbitrary delegate type delegating to the given F# function - type FuncDelegate<'T>(f) = - member _.Invoke(sender:obj, a:'T) : unit = ignore sender; f a - static member Create<'Delegate when 'Delegate :> Delegate>(f) = - let obj = FuncDelegate<'T>(f) - let invokeMeth = (typeof>).GetMethod("Invoke", BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) - System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeMeth) :?> 'Delegate - - [] - let QueueAsync cancellationToken cont econt ccont computation = - let trampolineHolder = TrampolineHolder() - trampolineHolder.QueueWorkItemWithTrampoline (fun () -> - let ctxt = AsyncActivation.Create cancellationToken trampolineHolder cont econt ccont - computation.Invoke ctxt) - - /// Run the asynchronous workflow and wait for its result. - [] - let QueueAsyncAndWaitForResultSynchronously (token:CancellationToken) computation timeout = - let token, innerCTS = - // If timeout is provided, we govern the async by our own CTS, to cancel - // when execution times out. Otherwise, the user-supplied token governs the async. - match timeout with - | None -> token, None - | Some _ -> - let subSource = new LinkedSubSource(token) - subSource.Token, Some subSource - - use resultCell = new ResultCell>() - QueueAsync - token - (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) - (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) - (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) - computation - |> unfake - - let res = resultCell.TryWaitForResultSynchronously(?timeout = timeout) - match res with - | None -> // timed out - // issue cancellation signal - if innerCTS.IsSome then innerCTS.Value.Cancel() - // wait for computation to quiesce; drop result on the floor - resultCell.TryWaitForResultSynchronously() |> ignore - // dispose the CancellationTokenSource - if innerCTS.IsSome then innerCTS.Value.Dispose() - raise (System.TimeoutException()) - | Some res -> - match innerCTS with - | Some subSource -> subSource.Dispose() - | None -> () - res.Commit() - - [] - let RunImmediate (cancellationToken:CancellationToken) computation = - use resultCell = new ResultCell>() - let trampolineHolder = TrampolineHolder() - - trampolineHolder.ExecuteWithTrampoline (fun () -> - let ctxt = - AsyncActivation.Create - cancellationToken - trampolineHolder - (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) - (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) - (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) - computation.Invoke ctxt) - |> unfake - - let res = resultCell.TryWaitForResultSynchronously().Value - res.Commit() - - [] - let RunSynchronously cancellationToken (computation: Async<'T>) timeout = - // Reuse the current ThreadPool thread if possible. - match SynchronizationContext.Current, Thread.CurrentThread.IsThreadPoolThread, timeout with - | null, true, None -> RunImmediate cancellationToken computation - | _ -> QueueAsyncAndWaitForResultSynchronously cancellationToken computation timeout - - [] - let Start cancellationToken (computation:Async) = - QueueAsync - cancellationToken - (fun () -> fake()) // nothing to do on success - (fun edi -> edi.ThrowAny()) // raise exception in child - (fun _ -> fake()) // ignore cancellation in child - computation - |> unfake - - [] - let StartWithContinuations cancellationToken (computation:Async<'T>) cont econt ccont = - let trampolineHolder = TrampolineHolder() - trampolineHolder.ExecuteWithTrampoline (fun () -> - let ctxt = AsyncActivation.Create cancellationToken trampolineHolder (cont >> fake) (econt >> fake) (ccont >> fake) - computation.Invoke ctxt) - |> unfake - - [] - let StartAsTask cancellationToken (computation:Async<'T>) taskCreationOptions = - let taskCreationOptions = defaultArg taskCreationOptions TaskCreationOptions.None - let tcs = TaskCompletionSource<_>(taskCreationOptions) - - // The contract: - // a) cancellation signal should always propagate to the computation - // b) when the task IsCompleted -> nothing is running anymore - let task = tcs.Task - QueueAsync - cancellationToken - (fun r -> tcs.SetResult r |> fake) - (fun edi -> tcs.SetException edi.SourceException |> fake) - (fun _ -> tcs.SetCanceled() |> fake) - computation - |> unfake - task - - // Call the appropriate continuation on completion of a task - [] - let OnTaskCompleted (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = - assert completedTask.IsCompleted - if completedTask.IsCanceled then - let edi = ExceptionDispatchInfo.Capture(TaskCanceledException completedTask) - ctxt.econt edi - elif completedTask.IsFaulted then - let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception - ctxt.econt edi - else - ctxt.cont completedTask.Result - - // Call the appropriate continuation on completion of a task. A cancelled task - // calls the exception continuation with TaskCanceledException, since it may not represent cancellation of - // the overall async (they may be governed by different cancellation tokens, or - // the task may not have a cancellation token at all). - [] - let OnUnitTaskCompleted (completedTask: Task) (ctxt: AsyncActivation) = - assert completedTask.IsCompleted - if completedTask.IsCanceled then - let edi = ExceptionDispatchInfo.Capture(TaskCanceledException(completedTask)) - ctxt.econt edi - elif completedTask.IsFaulted then - let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception - ctxt.econt edi - else - ctxt.cont () - - // Helper to attach continuation to the given task, which is assumed not to be completed. - // When the task completes the continuation will be run synchronously on the thread - // completing the task. This will install a new trampoline on that thread and continue the - // execution of the async there. - [] - let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = - task.ContinueWith(Action>(fun completedTask -> - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> - OnTaskCompleted completedTask ctxt) - |> unfake), TaskContinuationOptions.ExecuteSynchronously) - |> ignore - |> fake - - // Helper to attach continuation to the given task, which is assumed not to be completed - // When the task completes the continuation will be run synchronously on the thread - // completing the task. This will install a new trampoline on that thread and continue the - // execution of the async there. - [] - let AttachContinuationToUnitTask (task: Task) (ctxt: AsyncActivation) = - task.ContinueWith(Action(fun completedTask -> - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> - OnUnitTaskCompleted completedTask ctxt) - |> unfake), TaskContinuationOptions.ExecuteSynchronously) - |> ignore - |> fake - - /// Removes a registration places on a cancellation token - let DisposeCancellationRegistration (registration: byref) = - match registration with - | Some r -> - registration <- None - r.Dispose() - | None -> () - - /// Cleans up a Timer, helper for Async.Sleep - let DisposeTimer (timer: byref) = - match timer with - | None -> () - | Some t -> - timer <- None - t.Dispose() - - /// Unregisters a RegisteredWaitHandle, helper for AwaitWaitHandle - let UnregisterWaitHandle (rwh: byref) = - match rwh with - | None -> () - | Some r -> - r.Unregister null |> ignore - rwh <- None - - /// Unregisters a delegate handler, helper for AwaitEvent - let RemoveHandler (event: IEvent<_, _>) (del: byref<'Delegate option>) = - match del with - | Some d -> - del <- None - event.RemoveHandler d + // OK, let's really wait for the Set signal. This may block. + let timeout = defaultArg timeout Threading.Timeout.Infinite + let ok = resHandle.WaitOne(millisecondsTimeout= timeout, exitContext=true) + if ok then + // Now the result really must be available + result + else + // timed out + None + + + /// Create an instance of an arbitrary delegate type delegating to the given F# function + type FuncDelegate<'T>(f) = + member _.Invoke(sender:obj, a:'T) : unit = ignore sender; f a + static member Create<'Delegate when 'Delegate :> Delegate>(f) = + let obj = FuncDelegate<'T>(f) + let invokeMeth = (typeof>).GetMethod("Invoke", BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) + System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeMeth) :?> 'Delegate + + [] + let QueueAsync cancellationToken cont econt ccont computation = + let trampolineHolder = TrampolineHolder() + trampolineHolder.QueueWorkItemWithTrampoline (fun () -> + let ctxt = AsyncActivation.Create cancellationToken trampolineHolder cont econt ccont + computation.Invoke ctxt) + + /// Run the asynchronous workflow and wait for its result. + [] + let QueueAsyncAndWaitForResultSynchronously (token:CancellationToken) computation timeout = + let token, innerCTS = + // If timeout is provided, we govern the async by our own CTS, to cancel + // when execution times out. Otherwise, the user-supplied token governs the async. + match timeout with + | None -> token, None + | Some _ -> + let subSource = new LinkedSubSource(token) + subSource.Token, Some subSource + + use resultCell = new ResultCell>() + QueueAsync + token + (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) + (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) + (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) + computation + |> unfake + + let res = resultCell.TryWaitForResultSynchronously(?timeout = timeout) + match res with + | None -> // timed out + // issue cancellation signal + if innerCTS.IsSome then innerCTS.Value.Cancel() + // wait for computation to quiesce; drop result on the floor + resultCell.TryWaitForResultSynchronously() |> ignore + // dispose the CancellationTokenSource + if innerCTS.IsSome then innerCTS.Value.Dispose() + raise (System.TimeoutException()) + | Some res -> + match innerCTS with + | Some subSource -> subSource.Dispose() | None -> () + res.Commit() - [] - type AsyncIAsyncResult<'T>(callback: System.AsyncCallback, state:obj) = - // This gets set to false if the result is not available by the - // time the IAsyncResult is returned to the caller of Begin - let mutable completedSynchronously = true - - let mutable disposed = false - - let cts = new CancellationTokenSource() - - let result = new ResultCell>() - - member s.SetResult(v: AsyncResult<'T>) = - result.RegisterResult(v, reuseThread=true) |> unfake - match callback with - | null -> () - | d -> - // The IASyncResult becomes observable here - d.Invoke (s :> System.IAsyncResult) - - member s.GetResult() = - match result.TryWaitForResultSynchronously (-1) with - | Some (AsyncResult.Ok v) -> v - | Some (AsyncResult.Error edi) -> edi.ThrowAny() - | Some (AsyncResult.Canceled err) -> raise err - | None -> failwith "unreachable" - - member x.IsClosed = disposed - - member x.Close() = - if not disposed then - disposed <- true - cts.Dispose() - result.Close() - - member x.Token = cts.Token - - member x.CancelAsync() = cts.Cancel() - - member x.CheckForNotSynchronous() = - if not result.ResultAvailable then - completedSynchronously <- false - - interface System.IAsyncResult with - member _.IsCompleted = result.ResultAvailable - member _.CompletedSynchronously = completedSynchronously - member _.AsyncWaitHandle = result.GetWaitHandle() - member _.AsyncState = state - - interface System.IDisposable with - member x.Dispose() = x.Close() - - module AsBeginEndHelpers = - let beginAction (computation, callback, state) = - let aiar = new AsyncIAsyncResult<'T>(callback, state) - let cont res = aiar.SetResult (AsyncResult.Ok res) - let econt edi = aiar.SetResult (AsyncResult.Error edi) - let ccont cexn = aiar.SetResult (AsyncResult.Canceled cexn) - StartWithContinuations aiar.Token computation cont econt ccont - aiar.CheckForNotSynchronous() - (aiar :> IAsyncResult) - - let endAction<'T> (iar:IAsyncResult) = - match iar with - | :? AsyncIAsyncResult<'T> as aiar -> - if aiar.IsClosed then - raise (System.ObjectDisposedException("AsyncResult")) - else - let res = aiar.GetResult() - aiar.Close () - res - | _ -> - invalidArg "iar" (SR.GetString(SR.mismatchIAREnd)) + [] + let RunImmediate (cancellationToken:CancellationToken) computation = + use resultCell = new ResultCell>() + let trampolineHolder = TrampolineHolder() + + trampolineHolder.ExecuteWithTrampoline (fun () -> + let ctxt = + AsyncActivation.Create + cancellationToken + trampolineHolder + (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) + (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) + (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) + computation.Invoke ctxt) + |> unfake + + let res = resultCell.TryWaitForResultSynchronously().Value + res.Commit() + + [] + let RunSynchronously cancellationToken (computation: Async<'T>) timeout = + // Reuse the current ThreadPool thread if possible. + match SynchronizationContext.Current, Thread.CurrentThread.IsThreadPoolThread, timeout with + | null, true, None -> RunImmediate cancellationToken computation + | _ -> QueueAsyncAndWaitForResultSynchronously cancellationToken computation timeout + + [] + let Start cancellationToken (computation:Async) = + QueueAsync + cancellationToken + (fun () -> fake()) // nothing to do on success + (fun edi -> edi.ThrowAny()) // raise exception in child + (fun _ -> fake()) // ignore cancellation in child + computation + |> unfake + + [] + let StartWithContinuations cancellationToken (computation:Async<'T>) cont econt ccont = + let trampolineHolder = TrampolineHolder() + trampolineHolder.ExecuteWithTrampoline (fun () -> + let ctxt = AsyncActivation.Create cancellationToken trampolineHolder (cont >> fake) (econt >> fake) (ccont >> fake) + computation.Invoke ctxt) + |> unfake + + [] + let StartAsTask cancellationToken (computation:Async<'T>) taskCreationOptions = + let taskCreationOptions = defaultArg taskCreationOptions TaskCreationOptions.None + let tcs = TaskCompletionSource<_>(taskCreationOptions) + + // The contract: + // a) cancellation signal should always propagate to the computation + // b) when the task IsCompleted -> nothing is running anymore + let task = tcs.Task + QueueAsync + cancellationToken + (fun r -> tcs.SetResult r |> fake) + (fun edi -> tcs.SetException edi.SourceException |> fake) + (fun _ -> tcs.SetCanceled() |> fake) + computation + |> unfake + task + + // Call the appropriate continuation on completion of a task + [] + let OnTaskCompleted (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = + assert completedTask.IsCompleted + if completedTask.IsCanceled then + let edi = ExceptionDispatchInfo.Capture(TaskCanceledException completedTask) + ctxt.econt edi + elif completedTask.IsFaulted then + let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception + ctxt.econt edi + else + ctxt.cont completedTask.Result + + // Call the appropriate continuation on completion of a task. A cancelled task + // calls the exception continuation with TaskCanceledException, since it may not represent cancellation of + // the overall async (they may be governed by different cancellation tokens, or + // the task may not have a cancellation token at all). + [] + let OnUnitTaskCompleted (completedTask: Task) (ctxt: AsyncActivation) = + assert completedTask.IsCompleted + if completedTask.IsCanceled then + let edi = ExceptionDispatchInfo.Capture(TaskCanceledException(completedTask)) + ctxt.econt edi + elif completedTask.IsFaulted then + let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception + ctxt.econt edi + else + ctxt.cont () + + // Helper to attach continuation to the given task, which is assumed not to be completed. + // When the task completes the continuation will be run synchronously on the thread + // completing the task. This will install a new trampoline on that thread and continue the + // execution of the async there. + [] + let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = + task.ContinueWith(Action>(fun completedTask -> + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> + OnTaskCompleted completedTask ctxt) + |> unfake), TaskContinuationOptions.ExecuteSynchronously) + |> ignore + |> fake + + // Helper to attach continuation to the given task, which is assumed not to be completed + // When the task completes the continuation will be run synchronously on the thread + // completing the task. This will install a new trampoline on that thread and continue the + // execution of the async there. + [] + let AttachContinuationToUnitTask (task: Task) (ctxt: AsyncActivation) = + task.ContinueWith(Action(fun completedTask -> + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> + OnUnitTaskCompleted completedTask ctxt) + |> unfake), TaskContinuationOptions.ExecuteSynchronously) + |> ignore + |> fake + + /// Removes a registration places on a cancellation token + let DisposeCancellationRegistration (registration: byref) = + match registration with + | Some r -> + registration <- None + r.Dispose() + | None -> () + + /// Cleans up a Timer, helper for Async.Sleep + let DisposeTimer (timer: byref) = + match timer with + | None -> () + | Some t -> + timer <- None + t.Dispose() + + /// Unregisters a RegisteredWaitHandle, helper for AwaitWaitHandle + let UnregisterWaitHandle (rwh: byref) = + match rwh with + | None -> () + | Some r -> + r.Unregister null |> ignore + rwh <- None + + /// Unregisters a delegate handler, helper for AwaitEvent + let RemoveHandler (event: IEvent<_, _>) (del: byref<'Delegate option>) = + match del with + | Some d -> + del <- None + event.RemoveHandler d + | None -> () + + [] + type AsyncIAsyncResult<'T>(callback: System.AsyncCallback, state:obj) = + // This gets set to false if the result is not available by the + // time the IAsyncResult is returned to the caller of Begin + let mutable completedSynchronously = true + + let mutable disposed = false + + let cts = new CancellationTokenSource() + + let result = new ResultCell>() + + member s.SetResult(v: AsyncResult<'T>) = + result.RegisterResult(v, reuseThread=true) |> unfake + match callback with + | null -> () + | d -> + // The IASyncResult becomes observable here + d.Invoke (s :> System.IAsyncResult) + + member s.GetResult() = + match result.TryWaitForResultSynchronously (-1) with + | Some (AsyncResult.Ok v) -> v + | Some (AsyncResult.Error edi) -> edi.ThrowAny() + | Some (AsyncResult.Canceled err) -> raise err + | None -> failwith "unreachable" + + member x.IsClosed = disposed + + member x.Close() = + if not disposed then + disposed <- true + cts.Dispose() + result.Close() + + member x.Token = cts.Token + + member x.CancelAsync() = cts.Cancel() + + member x.CheckForNotSynchronous() = + if not result.ResultAvailable then + completedSynchronously <- false + + interface System.IAsyncResult with + member _.IsCompleted = result.ResultAvailable + member _.CompletedSynchronously = completedSynchronously + member _.AsyncWaitHandle = result.GetWaitHandle() + member _.AsyncState = state + + interface System.IDisposable with + member x.Dispose() = x.Close() + + module AsBeginEndHelpers = + let beginAction (computation, callback, state) = + let aiar = new AsyncIAsyncResult<'T>(callback, state) + let cont res = aiar.SetResult (AsyncResult.Ok res) + let econt edi = aiar.SetResult (AsyncResult.Error edi) + let ccont cexn = aiar.SetResult (AsyncResult.Canceled cexn) + StartWithContinuations aiar.Token computation cont econt ccont + aiar.CheckForNotSynchronous() + (aiar :> IAsyncResult) + + let endAction<'T> (iar:IAsyncResult) = + match iar with + | :? AsyncIAsyncResult<'T> as aiar -> + if aiar.IsClosed then + raise (System.ObjectDisposedException("AsyncResult")) + else + let res = aiar.GetResult() + aiar.Close () + res + | _ -> + invalidArg "iar" (SR.GetString(SR.mismatchIAREnd)) - let cancelAction<'T>(iar:IAsyncResult) = - match iar with - | :? AsyncIAsyncResult<'T> as aiar -> - aiar.CancelAsync() - | _ -> - invalidArg "iar" (SR.GetString(SR.mismatchIARCancel)) + let cancelAction<'T>(iar:IAsyncResult) = + match iar with + | :? AsyncIAsyncResult<'T> as aiar -> + aiar.CancelAsync() + | _ -> + invalidArg "iar" (SR.GetString(SR.mismatchIARCancel)) - open AsyncPrimitives +open AsyncPrimitives - [] - type AsyncBuilder() = - member _.Zero () = unitAsync +[] +type AsyncBuilder() = + member _.Zero () = unitAsync - member _.Delay generator = CreateDelayAsync generator + member _.Delay generator = CreateDelayAsync generator - member inline _.Return value = CreateReturnAsync value + member inline _.Return value = CreateReturnAsync value - member inline _.ReturnFrom (computation:Async<_>) = computation + member inline _.ReturnFrom (computation:Async<_>) = computation - member inline _.Bind (computation, binder) = CreateBindAsync computation binder + member inline _.Bind (computation, binder) = CreateBindAsync computation binder - member _.Using (resource, binder) = CreateUsingAsync resource binder + member _.Using (resource, binder) = CreateUsingAsync resource binder - member _.While (guard, computation) = CreateWhileAsync guard computation + member _.While (guard, computation) = CreateWhileAsync guard computation - member _.For (sequence, body) = CreateForLoopAsync sequence body + member _.For (sequence, body) = CreateForLoopAsync sequence body - member inline _.Combine (computation1, computation2) = CreateSequentialAsync computation1 computation2 + member inline _.Combine (computation1, computation2) = CreateSequentialAsync computation1 computation2 - member inline _.TryFinally (computation, compensation) = CreateTryFinallyAsync compensation computation + member inline _.TryFinally (computation, compensation) = CreateTryFinallyAsync compensation computation - member inline _.TryWith (computation, catchHandler) = CreateTryWithAsync catchHandler computation + member inline _.TryWith (computation, catchHandler) = CreateTryWithAsync catchHandler computation - // member inline _.TryWithFilter (computation, catchHandler) = CreateTryWithFilterAsync catchHandler computation + // member inline _.TryWithFilter (computation, catchHandler) = CreateTryWithFilterAsync catchHandler computation - [] - module AsyncBuilderImpl = - let async = AsyncBuilder() +[] +module AsyncBuilderImpl = + let async = AsyncBuilder() - [] - type Async = +[] +type Async = - static member CancellationToken = cancellationTokenAsync + static member CancellationToken = cancellationTokenAsync - static member CancelCheck () = unitAsync + static member CancelCheck () = unitAsync - static member FromContinuations (callback: ('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) : Async<'T> = - MakeAsyncWithCancelCheck (fun ctxt -> - let mutable underCurrentThreadStack = true - let mutable contToTailCall = None - let thread = Thread.CurrentThread - let latch = Latch() - let once cont x = - if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) - if Thread.CurrentThread.Equals thread && underCurrentThreadStack then - contToTailCall <- Some(fun () -> cont x) - elif Trampoline.ThisThreadHasTrampoline then - let syncCtxt = SynchronizationContext.Current - ctxt.trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> cont x) |> unfake - else - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> cont x ) |> unfake + static member FromContinuations (callback: ('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) : Async<'T> = + MakeAsyncWithCancelCheck (fun ctxt -> + let mutable underCurrentThreadStack = true + let mutable contToTailCall = None + let thread = Thread.CurrentThread + let latch = Latch() + let once cont x = + if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + if Thread.CurrentThread.Equals thread && underCurrentThreadStack then + contToTailCall <- Some(fun () -> cont x) + elif Trampoline.ThisThreadHasTrampoline then + let syncCtxt = SynchronizationContext.Current + ctxt.trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> cont x) |> unfake + else + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> cont x ) |> unfake + try + callback (once ctxt.cont, (fun exn -> once ctxt.econt (ExceptionDispatchInfo.RestoreOrCapture exn)), once ctxt.ccont) + with exn -> + if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + let edi = ExceptionDispatchInfo.RestoreOrCapture exn + ctxt.econt edi |> unfake + + underCurrentThreadStack <- false + + match contToTailCall with + | Some k -> k() + | _ -> fake()) + + static member DefaultCancellationToken = defaultCancellationTokenSource.Token + + static member CancelDefaultToken() = + let cts = defaultCancellationTokenSource + // set new CancellationTokenSource before calling Cancel - otherwise if Cancel throws token will stay unchanged + defaultCancellationTokenSource <- new CancellationTokenSource() + cts.Cancel() + // we do not dispose the old default CTS - let GC collect it + + static member Catch (computation: Async<'T>) = + MakeAsync (fun ctxt -> + // Turn the success or exception into data + let newCtxt = ctxt.WithContinuations(cont = (fun res -> ctxt.cont (Choice1Of2 res)), + econt = (fun edi -> ctxt.cont (Choice2Of2 (edi.GetAssociatedSourceException())))) + computation.Invoke newCtxt) + + static member RunSynchronously (computation: Async<'T>, ?timeout, ?cancellationToken:CancellationToken) = + let timeout, cancellationToken = + match cancellationToken with + | None -> timeout, defaultCancellationTokenSource.Token + | Some token when not token.CanBeCanceled -> timeout, token + | Some token -> None, token + AsyncPrimitives.RunSynchronously cancellationToken computation timeout + + static member Start (computation, ?cancellationToken) = + let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.Start cancellationToken computation + + static member StartAsTask (computation, ?taskCreationOptions, ?cancellationToken)= + let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions + + static member StartChildAsTask (computation, ?taskCreationOptions) = + async { + let! cancellationToken = cancellationTokenAsync + return AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions + } + + static member Parallel (computations: seq>) = + Async.Parallel(computations, ?maxDegreeOfParallelism=None) + + static member Parallel (computations: seq>, ?maxDegreeOfParallelism: int) = + match maxDegreeOfParallelism with + | Some x when x < 1 -> raise(System.ArgumentException(String.Format(SR.GetString(SR.maxDegreeOfParallelismNotPositive), x), "maxDegreeOfParallelism")) + | _ -> () + + MakeAsyncWithCancelCheck (fun ctxt -> + // manually protect eval of seq + let result = try - callback (once ctxt.cont, (fun exn -> once ctxt.econt (ExceptionDispatchInfo.RestoreOrCapture exn)), once ctxt.ccont) + Choice1Of2 (Seq.toArray computations) with exn -> - if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) - let edi = ExceptionDispatchInfo.RestoreOrCapture exn - ctxt.econt edi |> unfake - - underCurrentThreadStack <- false - - match contToTailCall with - | Some k -> k() - | _ -> fake()) - - static member DefaultCancellationToken = defaultCancellationTokenSource.Token - - static member CancelDefaultToken() = - let cts = defaultCancellationTokenSource - // set new CancellationTokenSource before calling Cancel - otherwise if Cancel throws token will stay unchanged - defaultCancellationTokenSource <- new CancellationTokenSource() - cts.Cancel() - // we do not dispose the old default CTS - let GC collect it - - static member Catch (computation: Async<'T>) = - MakeAsync (fun ctxt -> - // Turn the success or exception into data - let newCtxt = ctxt.WithContinuations(cont = (fun res -> ctxt.cont (Choice1Of2 res)), - econt = (fun edi -> ctxt.cont (Choice2Of2 (edi.GetAssociatedSourceException())))) - computation.Invoke newCtxt) - - static member RunSynchronously (computation: Async<'T>, ?timeout, ?cancellationToken:CancellationToken) = - let timeout, cancellationToken = - match cancellationToken with - | None -> timeout, defaultCancellationTokenSource.Token - | Some token when not token.CanBeCanceled -> timeout, token - | Some token -> None, token - AsyncPrimitives.RunSynchronously cancellationToken computation timeout - - static member Start (computation, ?cancellationToken) = - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token - AsyncPrimitives.Start cancellationToken computation - - static member StartAsTask (computation, ?taskCreationOptions, ?cancellationToken)= - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token - AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions - - static member StartChildAsTask (computation, ?taskCreationOptions) = - async { - let! cancellationToken = cancellationTokenAsync - return AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions - } - - static member Parallel (computations: seq>) = - Async.Parallel(computations, ?maxDegreeOfParallelism=None) + Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) + + match result with + | Choice2Of2 edi -> ctxt.econt edi + | Choice1Of2 [| |] -> ctxt.cont [| |] + | Choice1Of2 computations -> + ctxt.ProtectCode (fun () -> + let ctxt = DelimitSyncContext ctxt // manually resync + let mutable count = computations.Length + let mutable firstExn = None + let results = Array.zeroCreate computations.Length + // Attempt to cancel the individual operations if an exception happens on any of the other threads + let innerCTS = new LinkedSubSource(ctxt.token) + + let finishTask remaining = + if (remaining = 0) then + innerCTS.Dispose() + match firstExn with + | None -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont results) + | Some (Choice1Of2 exn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) + | Some (Choice2Of2 cexn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) + else + fake() - static member Parallel (computations: seq>, ?maxDegreeOfParallelism: int) = - match maxDegreeOfParallelism with - | Some x when x < 1 -> raise(System.ArgumentException(String.Format(SR.GetString(SR.maxDegreeOfParallelismNotPositive), x), "maxDegreeOfParallelism")) - | _ -> () + // recordSuccess and recordFailure between them decrement count to 0 and + // as soon as 0 is reached dispose innerCancellationSource - MakeAsyncWithCancelCheck (fun ctxt -> - // manually protect eval of seq - let result = - try - Choice1Of2 (Seq.toArray computations) - with exn -> - Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) + let recordSuccess i res = + results.[i] <- res + finishTask(Interlocked.Decrement &count) - match result with - | Choice2Of2 edi -> ctxt.econt edi - | Choice1Of2 [| |] -> ctxt.cont [| |] - | Choice1Of2 computations -> - ctxt.ProtectCode (fun () -> - let ctxt = DelimitSyncContext ctxt // manually resync - let mutable count = computations.Length - let mutable firstExn = None - let results = Array.zeroCreate computations.Length - // Attempt to cancel the individual operations if an exception happens on any of the other threads - let innerCTS = new LinkedSubSource(ctxt.token) - - let finishTask remaining = - if (remaining = 0) then - innerCTS.Dispose() - match firstExn with - | None -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont results) - | Some (Choice1Of2 exn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) - | Some (Choice2Of2 cexn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) - else - fake() - - // recordSuccess and recordFailure between them decrement count to 0 and - // as soon as 0 is reached dispose innerCancellationSource - - let recordSuccess i res = - results.[i] <- res - finishTask(Interlocked.Decrement &count) - - let recordFailure exn = - // capture first exception and then decrement the counter to avoid race when - // - thread 1 decremented counter and preempted by the scheduler - // - thread 2 decremented counter and called finishTask - // since exception is not yet captured - finishtask will fall into success branch - match Interlocked.CompareExchange(&firstExn, Some exn, None) with - | None -> - // signal cancellation before decrementing the counter - this guarantees that no other thread can sneak to finishTask and dispose innerCTS - // NOTE: Cancel may introduce reentrancy - i.e. when handler registered for the cancellation token invokes cancel continuation that will call 'recordFailure' - // to correctly handle this we need to return decremented value, not the current value of 'count' otherwise we may invoke finishTask with value '0' several times - innerCTS.Cancel() - | _ -> () - finishTask(Interlocked.Decrement &count) - - // If maxDegreeOfParallelism is set but is higher then the number of tasks we have we set it back to None to fall into the simple - // queue all items branch - let maxDegreeOfParallelism = - match maxDegreeOfParallelism with - | None -> None - | Some x when x >= computations.Length -> None - | Some _ as x -> x - - // Simple case (no maxDegreeOfParallelism) just queue all the work, if we have maxDegreeOfParallelism set we start that many workers - // which will make progress on the actual computations - match maxDegreeOfParallelism with + let recordFailure exn = + // capture first exception and then decrement the counter to avoid race when + // - thread 1 decremented counter and preempted by the scheduler + // - thread 2 decremented counter and called finishTask + // since exception is not yet captured - finishtask will fall into success branch + match Interlocked.CompareExchange(&firstExn, Some exn, None) with | None -> - computations |> Array.iteri (fun i p -> - QueueAsync - innerCTS.Token - // on success, record the result - (fun res -> recordSuccess i res) - // on exception... - (fun edi -> recordFailure (Choice1Of2 edi)) - // on cancellation... - (fun cexn -> recordFailure (Choice2Of2 cexn)) - p - |> unfake) - | Some maxDegreeOfParallelism -> - let mutable i = -1 - let rec worker (trampolineHolder : TrampolineHolder) = - if i < computations.Length then - let j = Interlocked.Increment &i - if j < computations.Length then - if innerCTS.Token.IsCancellationRequested then - let cexn = OperationCanceledException (innerCTS.Token) - recordFailure (Choice2Of2 cexn) |> unfake - worker trampolineHolder |> unfake - else - let taskCtxt = - AsyncActivation.Create - innerCTS.Token - trampolineHolder - (fun res -> recordSuccess j res |> unfake; worker trampolineHolder) - (fun edi -> recordFailure (Choice1Of2 edi) |> unfake; worker trampolineHolder) - (fun cexn -> recordFailure (Choice2Of2 cexn) |> unfake; worker trampolineHolder) - computations.[j].Invoke taskCtxt |> unfake - fake() - for x = 1 to maxDegreeOfParallelism do - let trampolineHolder = TrampolineHolder() - trampolineHolder.QueueWorkItemWithTrampoline (fun () -> - worker trampolineHolder) - |> unfake + // signal cancellation before decrementing the counter - this guarantees that no other thread can sneak to finishTask and dispose innerCTS + // NOTE: Cancel may introduce reentrancy - i.e. when handler registered for the cancellation token invokes cancel continuation that will call 'recordFailure' + // to correctly handle this we need to return decremented value, not the current value of 'count' otherwise we may invoke finishTask with value '0' several times + innerCTS.Cancel() + | _ -> () + finishTask(Interlocked.Decrement &count) + + // If maxDegreeOfParallelism is set but is higher then the number of tasks we have we set it back to None to fall into the simple + // queue all items branch + let maxDegreeOfParallelism = + match maxDegreeOfParallelism with + | None -> None + | Some x when x >= computations.Length -> None + | Some _ as x -> x - fake())) + // Simple case (no maxDegreeOfParallelism) just queue all the work, if we have maxDegreeOfParallelism set we start that many workers + // which will make progress on the actual computations + match maxDegreeOfParallelism with + | None -> + computations |> Array.iteri (fun i p -> + QueueAsync + innerCTS.Token + // on success, record the result + (fun res -> recordSuccess i res) + // on exception... + (fun edi -> recordFailure (Choice1Of2 edi)) + // on cancellation... + (fun cexn -> recordFailure (Choice2Of2 cexn)) + p + |> unfake) + | Some maxDegreeOfParallelism -> + let mutable i = -1 + let rec worker (trampolineHolder : TrampolineHolder) = + if i < computations.Length then + let j = Interlocked.Increment &i + if j < computations.Length then + if innerCTS.Token.IsCancellationRequested then + let cexn = OperationCanceledException (innerCTS.Token) + recordFailure (Choice2Of2 cexn) |> unfake + worker trampolineHolder |> unfake + else + let taskCtxt = + AsyncActivation.Create + innerCTS.Token + trampolineHolder + (fun res -> recordSuccess j res |> unfake; worker trampolineHolder) + (fun edi -> recordFailure (Choice1Of2 edi) |> unfake; worker trampolineHolder) + (fun cexn -> recordFailure (Choice2Of2 cexn) |> unfake; worker trampolineHolder) + computations.[j].Invoke taskCtxt |> unfake + fake() + for x = 1 to maxDegreeOfParallelism do + let trampolineHolder = TrampolineHolder() + trampolineHolder.QueueWorkItemWithTrampoline (fun () -> + worker trampolineHolder) + |> unfake - static member Sequential (computations: seq>) = - Async.Parallel(computations, maxDegreeOfParallelism=1) + fake())) - static member Choice(computations: Async<'T option> seq) : Async<'T option> = - MakeAsyncWithCancelCheck (fun ctxt -> - // manually protect eval of seq - let result = - try - Choice1Of2 (Seq.toArray computations) - with exn -> - Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) + static member Sequential (computations: seq>) = + Async.Parallel(computations, maxDegreeOfParallelism=1) - match result with - | Choice2Of2 edi -> ctxt.econt edi - | Choice1Of2 [| |] -> ctxt.cont None - | Choice1Of2 computations -> - let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode (fun () -> - let mutable count = computations.Length - let mutable noneCount = 0 - let mutable someOrExnCount = 0 - let innerCts = new LinkedSubSource(ctxt.token) - - let scont (result: 'T option) = - let result = - match result with - | Some _ -> - if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont result) - else - fake() - - | None -> - if Interlocked.Increment &noneCount = computations.Length then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont None) - else - fake() - - if Interlocked.Decrement &count = 0 then - innerCts.Dispose() - - result - - let econt (exn: ExceptionDispatchInfo) = - let result = + static member Choice(computations: Async<'T option> seq) : Async<'T option> = + MakeAsyncWithCancelCheck (fun ctxt -> + // manually protect eval of seq + let result = + try + Choice1Of2 (Seq.toArray computations) + with exn -> + Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) + + match result with + | Choice2Of2 edi -> ctxt.econt edi + | Choice1Of2 [| |] -> ctxt.cont None + | Choice1Of2 computations -> + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode (fun () -> + let mutable count = computations.Length + let mutable noneCount = 0 + let mutable someOrExnCount = 0 + let innerCts = new LinkedSubSource(ctxt.token) + + let scont (result: 'T option) = + let result = + match result with + | Some _ -> if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont result) else fake() - if Interlocked.Decrement &count = 0 then - innerCts.Dispose() - - result - - let ccont (cexn: OperationCanceledException) = - let result = - if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) + | None -> + if Interlocked.Increment &noneCount = computations.Length then + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont None) else fake() - if Interlocked.Decrement &count = 0 then - innerCts.Dispose() + if Interlocked.Decrement &count = 0 then + innerCts.Dispose() - result + result - for computation in computations do - QueueAsync innerCts.Token scont econt ccont computation |> unfake + let econt (exn: ExceptionDispatchInfo) = + let result = + if Interlocked.Increment &someOrExnCount = 1 then + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) + else + fake() - fake())) + if Interlocked.Decrement &count = 0 then + innerCts.Dispose() - /// StartWithContinuations, except the exception continuation is given an ExceptionDispatchInfo - static member StartWithContinuationsUsingDispatchInfo(computation:Async<'T>, continuation, exceptionContinuation, cancellationContinuation, ?cancellationToken) : unit = - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token - AsyncPrimitives.StartWithContinuations cancellationToken computation continuation exceptionContinuation cancellationContinuation + result - static member StartWithContinuations(computation:Async<'T>, continuation, exceptionContinuation, cancellationContinuation, ?cancellationToken) : unit = - Async.StartWithContinuationsUsingDispatchInfo(computation, continuation, (fun edi -> exceptionContinuation (edi.GetAssociatedSourceException())), cancellationContinuation, ?cancellationToken=cancellationToken) + let ccont (cexn: OperationCanceledException) = + let result = + if Interlocked.Increment &someOrExnCount = 1 then + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) + else + fake() - static member StartImmediateAsTask (computation: Async<'T>, ?cancellationToken ) : Task<'T>= - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token - let ts = TaskCompletionSource<'T>() - let task = ts.Task - Async.StartWithContinuations( - computation, - (fun k -> ts.SetResult k), - (fun exn -> ts.SetException exn), - (fun _ -> ts.SetCanceled()), - cancellationToken) - task + if Interlocked.Decrement &count = 0 then + innerCts.Dispose() - static member StartImmediate(computation:Async, ?cancellationToken) : unit = - let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token - AsyncPrimitives.StartWithContinuations cancellationToken computation id (fun edi -> edi.ThrowAny()) ignore + result - static member Sleep (millisecondsDueTime: int64) : Async = - MakeAsyncWithCancelCheck (fun ctxt -> + for computation in computations do + QueueAsync innerCts.Token scont econt ccont computation |> unfake + + fake())) + + /// StartWithContinuations, except the exception continuation is given an ExceptionDispatchInfo + static member StartWithContinuationsUsingDispatchInfo(computation:Async<'T>, continuation, exceptionContinuation, cancellationContinuation, ?cancellationToken) : unit = + let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.StartWithContinuations cancellationToken computation continuation exceptionContinuation cancellationContinuation + + static member StartWithContinuations(computation:Async<'T>, continuation, exceptionContinuation, cancellationContinuation, ?cancellationToken) : unit = + Async.StartWithContinuationsUsingDispatchInfo(computation, continuation, (fun edi -> exceptionContinuation (edi.GetAssociatedSourceException())), cancellationContinuation, ?cancellationToken=cancellationToken) + + static member StartImmediateAsTask (computation: Async<'T>, ?cancellationToken ) : Task<'T>= + let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + let ts = TaskCompletionSource<'T>() + let task = ts.Task + Async.StartWithContinuations( + computation, + (fun k -> ts.SetResult k), + (fun exn -> ts.SetException exn), + (fun _ -> ts.SetCanceled()), + cancellationToken) + task + + static member StartImmediate(computation:Async, ?cancellationToken) : unit = + let cancellationToken = defaultArg cancellationToken defaultCancellationTokenSource.Token + AsyncPrimitives.StartWithContinuations cancellationToken computation id (fun edi -> edi.ThrowAny()) ignore + + static member Sleep (millisecondsDueTime: int64) : Async = + MakeAsyncWithCancelCheck (fun ctxt -> + let ctxt = DelimitSyncContext ctxt + let mutable edi = null + let latch = Latch() + let mutable timer: Timer option = None + let mutable registration: CancellationTokenRegistration option = None + registration <- + ctxt.token.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration + DisposeTimer &timer + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake) + ) |> Some + try + timer <- new Timer(TimerCallback(fun _ -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration + DisposeTimer &timer + // Now we're done, so call the continuation + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont()) |> unfake), + null, dueTime=millisecondsDueTime, period = -1L) |> Some + with exn -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration + // Prepare to call exception continuation + edi <- ExceptionDispatchInfo.RestoreOrCapture exn + + // Call exception continuation if necessary + match edi with + | null -> + fake() + | _ -> + ctxt.econt edi) + + static member Sleep (millisecondsDueTime: int32) : Async = + Async.Sleep (millisecondsDueTime |> int64) + + static member Sleep (dueTime: TimeSpan) = + if dueTime < TimeSpan.Zero then + raise (ArgumentOutOfRangeException("dueTime")) + else + Async.Sleep (dueTime.TotalMilliseconds |> Checked.int64) + + /// Wait for a wait handle. Both timeout and cancellation are supported + static member AwaitWaitHandle(waitHandle: WaitHandle, ?millisecondsTimeout:int) = + MakeAsyncWithCancelCheck (fun ctxt -> + let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite + if millisecondsTimeout = 0 then + let ok = waitHandle.WaitOne(0, exitContext=false) + ctxt.cont ok + else let ctxt = DelimitSyncContext ctxt let mutable edi = null let latch = Latch() - let mutable timer: Timer option = None + let mutable rwh: RegisteredWaitHandle option = None let mutable registration: CancellationTokenRegistration option = None registration <- ctxt.token.Register(Action(fun () -> if latch.Enter() then // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration - DisposeTimer &timer - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake) - ) |> Some + DisposeCancellationRegistration ®istration + + UnregisterWaitHandle &rwh + + // Call the cancellation continuation + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake)) + |> Some + try - timer <- new Timer(TimerCallback(fun _ -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration - DisposeTimer &timer - // Now we're done, so call the continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont()) |> unfake), - null, dueTime=millisecondsDueTime, period = -1L) |> Some + rwh <- ThreadPool.RegisterWaitForSingleObject(waitObject=waitHandle, + callBack=WaitOrTimerCallback(fun _ timeOut -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration + UnregisterWaitHandle &rwh + // Call the success continuation + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont (not timeOut)) |> unfake), + state=null, + millisecondsTimeOutInterval=millisecondsTimeout, + executeOnlyOnce=true) + |> Some with exn -> if latch.Enter() then // Ensure cancellation is not possible beyond this point @@ -1621,445 +1682,384 @@ namespace Microsoft.FSharp.Control | null -> fake() | _ -> + // Call the exception continuation ctxt.econt edi) - static member Sleep (millisecondsDueTime: int32) : Async = - Async.Sleep (millisecondsDueTime |> int64) - - static member Sleep (dueTime: TimeSpan) = - if dueTime < TimeSpan.Zero then - raise (ArgumentOutOfRangeException("dueTime")) + static member AwaitIAsyncResult(iar: IAsyncResult, ?millisecondsTimeout) = + async { + if iar.CompletedSynchronously then + return true else - Async.Sleep (dueTime.TotalMilliseconds |> Checked.int64) - - /// Wait for a wait handle. Both timeout and cancellation are supported - static member AwaitWaitHandle(waitHandle: WaitHandle, ?millisecondsTimeout:int) = - MakeAsyncWithCancelCheck (fun ctxt -> - let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite - if millisecondsTimeout = 0 then - let ok = waitHandle.WaitOne(0, exitContext=false) - ctxt.cont ok - else - let ctxt = DelimitSyncContext ctxt - let mutable edi = null - let latch = Latch() - let mutable rwh: RegisteredWaitHandle option = None - let mutable registration: CancellationTokenRegistration option = None - registration <- - ctxt.token.Register(Action(fun () -> - if latch.Enter() then - // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration - - UnregisterWaitHandle &rwh - - // Call the cancellation continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake)) - |> Some - - try - rwh <- ThreadPool.RegisterWaitForSingleObject(waitObject=waitHandle, - callBack=WaitOrTimerCallback(fun _ timeOut -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration - UnregisterWaitHandle &rwh - // Call the success continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont (not timeOut)) |> unfake), - state=null, - millisecondsTimeOutInterval=millisecondsTimeout, - executeOnlyOnce=true) - |> Some - with exn -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration - // Prepare to call exception continuation - edi <- ExceptionDispatchInfo.RestoreOrCapture exn - - // Call exception continuation if necessary - match edi with - | null -> - fake() - | _ -> - // Call the exception continuation - ctxt.econt edi) - - static member AwaitIAsyncResult(iar: IAsyncResult, ?millisecondsTimeout) = - async { - if iar.CompletedSynchronously then - return true - else - return! Async.AwaitWaitHandle(iar.AsyncWaitHandle, ?millisecondsTimeout=millisecondsTimeout) + return! Async.AwaitWaitHandle(iar.AsyncWaitHandle, ?millisecondsTimeout=millisecondsTimeout) + } + + /// Await and use the result of a result cell. The resulting async doesn't support cancellation + /// or timeout directly, rather the underlying computation must fill the result if cancellation + /// or timeout occurs. + static member AwaitAndBindResult_NoDirectCancelOrTimeout(resultCell: ResultCell>) = + async { + let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout + return! CreateAsyncResultAsync result + } + + /// Await the result of a result cell belonging to a child computation. The resulting async supports timeout and if + /// it happens the child computation will be cancelled. The resulting async doesn't support cancellation + /// directly, rather the underlying computation must fill the result if cancellation occurs. + static member AwaitAndBindChildResult(innerCTS: CancellationTokenSource, resultCell: ResultCell>, millisecondsTimeout) : Async<'T> = + match millisecondsTimeout with + | None | Some -1 -> + resultCell |> Async.AwaitAndBindResult_NoDirectCancelOrTimeout + + | Some 0 -> + async { if resultCell.ResultAvailable then + let res = resultCell.GrabResult() + return res.Commit() + else + return raise (System.TimeoutException()) } + | _ -> + async { + try + if resultCell.ResultAvailable then + let res = resultCell.GrabResult() + return res.Commit() + else + let! ok = Async.AwaitWaitHandle (resultCell.GetWaitHandle(), ?millisecondsTimeout=millisecondsTimeout) + if ok then + let res = resultCell.GrabResult() + return res.Commit() + else // timed out + // issue cancellation signal + innerCTS.Cancel() + // wait for computation to quiesce + let! _ = Async.AwaitWaitHandle (resultCell.GetWaitHandle()) + return raise (System.TimeoutException()) + finally + resultCell.Close() } - /// Await and use the result of a result cell. The resulting async doesn't support cancellation - /// or timeout directly, rather the underlying computation must fill the result if cancellation - /// or timeout occurs. - static member AwaitAndBindResult_NoDirectCancelOrTimeout(resultCell: ResultCell>) = - async { - let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout - return! CreateAsyncResultAsync result - } - /// Await the result of a result cell belonging to a child computation. The resulting async supports timeout and if - /// it happens the child computation will be cancelled. The resulting async doesn't support cancellation - /// directly, rather the underlying computation must fill the result if cancellation occurs. - static member AwaitAndBindChildResult(innerCTS: CancellationTokenSource, resultCell: ResultCell>, millisecondsTimeout) : Async<'T> = - match millisecondsTimeout with - | None | Some -1 -> - resultCell |> Async.AwaitAndBindResult_NoDirectCancelOrTimeout + static member FromBeginEnd(beginAction, endAction, ?cancelAction): Async<'T> = + async { + let! ct = cancellationTokenAsync + let resultCell = new ResultCell<_>() - | Some 0 -> - async { if resultCell.ResultAvailable then - let res = resultCell.GrabResult() - return res.Commit() - else - return raise (System.TimeoutException()) } - | _ -> - async { - try - if resultCell.ResultAvailable then - let res = resultCell.GrabResult() - return res.Commit() - else - let! ok = Async.AwaitWaitHandle (resultCell.GetWaitHandle(), ?millisecondsTimeout=millisecondsTimeout) - if ok then - let res = resultCell.GrabResult() - return res.Commit() - else // timed out - // issue cancellation signal - innerCTS.Cancel() - // wait for computation to quiesce - let! _ = Async.AwaitWaitHandle (resultCell.GetWaitHandle()) - return raise (System.TimeoutException()) - finally - resultCell.Close() - } - - - static member FromBeginEnd(beginAction, endAction, ?cancelAction): Async<'T> = - async { - let! ct = cancellationTokenAsync - let resultCell = new ResultCell<_>() + let latch = Latch() + let mutable registration: CancellationTokenRegistration option = None + registration <- + ct.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration - let latch = Latch() - let mutable registration: CancellationTokenRegistration option = None - registration <- - ct.Register(Action(fun () -> + // Call the cancellation function. Ignore any exceptions from the + // cancellation function. + match cancelAction with + | None -> () + | Some cancel -> + try cancel() with _ -> () + + // Register the cancellation result. + let canceledResult = Canceled (OperationCanceledException ct) + resultCell.RegisterResult(canceledResult, reuseThread=true) |> unfake)) + |> Some + + let callback = + AsyncCallback(fun iar -> + if not iar.CompletedSynchronously then if latch.Enter() then - // Make sure we're not cancelled again + // Ensure cancellation is not possible beyond this point DisposeCancellationRegistration ®istration - // Call the cancellation function. Ignore any exceptions from the - // cancellation function. - match cancelAction with - | None -> () - | Some cancel -> - try cancel() with _ -> () + // Run the endAction and collect its result. + let res = + try + Ok(endAction iar) + with exn -> + let edi = ExceptionDispatchInfo.RestoreOrCapture exn + Error edi + + // Register the result. + resultCell.RegisterResult(res, reuseThread=true) |> unfake) + + let (iar:IAsyncResult) = beginAction (callback, (null:obj)) + if iar.CompletedSynchronously then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration + return endAction iar + else + // Note: ok to use "NoDirectCancel" here because cancellation has been registered above + // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method + return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell + } + + + static member FromBeginEnd(arg, beginAction, endAction, ?cancelAction): Async<'T> = + Async.FromBeginEnd((fun (iar, state) -> beginAction(arg, iar, state)), endAction, ?cancelAction=cancelAction) + + static member FromBeginEnd(arg1, arg2, beginAction, endAction, ?cancelAction): Async<'T> = + Async.FromBeginEnd((fun (iar, state) -> beginAction(arg1, arg2, iar, state)), endAction, ?cancelAction=cancelAction) + + static member FromBeginEnd(arg1, arg2, arg3, beginAction, endAction, ?cancelAction): Async<'T> = + Async.FromBeginEnd((fun (iar, state) -> beginAction(arg1, arg2, arg3, iar, state)), endAction, ?cancelAction=cancelAction) + + static member AsBeginEnd<'Arg, 'T> (computation:('Arg -> Async<'T>)) : + // The 'Begin' member + ('Arg * System.AsyncCallback * obj -> System.IAsyncResult) * + // The 'End' member + (System.IAsyncResult -> 'T) * + // The 'Cancel' member + (System.IAsyncResult -> unit) = + let beginAction = fun (a1, callback, state) -> AsBeginEndHelpers.beginAction ((computation a1), callback, state) + beginAction, AsBeginEndHelpers.endAction<'T>, AsBeginEndHelpers.cancelAction<'T> + + static member AwaitEvent(event:IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = + async { + let! ct = cancellationTokenAsync + let resultCell = new ResultCell<_>() + // Set up the handlers to listen to events and cancellation + let latch = Latch() + let mutable registration: CancellationTokenRegistration option = None + let mutable del: 'Delegate option = None + registration <- + ct.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeCancellationRegistration ®istration - // Register the cancellation result. - let canceledResult = Canceled (OperationCanceledException ct) - resultCell.RegisterResult(canceledResult, reuseThread=true) |> unfake)) - |> Some + // Stop listening to events + RemoveHandler event &del + + // Call the given cancellation routine if we've been given one + // Exceptions from a cooperative cancellation are ignored. + match cancelAction with + | None -> () + | Some cancel -> + try cancel() with _ -> () + + // Register the cancellation result. + resultCell.RegisterResult(Canceled (OperationCanceledException ct), reuseThread=true) |> unfake + )) |> Some + + let del = + FuncDelegate<'T>.Create<'Delegate>(fun eventArgs -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration - let callback = - AsyncCallback(fun iar -> - if not iar.CompletedSynchronously then - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + // Stop listening to events + RemoveHandler event &del - // Run the endAction and collect its result. - let res = - try - Ok(endAction iar) - with exn -> - let edi = ExceptionDispatchInfo.RestoreOrCapture exn - Error edi + // Register the successful result. + resultCell.RegisterResult(Ok eventArgs, reuseThread=true) |> unfake) - // Register the result. - resultCell.RegisterResult(res, reuseThread=true) |> unfake) + // Start listening to events + event.AddHandler del - let (iar:IAsyncResult) = beginAction (callback, (null:obj)) - if iar.CompletedSynchronously then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration - return endAction iar - else - // Note: ok to use "NoDirectCancel" here because cancellation has been registered above - // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method - return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell - } + // Return the async computation that allows us to await the result + // Note: ok to use "NoDirectCancel" here because cancellation has been registered above + // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method + return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } + static member Ignore (computation: Async<'T>) = CreateIgnoreAsync computation - static member FromBeginEnd(arg, beginAction, endAction, ?cancelAction): Async<'T> = - Async.FromBeginEnd((fun (iar, state) -> beginAction(arg, iar, state)), endAction, ?cancelAction=cancelAction) + static member SwitchToNewThread() = CreateSwitchToNewThreadAsync() - static member FromBeginEnd(arg1, arg2, beginAction, endAction, ?cancelAction): Async<'T> = - Async.FromBeginEnd((fun (iar, state) -> beginAction(arg1, arg2, iar, state)), endAction, ?cancelAction=cancelAction) + static member SwitchToThreadPool() = CreateSwitchToThreadPoolAsync() - static member FromBeginEnd(arg1, arg2, arg3, beginAction, endAction, ?cancelAction): Async<'T> = - Async.FromBeginEnd((fun (iar, state) -> beginAction(arg1, arg2, arg3, iar, state)), endAction, ?cancelAction=cancelAction) + static member StartChild (computation:Async<'T>, ?millisecondsTimeout) = + async { + let resultCell = new ResultCell<_>() + let! ct = cancellationTokenAsync + let innerCTS = new CancellationTokenSource() // innerCTS does not require disposal + let mutable ctsRef = innerCTS + let registration = + ct.Register(Action(fun () -> + match ctsRef with + | null -> () + | otherwise -> otherwise.Cancel())) - static member AsBeginEnd<'Arg, 'T> (computation:('Arg -> Async<'T>)) : - // The 'Begin' member - ('Arg * System.AsyncCallback * obj -> System.IAsyncResult) * - // The 'End' member - (System.IAsyncResult -> 'T) * - // The 'Cancel' member - (System.IAsyncResult -> unit) = - let beginAction = fun (a1, callback, state) -> AsBeginEndHelpers.beginAction ((computation a1), callback, state) - beginAction, AsBeginEndHelpers.endAction<'T>, AsBeginEndHelpers.cancelAction<'T> + do QueueAsync + innerCTS.Token + // since innerCTS is not ever Disposed, can call reg.Dispose() without a safety Latch + (fun res -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Ok res, reuseThread=true)) + (fun edi -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Error edi, reuseThread=true)) + (fun err -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Canceled err, reuseThread=true)) + computation + |> unfake - static member AwaitEvent(event:IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = - async { - let! ct = cancellationTokenAsync - let resultCell = new ResultCell<_>() - // Set up the handlers to listen to events and cancellation - let latch = Latch() - let mutable registration: CancellationTokenRegistration option = None - let mutable del: 'Delegate option = None - registration <- - ct.Register(Action(fun () -> + return Async.AwaitAndBindChildResult(innerCTS, resultCell, millisecondsTimeout) } + + static member SwitchToContext syncContext = + async { + match syncContext with + | null -> + // no synchronization context, just switch to the thread pool + do! Async.SwitchToThreadPool() + | syncCtxt -> + // post the continuation to the synchronization context + return! CreateSwitchToAsync syncCtxt + } + + static member OnCancel interruption = + async { + let! ct = cancellationTokenAsync + // latch protects cancellation and disposal contention + let latch = Latch() + let mutable registration: CancellationTokenRegistration option = None + registration <- + ct.Register(Action(fun () -> if latch.Enter() then // Make sure we're not cancelled again DisposeCancellationRegistration ®istration + try + interruption () + with _ -> ())) + |> Some + let disposer = + { new System.IDisposable with + member _.Dispose() = + // dispose CancellationTokenRegistration only if cancellation was not requested. + // otherwise - do nothing, disposal will be performed by the handler itself + if not ct.IsCancellationRequested then + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeCancellationRegistration ®istration } + return disposer + } + + static member TryCancelled (computation: Async<'T>, compensation) = + CreateWhenCancelledAsync compensation computation + + static member AwaitTask (task:Task<'T>) : Async<'T> = + MakeAsyncWithCancelCheck (fun ctxt -> + if task.IsCompleted then + // Run synchronously without installing new trampoline + OnTaskCompleted task ctxt + else + // Continue asynchronously, via syncContext if necessary, installing new trampoline + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode (fun () -> AttachContinuationToTask task ctxt)) - // Stop listening to events - RemoveHandler event &del - - // Call the given cancellation routine if we've been given one - // Exceptions from a cooperative cancellation are ignored. - match cancelAction with - | None -> () - | Some cancel -> - try cancel() with _ -> () - - // Register the cancellation result. - resultCell.RegisterResult(Canceled (OperationCanceledException ct), reuseThread=true) |> unfake - )) |> Some - - let del = - FuncDelegate<'T>.Create<'Delegate>(fun eventArgs -> - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration + static member AwaitTask (task:Task) : Async = + MakeAsyncWithCancelCheck (fun ctxt -> + if task.IsCompleted then + // Continue synchronously without installing new trampoline + OnUnitTaskCompleted task ctxt + else + // Continue asynchronously, via syncContext if necessary, installing new trampoline + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode (fun () -> AttachContinuationToUnitTask task ctxt)) - // Stop listening to events - RemoveHandler event &del +module CommonExtensions = - // Register the successful result. - resultCell.RegisterResult(Ok eventArgs, reuseThread=true) |> unfake) + type System.IO.Stream with - // Start listening to events - event.AddHandler del + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member stream.AsyncRead(buffer: byte[], ?offset, ?count) = + let offset = defaultArg offset 0 + let count = defaultArg count buffer.Length + Async.FromBeginEnd (buffer, offset, count, stream.BeginRead, stream.EndRead) - // Return the async computation that allows us to await the result - // Note: ok to use "NoDirectCancel" here because cancellation has been registered above - // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method - return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member stream.AsyncRead count = + async { + let buffer = Array.zeroCreate count + let mutable i = 0 + while i < count do + let! n = stream.AsyncRead(buffer, i, count - i) + i <- i + n + if n = 0 then + raise(System.IO.EndOfStreamException(SR.GetString(SR.failedReadEnoughBytes))) + return buffer + } - static member Ignore (computation: Async<'T>) = CreateIgnoreAsync computation + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member stream.AsyncWrite(buffer:byte[], ?offset:int, ?count:int) = + let offset = defaultArg offset 0 + let count = defaultArg count buffer.Length + Async.FromBeginEnd (buffer, offset, count, stream.BeginWrite, stream.EndWrite) - static member SwitchToNewThread() = CreateSwitchToNewThreadAsync() + type IObservable<'Args> with - static member SwitchToThreadPool() = CreateSwitchToThreadPoolAsync() + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member x.Add(callback: 'Args -> unit) = x.Subscribe callback |> ignore - static member StartChild (computation:Async<'T>, ?millisecondsTimeout) = - async { - let resultCell = new ResultCell<_>() - let! ct = cancellationTokenAsync - let innerCTS = new CancellationTokenSource() // innerCTS does not require disposal - let mutable ctsRef = innerCTS - let registration = - ct.Register(Action(fun () -> - match ctsRef with - | null -> () - | otherwise -> otherwise.Cancel())) - - do QueueAsync - innerCTS.Token - // since innerCTS is not ever Disposed, can call reg.Dispose() without a safety Latch - (fun res -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Ok res, reuseThread=true)) - (fun edi -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Error edi, reuseThread=true)) - (fun err -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Canceled err, reuseThread=true)) - computation - |> unfake - - return Async.AwaitAndBindChildResult(innerCTS, resultCell, millisecondsTimeout) } - - static member SwitchToContext syncContext = - async { - match syncContext with - | null -> - // no synchronization context, just switch to the thread pool - do! Async.SwitchToThreadPool() - | syncCtxt -> - // post the continuation to the synchronization context - return! CreateSwitchToAsync syncCtxt - } + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member x.Subscribe callback = + x.Subscribe { new IObserver<'Args> with + member x.OnNext args = callback args + member x.OnError e = () + member x.OnCompleted() = () } - static member OnCancel interruption = - async { - let! ct = cancellationTokenAsync - // latch protects cancellation and disposal contention - let latch = Latch() - let mutable registration: CancellationTokenRegistration option = None - registration <- - ct.Register(Action(fun () -> - if latch.Enter() then - // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration - try - interruption () - with _ -> ())) - |> Some - let disposer = - { new System.IDisposable with - member _.Dispose() = - // dispose CancellationTokenRegistration only if cancellation was not requested. - // otherwise - do nothing, disposal will be performed by the handler itself - if not ct.IsCancellationRequested then - if latch.Enter() then - // Ensure cancellation is not possible beyond this point - DisposeCancellationRegistration ®istration } - return disposer - } +module WebExtensions = - static member TryCancelled (computation: Async<'T>, compensation) = - CreateWhenCancelledAsync compensation computation + type System.Net.WebRequest with + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member req.AsyncGetResponse() : Async= - static member AwaitTask (task:Task<'T>) : Async<'T> = - MakeAsyncWithCancelCheck (fun ctxt -> - if task.IsCompleted then - // Run synchronously without installing new trampoline - OnTaskCompleted task ctxt - else - // Continue asynchronously, via syncContext if necessary, installing new trampoline - let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode (fun () -> AttachContinuationToTask task ctxt)) - - static member AwaitTask (task:Task) : Async = - MakeAsyncWithCancelCheck (fun ctxt -> - if task.IsCompleted then - // Continue synchronously without installing new trampoline - OnUnitTaskCompleted task ctxt - else - // Continue asynchronously, via syncContext if necessary, installing new trampoline - let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode (fun () -> AttachContinuationToUnitTask task ctxt)) - - module CommonExtensions = - - type System.IO.Stream with - - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member stream.AsyncRead(buffer: byte[], ?offset, ?count) = - let offset = defaultArg offset 0 - let count = defaultArg count buffer.Length - Async.FromBeginEnd (buffer, offset, count, stream.BeginRead, stream.EndRead) - - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member stream.AsyncRead count = - async { - let buffer = Array.zeroCreate count - let mutable i = 0 - while i < count do - let! n = stream.AsyncRead(buffer, i, count - i) - i <- i + n - if n = 0 then - raise(System.IO.EndOfStreamException(SR.GetString(SR.failedReadEnoughBytes))) - return buffer - } - - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member stream.AsyncWrite(buffer:byte[], ?offset:int, ?count:int) = - let offset = defaultArg offset 0 - let count = defaultArg count buffer.Length - Async.FromBeginEnd (buffer, offset, count, stream.BeginWrite, stream.EndWrite) - - type IObservable<'Args> with - - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member x.Add(callback: 'Args -> unit) = x.Subscribe callback |> ignore - - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member x.Subscribe callback = - x.Subscribe { new IObserver<'Args> with - member x.OnNext args = callback args - member x.OnError e = () - member x.OnCompleted() = () } - - module WebExtensions = - - type System.Net.WebRequest with - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member req.AsyncGetResponse() : Async= - - let mutable canceled = false // WebException with Status = WebExceptionStatus.RequestCanceled can be raised in other situations except cancellation, use flag to filter out false positives - - // Use CreateTryWithFilterAsync to allow propagation of exception without losing stack - Async.FromBeginEnd(beginAction=req.BeginGetResponse, - endAction = req.EndGetResponse, - cancelAction = fun() -> canceled <- true; req.Abort()) - |> CreateTryWithFilterAsync (fun exn -> - match exn with - | :? System.Net.WebException as webExn - when webExn.Status = System.Net.WebExceptionStatus.RequestCanceled && canceled -> - - Some (CreateAsyncResultAsync(AsyncResult.Canceled (OperationCanceledException webExn.Message))) - | _ -> - None) - - type System.Net.WebClient with - member inline private this.Download(event: IEvent<'T, _>, handler: _ -> 'T, start, result) = - let downloadAsync = - Async.FromContinuations (fun (cont, econt, ccont) -> - let userToken = obj() - let rec delegate' (_: obj) (args: #ComponentModel.AsyncCompletedEventArgs) = - // ensure we handle the completed event from correct download call - if userToken = args.UserState then - event.RemoveHandler handle - if args.Cancelled then - ccont (OperationCanceledException()) - elif isNotNull args.Error then - econt args.Error - else - cont (result args) - and handle = handler delegate' - event.AddHandler handle - start userToken - ) - - async { - use! _holder = Async.OnCancel(fun _ -> this.CancelAsync()) - return! downloadAsync - } - - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member this.AsyncDownloadString (address:Uri) : Async = - this.Download( - event = this.DownloadStringCompleted, - handler = (fun action -> Net.DownloadStringCompletedEventHandler action), - start = (fun userToken -> this.DownloadStringAsync(address, userToken)), - result = (fun args -> args.Result) - ) + let mutable canceled = false // WebException with Status = WebExceptionStatus.RequestCanceled can be raised in other situations except cancellation, use flag to filter out false positives - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member this.AsyncDownloadData (address:Uri) : Async = - this.Download( - event = this.DownloadDataCompleted, - handler = (fun action -> Net.DownloadDataCompletedEventHandler action), - start = (fun userToken -> this.DownloadDataAsync(address, userToken)), - result = (fun args -> args.Result) - ) + // Use CreateTryWithFilterAsync to allow propagation of exception without losing stack + Async.FromBeginEnd(beginAction=req.BeginGetResponse, + endAction = req.EndGetResponse, + cancelAction = fun() -> canceled <- true; req.Abort()) + |> CreateTryWithFilterAsync (fun exn -> + match exn with + | :? System.Net.WebException as webExn + when webExn.Status = System.Net.WebExceptionStatus.RequestCanceled && canceled -> - [] // give the extension member a 'nice', unmangled compiled name, unique within this module - member this.AsyncDownloadFile (address:Uri, fileName:string) : Async = - this.Download( - event = this.DownloadFileCompleted, - handler = (fun action -> ComponentModel.AsyncCompletedEventHandler action), - start = (fun userToken -> this.DownloadFileAsync(address, fileName, userToken)), - result = (fun _ -> ()) + Some (CreateAsyncResultAsync(AsyncResult.Canceled (OperationCanceledException webExn.Message))) + | _ -> + None) + + type System.Net.WebClient with + member inline private this.Download(event: IEvent<'T, _>, handler: _ -> 'T, start, result) = + let downloadAsync = + Async.FromContinuations (fun (cont, econt, ccont) -> + let userToken = obj() + let rec delegate' (_: obj) (args: #ComponentModel.AsyncCompletedEventArgs) = + // ensure we handle the completed event from correct download call + if userToken = args.UserState then + event.RemoveHandler handle + if args.Cancelled then + ccont (OperationCanceledException()) + elif isNotNull args.Error then + econt args.Error + else + cont (result args) + and handle = handler delegate' + event.AddHandler handle + start userToken ) + + async { + use! _holder = Async.OnCancel(fun _ -> this.CancelAsync()) + return! downloadAsync + } + + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member this.AsyncDownloadString (address:Uri) : Async = + this.Download( + event = this.DownloadStringCompleted, + handler = (fun action -> Net.DownloadStringCompletedEventHandler action), + start = (fun userToken -> this.DownloadStringAsync(address, userToken)), + result = (fun args -> args.Result) + ) + + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member this.AsyncDownloadData (address:Uri) : Async = + this.Download( + event = this.DownloadDataCompleted, + handler = (fun action -> Net.DownloadDataCompletedEventHandler action), + start = (fun userToken -> this.DownloadDataAsync(address, userToken)), + result = (fun args -> args.Result) + ) + + [] // give the extension member a 'nice', unmangled compiled name, unique within this module + member this.AsyncDownloadFile (address:Uri, fileName:string) : Async = + this.Download( + event = this.DownloadFileCompleted, + handler = (fun action -> ComponentModel.AsyncCompletedEventHandler action), + start = (fun userToken -> this.DownloadFileAsync(address, fileName, userToken)), + result = (fun _ -> ()) + ) diff --git a/src/FSharp.Core/collections.fs b/src/FSharp.Core/collections.fs index f15cb4894a3050bed1c461bc655f72fd17bb98ed..b08a1989622c8631734cfefbce275dac91250b9e 100644 --- a/src/FSharp.Core/collections.fs +++ b/src/FSharp.Core/collections.fs @@ -2,49 +2,47 @@ namespace Microsoft.FSharp.Collections - #nowarn "51" - - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.Operators - open System.Collections.Generic - - module HashIdentity = - - - let inline Structural<'T when 'T : equality> : IEqualityComparer<'T> = - LanguagePrimitives.FastGenericEqualityComparer<'T> - - let inline LimitedStructural<'T when 'T : equality>(limit) : IEqualityComparer<'T> = - LanguagePrimitives.FastLimitedGenericEqualityComparer<'T>(limit) - - let Reference<'T when 'T : not struct > : IEqualityComparer<'T> = - { new IEqualityComparer<'T> with - member _.GetHashCode(x) = LanguagePrimitives.PhysicalHash(x) - member _.Equals(x,y) = LanguagePrimitives.PhysicalEquality x y } - - let inline NonStructural< 'T when 'T : equality and 'T : (static member ( = ) : 'T * 'T -> bool) > = - { new IEqualityComparer<'T> with - member _.GetHashCode(x) = NonStructuralComparison.hash x - member _.Equals(x, y) = NonStructuralComparison.(=) x y } - - let inline FromFunctions hasher equality : IEqualityComparer<'T> = - let eq = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(equality) - { new IEqualityComparer<'T> with - member _.GetHashCode(x) = hasher x - member _.Equals(x,y) = eq.Invoke(x,y) } - - - module ComparisonIdentity = - - let inline Structural<'T when 'T : comparison > : IComparer<'T> = - LanguagePrimitives.FastGenericComparer<'T> - - let inline NonStructural< 'T when 'T : (static member ( < ) : 'T * 'T -> bool) and 'T : (static member ( > ) : 'T * 'T -> bool) > : IComparer<'T> = - { new IComparer<'T> with - member _.Compare(x,y) = NonStructuralComparison.compare x y } - - let FromFunction comparer = - let comparer = OptimizedClosures.FSharpFunc<'T,'T,int>.Adapt(comparer) - { new IComparer<'T> with - member _.Compare(x,y) = comparer.Invoke(x,y) } +#nowarn "51" + +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +open System.Collections.Generic + +module HashIdentity = + + let inline Structural<'T when 'T : equality> : IEqualityComparer<'T> = + LanguagePrimitives.FastGenericEqualityComparer<'T> + + let inline LimitedStructural<'T when 'T : equality>(limit) : IEqualityComparer<'T> = + LanguagePrimitives.FastLimitedGenericEqualityComparer<'T>(limit) + + let Reference<'T when 'T : not struct > : IEqualityComparer<'T> = + { new IEqualityComparer<'T> with + member _.GetHashCode(x) = LanguagePrimitives.PhysicalHash(x) + member _.Equals(x,y) = LanguagePrimitives.PhysicalEquality x y } + + let inline NonStructural< 'T when 'T : equality and 'T : (static member ( = ) : 'T * 'T -> bool) > = + { new IEqualityComparer<'T> with + member _.GetHashCode(x) = NonStructuralComparison.hash x + member _.Equals(x, y) = NonStructuralComparison.(=) x y } + + let inline FromFunctions hasher equality : IEqualityComparer<'T> = + let eq = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(equality) + { new IEqualityComparer<'T> with + member _.GetHashCode(x) = hasher x + member _.Equals(x,y) = eq.Invoke(x,y) } + +module ComparisonIdentity = + + let inline Structural<'T when 'T : comparison > : IComparer<'T> = + LanguagePrimitives.FastGenericComparer<'T> + + let inline NonStructural< 'T when 'T : (static member ( < ) : 'T * 'T -> bool) and 'T : (static member ( > ) : 'T * 'T -> bool) > : IComparer<'T> = + { new IComparer<'T> with + member _.Compare(x,y) = NonStructuralComparison.compare x y } + + let FromFunction comparer = + let comparer = OptimizedClosures.FSharpFunc<'T,'T,int>.Adapt(comparer) + { new IComparer<'T> with + member _.Compare(x,y) = comparer.Invoke(x,y) } diff --git a/src/FSharp.Core/event.fs b/src/FSharp.Core/event.fs index 8e1d0826f334ef8347381cdcca2a9fce1068b7f6..054b31cbd0b5db044ea5fabd29e70c4eb925ecca 100644 --- a/src/FSharp.Core/event.fs +++ b/src/FSharp.Core/event.fs @@ -2,153 +2,153 @@ namespace Microsoft.FSharp.Control - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Collections - open Microsoft.FSharp.Control - open System.Reflection - open System.Diagnostics - - module private Atomic = - open System.Threading - - let inline setWith (thunk: 'a -> 'a) (value: byref<'a>) = - let mutable exchanged = false - let mutable oldValue = value - while not exchanged do - let comparand = oldValue - let newValue = thunk comparand - oldValue <- Interlocked.CompareExchange(&value, newValue, comparand) - if obj.ReferenceEquals(comparand, oldValue) then - exchanged <- true - - [] - type DelegateEvent<'Delegate when 'Delegate :> System.Delegate>() = - let mutable multicast : System.Delegate = null - member x.Trigger(args:obj[]) = - match multicast with - | null -> () - | d -> d.DynamicInvoke(args) |> ignore - member x.Publish = - { new IDelegateEvent<'Delegate> with - member x.AddHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Combine(value, d)) &multicast - member x.RemoveHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Remove(value, d)) &multicast } - - type EventDelegee<'Args>(observer: System.IObserver<'Args>) = - static let makeTuple = - if Microsoft.FSharp.Reflection.FSharpType.IsTuple(typeof<'Args>) then - Microsoft.FSharp.Reflection.FSharpValue.PreComputeTupleConstructor(typeof<'Args>) - else - fun _ -> assert false; null // should not be called, one-argument case don't use makeTuple function - - member x.Invoke(_sender:obj, args: 'Args) = - observer.OnNext args - member x.Invoke(_sender:obj, a, b) = - let args = makeTuple([|a; b|]) :?> 'Args - observer.OnNext args - member x.Invoke(_sender:obj, a, b, c) = - let args = makeTuple([|a; b; c|]) :?> 'Args - observer.OnNext args - member x.Invoke(_sender:obj, a, b, c, d) = - let args = makeTuple([|a; b; c; d|]) :?> 'Args - observer.OnNext args - member x.Invoke(_sender:obj, a, b, c, d, e) = - let args = makeTuple([|a; b; c; d; e|]) :?> 'Args - observer.OnNext args - member x.Invoke(_sender:obj, a, b, c, d, e, f) = - let args = makeTuple([|a; b; c; d; e; f|]) :?> 'Args - observer.OnNext args - - - type EventWrapper<'Delegate,'Args> = delegate of 'Delegate * obj * 'Args -> unit - - [] - type Event<'Delegate, 'Args when 'Delegate : delegate<'Args, unit> and 'Delegate :> System.Delegate and 'Delegate: not struct>() = - - let mutable multicast : 'Delegate = Unchecked.defaultof<_> - - static let mi, argTypes = - let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly - let mi = typeof<'Delegate>.GetMethod("Invoke",instanceBindingFlags) - let actualTypes = mi.GetParameters() |> Array.map (fun p -> p.ParameterType) - mi, actualTypes.[1..] - - // For the one-argument case, use an optimization that allows a fast call. - // CreateDelegate creates a delegate that is fast to invoke. - static let invoker = - if argTypes.Length = 1 then - (System.Delegate.CreateDelegate(typeof>, mi) :?> EventWrapper<'Delegate,'Args>) - else - null - - // For the multi-arg case, use a slower DynamicInvoke. - static let invokeInfo = - let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly - let mi = - typeof>.GetMethods(instanceBindingFlags) - |> Seq.filter(fun mi -> mi.Name = "Invoke" && mi.GetParameters().Length = argTypes.Length + 1) - |> Seq.exactlyOne - if mi.IsGenericMethodDefinition then - mi.MakeGenericMethod argTypes - else - mi - - member x.Trigger(sender:obj,args: 'Args) = - // Copy multicast value into local variable to avoid changing during member call. - let multicast = multicast - match box multicast with - | null -> () +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Control +open System.Reflection +open System.Diagnostics + +module private Atomic = + open System.Threading + + let inline setWith (thunk: 'a -> 'a) (value: byref<'a>) = + let mutable exchanged = false + let mutable oldValue = value + while not exchanged do + let comparand = oldValue + let newValue = thunk comparand + oldValue <- Interlocked.CompareExchange(&value, newValue, comparand) + if obj.ReferenceEquals(comparand, oldValue) then + exchanged <- true + +[] +type DelegateEvent<'Delegate when 'Delegate :> System.Delegate>() = + let mutable multicast : System.Delegate = null + member x.Trigger(args:obj[]) = + match multicast with + | null -> () + | d -> d.DynamicInvoke(args) |> ignore + member x.Publish = + { new IDelegateEvent<'Delegate> with + member x.AddHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Combine(value, d)) &multicast + member x.RemoveHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Remove(value, d)) &multicast } + +type EventDelegee<'Args>(observer: System.IObserver<'Args>) = + static let makeTuple = + if Microsoft.FSharp.Reflection.FSharpType.IsTuple(typeof<'Args>) then + Microsoft.FSharp.Reflection.FSharpValue.PreComputeTupleConstructor(typeof<'Args>) + else + fun _ -> assert false; null // should not be called, one-argument case don't use makeTuple function + + member x.Invoke(_sender:obj, args: 'Args) = + observer.OnNext args + member x.Invoke(_sender:obj, a, b) = + let args = makeTuple([|a; b|]) :?> 'Args + observer.OnNext args + member x.Invoke(_sender:obj, a, b, c) = + let args = makeTuple([|a; b; c|]) :?> 'Args + observer.OnNext args + member x.Invoke(_sender:obj, a, b, c, d) = + let args = makeTuple([|a; b; c; d|]) :?> 'Args + observer.OnNext args + member x.Invoke(_sender:obj, a, b, c, d, e) = + let args = makeTuple([|a; b; c; d; e|]) :?> 'Args + observer.OnNext args + member x.Invoke(_sender:obj, a, b, c, d, e, f) = + let args = makeTuple([|a; b; c; d; e; f|]) :?> 'Args + observer.OnNext args + + +type EventWrapper<'Delegate,'Args> = delegate of 'Delegate * obj * 'Args -> unit + +[] +type Event<'Delegate, 'Args when 'Delegate : delegate<'Args, unit> and 'Delegate :> System.Delegate and 'Delegate: not struct>() = + + let mutable multicast : 'Delegate = Unchecked.defaultof<_> + + static let mi, argTypes = + let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly + let mi = typeof<'Delegate>.GetMethod("Invoke",instanceBindingFlags) + let actualTypes = mi.GetParameters() |> Array.map (fun p -> p.ParameterType) + mi, actualTypes.[1..] + + // For the one-argument case, use an optimization that allows a fast call. + // CreateDelegate creates a delegate that is fast to invoke. + static let invoker = + if argTypes.Length = 1 then + (System.Delegate.CreateDelegate(typeof>, mi) :?> EventWrapper<'Delegate,'Args>) + else + null + + // For the multi-arg case, use a slower DynamicInvoke. + static let invokeInfo = + let instanceBindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly + let mi = + typeof>.GetMethods(instanceBindingFlags) + |> Seq.filter(fun mi -> mi.Name = "Invoke" && mi.GetParameters().Length = argTypes.Length + 1) + |> Seq.exactlyOne + if mi.IsGenericMethodDefinition then + mi.MakeGenericMethod argTypes + else + mi + + member x.Trigger(sender:obj,args: 'Args) = + // Copy multicast value into local variable to avoid changing during member call. + let multicast = multicast + match box multicast with + | null -> () + | _ -> + match invoker with + | null -> + let args = Array.append [| sender |] (Microsoft.FSharp.Reflection.FSharpValue.GetTupleFields(box args)) + multicast.DynamicInvoke(args) |> ignore | _ -> - match invoker with - | null -> - let args = Array.append [| sender |] (Microsoft.FSharp.Reflection.FSharpValue.GetTupleFields(box args)) - multicast.DynamicInvoke(args) |> ignore - | _ -> - // For the one-argument case, use an optimization that allows a fast call. - // CreateDelegate creates a delegate that is fast to invoke. - invoker.Invoke(multicast, sender, args) |> ignore - - member x.Publish = - { new obj() with - member x.ToString() = "" - interface IEvent<'Delegate,'Args> with - member e.AddHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> 'Delegate) &multicast - member e.RemoveHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> 'Delegate) &multicast - interface System.IObservable<'Args> with - member e.Subscribe(observer) = - let obj = new EventDelegee<'Args>(observer) - let h = System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeInfo) :?> 'Delegate - (e :?> IDelegateEvent<'Delegate>).AddHandler(h) - { new System.IDisposable with - member x.Dispose() = (e :?> IDelegateEvent<'Delegate>).RemoveHandler(h) } } - - - [] - type Event<'T> = - val mutable multicast : Handler<'T> - new() = { multicast = null } - - member x.Trigger(arg:'T) = - match x.multicast with - | null -> () - | d -> d.Invoke(null,arg) |> ignore - member x.Publish = - { new obj() with - member x.ToString() = "" - interface IEvent<'T> with - member e.AddHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> Handler<'T>) &x.multicast - member e.RemoveHandler(d) = - Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> Handler<'T>) &x.multicast - interface System.IObservable<'T> with - member e.Subscribe(observer) = - let h = new Handler<_>(fun sender args -> observer.OnNext(args)) - (e :?> IEvent<_,_>).AddHandler(h) - { new System.IDisposable with - member x.Dispose() = (e :?> IEvent<_,_>).RemoveHandler(h) } } + // For the one-argument case, use an optimization that allows a fast call. + // CreateDelegate creates a delegate that is fast to invoke. + invoker.Invoke(multicast, sender, args) |> ignore + + member x.Publish = + { new obj() with + member x.ToString() = "" + interface IEvent<'Delegate,'Args> with + member e.AddHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> 'Delegate) &multicast + member e.RemoveHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> 'Delegate) &multicast + interface System.IObservable<'Args> with + member e.Subscribe(observer) = + let obj = new EventDelegee<'Args>(observer) + let h = System.Delegate.CreateDelegate(typeof<'Delegate>, obj, invokeInfo) :?> 'Delegate + (e :?> IDelegateEvent<'Delegate>).AddHandler(h) + { new System.IDisposable with + member x.Dispose() = (e :?> IDelegateEvent<'Delegate>).RemoveHandler(h) } } + + +[] +type Event<'T> = + val mutable multicast : Handler<'T> + new() = { multicast = null } + + member x.Trigger(arg:'T) = + match x.multicast with + | null -> () + | d -> d.Invoke(null,arg) |> ignore + member x.Publish = + { new obj() with + member x.ToString() = "" + interface IEvent<'T> with + member e.AddHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Combine(value, d) :?> Handler<'T>) &x.multicast + member e.RemoveHandler(d) = + Atomic.setWith (fun value -> System.Delegate.Remove(value, d) :?> Handler<'T>) &x.multicast + interface System.IObservable<'T> with + member e.Subscribe(observer) = + let h = new Handler<_>(fun sender args -> observer.OnNext(args)) + (e :?> IEvent<_,_>).AddHandler(h) + { new System.IDisposable with + member x.Dispose() = (e :?> IEvent<_,_>).RemoveHandler(h) } } diff --git a/src/FSharp.Core/eventmodule.fs b/src/FSharp.Core/eventmodule.fs index fe907373f598700f5acba9e8f8061210bfc1001c..b9776a692d9ac5b5e8731b77308f7432e48d023b 100644 --- a/src/FSharp.Core/eventmodule.fs +++ b/src/FSharp.Core/eventmodule.fs @@ -2,80 +2,80 @@ namespace Microsoft.FSharp.Control - open Microsoft.FSharp.Core - open Microsoft.FSharp.Control +open Microsoft.FSharp.Core +open Microsoft.FSharp.Control - [] - [] - module Event = - [] - let create<'T>() = - let ev = new Event<'T>() - ev.Trigger, ev.Publish +[] +[] +module Event = + [] + let create<'T>() = + let ev = new Event<'T>() + ev.Trigger, ev.Publish - [] - let map mapping (sourceEvent: IEvent<'Delegate,'T>) = - let ev = new Event<_>() - sourceEvent.Add(fun x -> ev.Trigger(mapping x)) - ev.Publish + [] + let map mapping (sourceEvent: IEvent<'Delegate,'T>) = + let ev = new Event<_>() + sourceEvent.Add(fun x -> ev.Trigger(mapping x)) + ev.Publish - [] - let filter predicate (sourceEvent: IEvent<'Delegate,'T>) = - let ev = new Event<_>() - sourceEvent.Add(fun x -> if predicate x then ev.Trigger x) - ev.Publish + [] + let filter predicate (sourceEvent: IEvent<'Delegate,'T>) = + let ev = new Event<_>() + sourceEvent.Add(fun x -> if predicate x then ev.Trigger x) + ev.Publish - [] - let partition predicate (sourceEvent: IEvent<'Delegate,'T>) = - let ev1 = new Event<_>() - let ev2 = new Event<_>() - sourceEvent.Add(fun x -> if predicate x then ev1.Trigger x else ev2.Trigger x) - ev1.Publish,ev2.Publish + [] + let partition predicate (sourceEvent: IEvent<'Delegate,'T>) = + let ev1 = new Event<_>() + let ev2 = new Event<_>() + sourceEvent.Add(fun x -> if predicate x then ev1.Trigger x else ev2.Trigger x) + ev1.Publish,ev2.Publish - [] - let choose chooser (sourceEvent: IEvent<'Delegate,'T>) = - let ev = new Event<_>() - sourceEvent.Add(fun x -> match chooser x with None -> () | Some r -> ev.Trigger r) - ev.Publish + [] + let choose chooser (sourceEvent: IEvent<'Delegate,'T>) = + let ev = new Event<_>() + sourceEvent.Add(fun x -> match chooser x with None -> () | Some r -> ev.Trigger r) + ev.Publish - [] - let scan collector state (sourceEvent: IEvent<'Delegate,'T>) = - let mutable state = state - let ev = new Event<_>() - sourceEvent.Add(fun msg -> - let z = state - let z = collector z msg - state <- z; - ev.Trigger(z)) - ev.Publish + [] + let scan collector state (sourceEvent: IEvent<'Delegate,'T>) = + let mutable state = state + let ev = new Event<_>() + sourceEvent.Add(fun msg -> + let z = state + let z = collector z msg + state <- z; + ev.Trigger(z)) + ev.Publish - [] - let add callback (sourceEvent: IEvent<'Delegate,'T>) = sourceEvent.Add(callback) + [] + let add callback (sourceEvent: IEvent<'Delegate,'T>) = sourceEvent.Add(callback) - [] - let pairwise (sourceEvent : IEvent<'Delegate,'T>) : IEvent<'T * 'T> = - let ev = new Event<'T * 'T>() - let mutable lastArgs = None - sourceEvent.Add(fun args2 -> - (match lastArgs with - | None -> () - | Some args1 -> ev.Trigger(args1,args2)) - lastArgs <- Some args2) + [] + let pairwise (sourceEvent : IEvent<'Delegate,'T>) : IEvent<'T * 'T> = + let ev = new Event<'T * 'T>() + let mutable lastArgs = None + sourceEvent.Add(fun args2 -> + (match lastArgs with + | None -> () + | Some args1 -> ev.Trigger(args1,args2)) + lastArgs <- Some args2) - ev.Publish + ev.Publish - [] - let merge (event1: IEvent<'Del1,'T>) (event2: IEvent<'Del2,'T>) = - let ev = new Event<_>() - event1.Add(fun x -> ev.Trigger(x)) - event2.Add(fun x -> ev.Trigger(x)) - ev.Publish + [] + let merge (event1: IEvent<'Del1,'T>) (event2: IEvent<'Del2,'T>) = + let ev = new Event<_>() + event1.Add(fun x -> ev.Trigger(x)) + event2.Add(fun x -> ev.Trigger(x)) + ev.Publish - [] - let split (splitter : 'T -> Choice<'U1,'U2>) (sourceEvent: IEvent<'Delegate,'T>) = - let ev1 = new Event<_>() - let ev2 = new Event<_>() - sourceEvent.Add(fun x -> match splitter x with Choice1Of2 y -> ev1.Trigger(y) | Choice2Of2 z -> ev2.Trigger(z)) - ev1.Publish,ev2.Publish + [] + let split (splitter : 'T -> Choice<'U1,'U2>) (sourceEvent: IEvent<'Delegate,'T>) = + let ev1 = new Event<_>() + let ev2 = new Event<_>() + sourceEvent.Add(fun x -> match splitter x with Choice1Of2 y -> ev1.Trigger(y) | Choice2Of2 z -> ev2.Trigger(z)) + ev1.Publish,ev2.Publish diff --git a/src/FSharp.Core/fslib-extra-pervasives.fs b/src/FSharp.Core/fslib-extra-pervasives.fs index 789533419b0f8a28a84464b34c12157ee122c79e..2c0c462a9bc3c32c06ceb8221f14d331574b5bf3 100644 --- a/src/FSharp.Core/fslib-extra-pervasives.fs +++ b/src/FSharp.Core/fslib-extra-pervasives.fs @@ -8,11 +8,9 @@ module ExtraTopLevelOperators = open System.Collections.Generic open System.IO open System.Diagnostics - open System.Reflection open Microsoft.FSharp open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Text open Microsoft.FSharp.Collections open Microsoft.FSharp.Control open Microsoft.FSharp.Primitives.Basics @@ -46,70 +44,96 @@ module ExtraTopLevelOperators = #if NETSTANDARD static let emptyEnumerator = (Array.empty> :> seq<_>).GetEnumerator() #endif - member x.Count = t.Count + member _.Count = t.Count // Give a read-only view of the dictionary interface IDictionary<'Key, 'T> with - member s.Item + member _.Item with get x = dont_tail_call (fun () -> t.[makeSafeKey x]) and set _ _ = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Keys = + + member _.Keys = let keys = t.Keys { new ICollection<'Key> with - member s.Add(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Remove(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Contains(x) = t.ContainsKey (makeSafeKey x) - member s.CopyTo(arr,i) = + member _.Add(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.Remove(x) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.Contains(x) = t.ContainsKey (makeSafeKey x) + + member _.CopyTo(arr,i) = let mutable n = 0 for k in keys do arr.[i+n] <- getKey k n <- n + 1 - member s.IsReadOnly = true - member s.Count = keys.Count + + member _.IsReadOnly = true + + member _.Count = keys.Count + interface IEnumerable<'Key> with - member s.GetEnumerator() = (keys |> Seq.map getKey).GetEnumerator() + member _.GetEnumerator() = (keys |> Seq.map getKey).GetEnumerator() + interface System.Collections.IEnumerable with - member s.GetEnumerator() = ((keys |> Seq.map getKey) :> System.Collections.IEnumerable).GetEnumerator() } + member _.GetEnumerator() = ((keys |> Seq.map getKey) :> System.Collections.IEnumerable).GetEnumerator() } - member s.Values = upcast t.Values - member s.Add(_,_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.ContainsKey(k) = dont_tail_call (fun () -> t.ContainsKey(makeSafeKey k)) - member s.TryGetValue(k,r) = + member _.Values = upcast t.Values + + member _.Add(_,_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.ContainsKey(k) = dont_tail_call (fun () -> t.ContainsKey(makeSafeKey k)) + + member _.TryGetValue(k,r) = let safeKey = makeSafeKey k if t.ContainsKey(safeKey) then (r <- t.[safeKey]; true) else false - member s.Remove(_ : 'Key) = (raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) : bool) + + member _.Remove(_ : 'Key) = (raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) : bool) interface IReadOnlyDictionary<'Key, 'T> with + member _.Item with get key = t.[makeSafeKey key] + member _.Keys = t.Keys |> Seq.map getKey + member _.TryGetValue(key, r) = match t.TryGetValue (makeSafeKey key) with | false, _ -> false | true, value -> r <- value true + member _.Values = (t :> IReadOnlyDictionary<_,_>).Values + member _.ContainsKey k = t.ContainsKey (makeSafeKey k) interface ICollection> with - member s.Add(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Remove(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) - member s.Contains(KeyValue(k,v)) = ICollection_Contains t (KeyValuePair<_,_>(makeSafeKey k,v)) - member s.CopyTo(arr,i) = + + member _.Add(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.Clear() = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.Remove(_) = raise (NotSupportedException(SR.GetString(SR.thisValueCannotBeMutated))) + + member _.Contains(KeyValue(k,v)) = ICollection_Contains t (KeyValuePair<_,_>(makeSafeKey k,v)) + + member _.CopyTo(arr,i) = let mutable n = 0 for (KeyValue(k,v)) in t do arr.[i+n] <- KeyValuePair<_,_>(getKey k,v) n <- n + 1 - member s.IsReadOnly = true - member s.Count = t.Count + + member _.IsReadOnly = true + + member _.Count = t.Count interface IReadOnlyCollection> with member _.Count = t.Count interface IEnumerable> with - member s.GetEnumerator() = + + member _.GetEnumerator() = // We use an array comprehension here instead of seq {} as otherwise we get incorrect // IEnumerator.Reset() and IEnumerator.Current semantics. // Coreclr has a bug with SZGenericEnumerators --- implement a correct enumerator. On desktop use the desktop implementation because it's ngened. @@ -129,20 +153,24 @@ module ExtraTopLevelOperators = {new IEnumerator<_> with member _.Current = current () + interface System.Collections.IEnumerator with member _.Current = box(current()) + member _.MoveNext() = if index < endIndex then index <- index + 1 index < endIndex else false + member _.Reset() = index <- -1 + interface System.IDisposable with - member self.Dispose() = () } + member _.Dispose() = () } #endif interface System.Collections.IEnumerable with - member s.GetEnumerator() = + member _.GetEnumerator() = // We use an array comprehension here instead of seq {} as otherwise we get incorrect // IEnumerator.Reset() and IEnumerator.Current semantics. let kvps = [| for (KeyValue (k,v)) in t -> KeyValuePair (getKey k, v) |] :> System.Collections.IEnumerable @@ -150,7 +178,7 @@ module ExtraTopLevelOperators = and DictDebugView<'SafeKey,'Key,'T>(d:DictImpl<'SafeKey,'Key,'T>) = [] - member x.Items = Array.ofSeq d + member _.Items = Array.ofSeq d let inline dictImpl (comparer:IEqualityComparer<'SafeKey>) (makeSafeKey : 'Key->'SafeKey) (getKey : 'SafeKey->'Key) (l:seq<'Key*'T>) = let t = Dictionary comparer @@ -159,22 +187,26 @@ module ExtraTopLevelOperators = DictImpl(t, makeSafeKey, getKey) // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let dictValueType (l:seq<'Key*'T>) = dictImpl HashIdentity.Structural<'Key> id id l + let dictValueType (l:seq<'Key*'T>) = + dictImpl HashIdentity.Structural<'Key> id id l // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let dictRefType (l:seq<'Key*'T>) = dictImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun k -> RuntimeHelpers.StructBox k) (fun sb -> sb.Value) l + let dictRefType (l:seq<'Key*'T>) = + dictImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun k -> RuntimeHelpers.StructBox k) (fun sb -> sb.Value) l [] let dict (keyValuePairs:seq<'Key*'T>) : IDictionary<'Key,'T> = - if typeof<'Key>.IsValueType - then dictValueType keyValuePairs :> _ - else dictRefType keyValuePairs :> _ + if typeof<'Key>.IsValueType then + dictValueType keyValuePairs + else + dictRefType keyValuePairs [] let readOnlyDict (keyValuePairs:seq<'Key*'T>) : IReadOnlyDictionary<'Key,'T> = - if typeof<'Key>.IsValueType - then dictValueType keyValuePairs :> _ - else dictRefType keyValuePairs :> _ + if typeof<'Key>.IsValueType then + dictValueType keyValuePairs + else + dictRefType keyValuePairs let getArray (vals : seq<'T>) = match vals with @@ -203,36 +235,41 @@ module ExtraTopLevelOperators = res.[i,j] <- rowiArr.[j] res - // -------------------------------------------------------------------- - // Printf - // -------------------------------------------------------------------- - [] - let sprintf format = Printf.sprintf format + let sprintf format = + Printf.sprintf format [] - let failwithf format = Printf.failwithf format + let failwithf format = + Printf.failwithf format [] - let fprintf (textWriter:TextWriter) format = Printf.fprintf textWriter format + let fprintf (textWriter:TextWriter) format = + Printf.fprintf textWriter format [] - let fprintfn (textWriter:TextWriter) format = Printf.fprintfn textWriter format + let fprintfn (textWriter:TextWriter) format = + Printf.fprintfn textWriter format [] - let printf format = Printf.printf format + let printf format = + Printf.printf format [] - let eprintf format = Printf.eprintf format + let eprintf format = + Printf.eprintf format [] - let printfn format = Printf.printfn format + let printfn format = + Printf.printfn format [] - let eprintfn format = Printf.eprintfn format + let eprintfn format = + Printf.eprintfn format [] - let failwith s = raise (Failure s) + let failwith s = + raise (Failure s) [] let async = AsyncBuilder() @@ -282,7 +319,8 @@ module ExtraTopLevelOperators = do() [] - let (|Lazy|) (input:Lazy<_>) = input.Force() + let (|Lazy|) (input:Lazy<_>) = + input.Force() let query = Microsoft.FSharp.Linq.QueryBuilder() @@ -291,9 +329,9 @@ namespace Microsoft.FSharp.Core.CompilerServices open System open System.Reflection - open System.Linq.Expressions - open System.Collections.Generic open Microsoft.FSharp.Core + open Microsoft.FSharp.Control + open Microsoft.FSharp.Quotations /// Represents the product of two measure expressions when returned as a generic argument of a provided type. [] @@ -315,11 +353,13 @@ namespace Microsoft.FSharp.Core.CompilerServices type TypeProviderAssemblyAttribute(assemblyName : string) = inherit System.Attribute() new () = TypeProviderAssemblyAttribute(null) + member _.AssemblyName = assemblyName [] type TypeProviderXmlDocAttribute(commentText: string) = inherit System.Attribute() + member _.CommentText = commentText [] @@ -328,8 +368,11 @@ namespace Microsoft.FSharp.Core.CompilerServices let mutable filePath : string = null let mutable line : int = 0 let mutable column : int = 0 + member _.FilePath with get() = filePath and set v = filePath <- v + member _.Line with get() = line and set v = line <- v + member _.Column with get() = column and set v = column <- v [] @@ -342,41 +385,57 @@ namespace Microsoft.FSharp.Core.CompilerServices | IsErased = 0x40000000 type TypeProviderConfig( systemRuntimeContainsType : string -> bool ) = - let mutable resolutionFolder : string = null - let mutable runtimeAssembly : string = null - let mutable referencedAssemblies : string[] = null - let mutable temporaryFolder : string = null - let mutable isInvalidationSupported : bool = false - let mutable useResolutionFolderAtRuntime : bool = false - let mutable systemRuntimeAssemblyVersion : System.Version = null - member _.ResolutionFolder with get() = resolutionFolder and set v = resolutionFolder <- v - member _.RuntimeAssembly with get() = runtimeAssembly and set v = runtimeAssembly <- v - member _.ReferencedAssemblies with get() = referencedAssemblies and set v = referencedAssemblies <- v - member _.TemporaryFolder with get() = temporaryFolder and set v = temporaryFolder <- v - member _.IsInvalidationSupported with get() = isInvalidationSupported and set v = isInvalidationSupported <- v + let mutable resolutionFolder: string = null + let mutable runtimeAssembly: string = null + let mutable referencedAssemblies: string[] = null + let mutable temporaryFolder: string = null + let mutable isInvalidationSupported: bool = false + let mutable useResolutionFolderAtRuntime: bool = false + let mutable systemRuntimeAssemblyVersion: System.Version = null + + member _.ResolutionFolder with get() = resolutionFolder and set v = resolutionFolder <- v + + member _.RuntimeAssembly with get() = runtimeAssembly and set v = runtimeAssembly <- v + + member _.ReferencedAssemblies with get() = referencedAssemblies and set v = referencedAssemblies <- v + + member _.TemporaryFolder with get() = temporaryFolder and set v = temporaryFolder <- v + + member _.IsInvalidationSupported with get() = isInvalidationSupported and set v = isInvalidationSupported <- v + member _.IsHostedExecution with get() = useResolutionFolderAtRuntime and set v = useResolutionFolderAtRuntime <- v - member _.SystemRuntimeAssemblyVersion with get() = systemRuntimeAssemblyVersion and set v = systemRuntimeAssemblyVersion <- v - member _.SystemRuntimeContainsType (typeName : string) = systemRuntimeContainsType typeName + + member _.SystemRuntimeAssemblyVersion with get() = systemRuntimeAssemblyVersion and set v = systemRuntimeAssemblyVersion <- v + + member _.SystemRuntimeContainsType (typeName: string) = systemRuntimeContainsType typeName type IProvidedNamespace = - abstract NamespaceName : string - abstract GetNestedNamespaces : unit -> IProvidedNamespace[] - abstract GetTypes : unit -> Type[] - abstract ResolveTypeName : typeName: string -> Type + abstract NamespaceName: string + + abstract GetNestedNamespaces: unit -> IProvidedNamespace[] + + abstract GetTypes: unit -> Type[] + + abstract ResolveTypeName: typeName: string -> Type type ITypeProvider = inherit System.IDisposable - abstract GetNamespaces : unit -> IProvidedNamespace[] - abstract GetStaticParameters : typeWithoutArguments:Type -> ParameterInfo[] - abstract ApplyStaticArguments : typeWithoutArguments:Type * typePathWithArguments:string[] * staticArguments:obj[] -> Type - abstract GetInvokerExpression : syntheticMethodBase:MethodBase * parameters:Microsoft.FSharp.Quotations.Expr[] -> Microsoft.FSharp.Quotations.Expr + + abstract GetNamespaces: unit -> IProvidedNamespace[] + + abstract GetStaticParameters: typeWithoutArguments: Type -> ParameterInfo[] + + abstract ApplyStaticArguments: typeWithoutArguments: Type * typePathWithArguments: string[] * staticArguments:obj[] -> Type + + abstract GetInvokerExpression: syntheticMethodBase:MethodBase * parameters:Expr[] -> Expr [] - abstract Invalidate : Microsoft.FSharp.Control.IEvent - abstract GetGeneratedAssemblyContents : assembly:System.Reflection.Assembly -> byte[] + abstract Invalidate : IEvent + abstract GetGeneratedAssemblyContents: assembly:System.Reflection.Assembly -> byte[] type ITypeProvider2 = - abstract GetStaticParametersForMethod : methodWithoutArguments:MethodBase -> ParameterInfo[] - abstract ApplyStaticArgumentsForMethod : methodWithoutArguments:MethodBase * methodNameWithArguments:string * staticArguments:obj[] -> MethodBase + abstract GetStaticParametersForMethod: methodWithoutArguments:MethodBase -> ParameterInfo[] + + abstract ApplyStaticArgumentsForMethod: methodWithoutArguments:MethodBase * methodNameWithArguments:string * staticArguments:obj[] -> MethodBase diff --git a/src/FSharp.Core/list.fs b/src/FSharp.Core/list.fs index d0eeda4e85432fa163b9f5694602bb406b9d5f6c..cd8b7ae3ad13b2475e5e4118859e1576f788120c 100644 --- a/src/FSharp.Core/list.fs +++ b/src/FSharp.Core/list.fs @@ -2,785 +2,784 @@ namespace Microsoft.FSharp.Collections - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.LanguagePrimitives - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Collections - open Microsoft.FSharp.Core.CompilerServices - open System.Collections.Generic - - - [] - [] - module List = - - let inline checkNonNull argName arg = - if isNull arg then - nullArg argName - - let inline indexNotFound() = raise (KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) - - [] - let length (list: 'T list) = list.Length - - [] - let last (list: 'T list) = - match Microsoft.FSharp.Primitives.Basics.List.tryLastV list with - | ValueSome x -> x - | ValueNone -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) - - [] - let rec tryLast (list: 'T list) = - match Microsoft.FSharp.Primitives.Basics.List.tryLastV list with - | ValueSome x -> Some x - | ValueNone -> None - - [] - let rev list = Microsoft.FSharp.Primitives.Basics.List.rev list - - [] - let concat lists = Microsoft.FSharp.Primitives.Basics.List.concat lists - - let inline countByImpl (comparer:IEqualityComparer<'SafeKey>) ([] projection: 'T->'SafeKey) ([] getKey:'SafeKey->'Key) (list: 'T list) = - let dict = Dictionary comparer - let rec loop srcList = - match srcList with - | [] -> () - | h :: t -> - let safeKey = projection h - let mutable prev = 0 - if dict.TryGetValue(safeKey, &prev) then dict.[safeKey] <- prev + 1 else dict.[safeKey] <- 1 - loop t - loop list - Microsoft.FSharp.Primitives.Basics.List.countBy dict getKey - - // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let countByValueType (projection: 'T->'Key) (list: 'T list) = countByImpl HashIdentity.Structural<'Key> projection id list - - // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let countByRefType (projection: 'T->'Key) (list: 'T list) = countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (projection t)) (fun sb -> sb.Value) list - - [] - let countBy (projection: 'T->'Key) (list: 'T list) = - match list with - | [] -> [] - | _ -> - if typeof<'Key>.IsValueType - then countByValueType projection list - else countByRefType projection list - - [] - let map mapping list = Microsoft.FSharp.Primitives.Basics.List.map mapping list - - [] - let mapi mapping list = Microsoft.FSharp.Primitives.Basics.List.mapi mapping list - - [] - let indexed list = Microsoft.FSharp.Primitives.Basics.List.indexed list - - [] - let mapFold<'T, 'State, 'Result> (mapping:'State -> 'T -> 'Result * 'State) state list = - Microsoft.FSharp.Primitives.Basics.List.mapFold mapping state list - - [] - let mapFoldBack<'T, 'State, 'Result> (mapping: 'T -> 'State -> 'Result * 'State) list state = - match list with - | [] -> [], state - | [h] -> let h', s' = mapping h state in [h'], s' - | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) - let rec loop res list = - match list, res with - | [], _ -> res - | h :: t, (list', acc') -> - let h', s' = f.Invoke(h, acc') - loop (h' :: list', s') t - loop ([], state) (rev list) - - [] - let inline iter ([] action) (list: 'T list) = for x in list do action x - - [] - let distinct (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctWithComparer HashIdentity.Structural<'T> list - - [] - let distinctBy projection (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctByWithComparer HashIdentity.Structural<_> projection list - - [] - let ofArray (array: 'T array) = Microsoft.FSharp.Primitives.Basics.List.ofArray array - - [] - let toArray (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.toArray list - - [] - let empty<'T> = ([ ] : 'T list) - - [] - let head list = match list with x :: _ -> x | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) - - [] - let tryHead list = match list with x :: _ -> Some x | [] -> None - - [] - let tail list = match list with _ :: t -> t | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) - - [] - let isEmpty list = match list with [] -> true | _ -> false - - [] - let append list1 list2 = list1 @ list2 - - [] - let rec item index list = - match list with - | h :: t when index >= 0 -> - if index = 0 then h else item (index - 1) t - | _ -> - invalidArg "index" (SR.GetString(SR.indexOutOfBounds)) - - [] - let rec tryItem index list = - match list with - | h :: t when index >= 0 -> - if index = 0 then Some h else tryItem (index - 1) t - | _ -> - None - - [] - let nth list index = item index list - - [] - let choose chooser list = Microsoft.FSharp.Primitives.Basics.List.choose chooser list - - [] - let splitAt index (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.splitAt index list - - [] - let take count (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.take count list - - [] - let takeWhile predicate (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.takeWhile predicate list - - [] - let inline iteri ([] action) (list: 'T list) = - let mutable n = 0 - for x in list do action n x; n <- n + 1 - - [] - let init length initializer = Microsoft.FSharp.Primitives.Basics.List.init length initializer - - [] - let replicate count initial = - if count < 0 then invalidArg "count" (SR.GetString(SR.inputMustBeNonNegative)) - let mutable result = [] - for i in 0..count-1 do - result <- initial :: result - result - - [] - let iter2 action list1 list2 = - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) - let rec loop list1 list2 = - match list1, list2 with - | [], [] -> () - | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2); loop t1 t2 - | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - loop list1 list2 - - [] - let iteri2 action list1 list2 = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(action) - let rec loop n list1 list2 = - match list1, list2 with - | [], [] -> () - | h1 :: t1, h2 :: t2 -> f.Invoke(n, h1, h2); loop (n+1) t1 t2 - | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - loop 0 list1 list2 - - [] - let map3 mapping list1 list2 list3 = - Microsoft.FSharp.Primitives.Basics.List.map3 mapping list1 list2 list3 - - [] - let mapi2 mapping list1 list2 = - Microsoft.FSharp.Primitives.Basics.List.mapi2 mapping list1 list2 - - [] - let map2 mapping list1 list2 = Microsoft.FSharp.Primitives.Basics.List.map2 mapping list1 list2 - - [] - let fold<'T, 'State> folder (state:'State) (list: 'T list) = - match list with - | [] -> state - | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) - let mutable acc = state - for x in list do - acc <- f.Invoke(acc, x) - acc - - [] - let pairwise (list: 'T list) = - Microsoft.FSharp.Primitives.Basics.List.pairwise list - - [] - let reduce reduction list = - match list with - | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) - | h :: t -> fold reduction h t - - [] - let scan<'T, 'State> folder (state:'State) (list: 'T list) = - Microsoft.FSharp.Primitives.Basics.List.scan folder state list - - [] - let inline singleton value = [value] - - [] - let fold2<'T1, 'T2, 'State> folder (state:'State) (list1:'T1 list) (list2:'T2 list) = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) - let rec loop acc list1 list2 = - match list1, list2 with - | [], [] -> acc - | h1 :: t1, h2 :: t2 -> loop (f.Invoke(acc, h1, h2)) t1 t2 - | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length - | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length - loop state list1 list2 - - let foldArraySubRight (f:OptimizedClosures.FSharpFunc<'T, _, _>) (arr: 'T[]) start fin acc = - let mutable state = acc - for i = fin downto start do - state <- f.Invoke(arr.[i], state) - state - - // this version doesn't causes stack overflow - it uses a private stack - [] - let foldBack<'T, 'State> folder (list: 'T list) (state:'State) = - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) - match list with - | [] -> state - | [h] -> f.Invoke(h, state) - | [h1; h2] -> f.Invoke(h1, f.Invoke(h2, state)) - | [h1; h2; h3] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, state))) - | [h1; h2; h3; h4] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, f.Invoke(h4, state)))) - | _ -> - // It is faster to allocate and iterate an array than to create all those - // highly nested stacks. It also means we won't get stack overflows here. - let arr = toArray list - let arrn = arr.Length - foldArraySubRight f arr 0 (arrn - 1) state - - [] - let reduceBack reduction list = - match list with - | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) - | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(reduction) - let arr = toArray list - let arrn = arr.Length - foldArraySubRight f arr 0 (arrn - 2) arr.[arrn - 1] - - let scanArraySubRight<'T, 'State> (f:OptimizedClosures.FSharpFunc<'T, 'State, 'State>) (arr: _[]) start fin initState = - let mutable state = initState - let mutable res = [state] - for i = fin downto start do - state <- f.Invoke(arr.[i], state) - res <- state :: res - res - - [] - let scanBack<'T, 'State> folder (list: 'T list) (state:'State) = - match list with - | [] -> [state] - | [h] -> - [folder h state; state] - | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) - // It is faster to allocate and iterate an array than to create all those - // highly nested stacks. It also means we won't get stack overflows here. - let arr = toArray list - let arrn = arr.Length - scanArraySubRight f arr 0 (arrn - 1) state - - let foldBack2UsingArrays (f:OptimizedClosures.FSharpFunc<_, _, _, _>) list1 list2 acc = - let arr1 = toArray list1 - let arr2 = toArray list2 - let n1 = arr1.Length - let n2 = arr2.Length - if n1 <> n2 then - invalidArgFmt "list1, list2" - "{0}\nlist1.Length = {1}, list2.Length = {2}" - [|SR.GetString SR.listsHadDifferentLengths; arr1.Length; arr2.Length|] - let mutable res = acc - for i = n1 - 1 downto 0 do - res <- f.Invoke(arr1.[i], arr2.[i], res) - res - - [] - let rec foldBack2<'T1, 'T2, 'State> folder (list1:'T1 list) (list2:'T2 list) (state:'State) = +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Core.LanguagePrimitives +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core.CompilerServices +open System.Collections.Generic + +[] +[] +module List = + + let inline checkNonNull argName arg = + if isNull arg then + nullArg argName + + let inline indexNotFound() = raise (KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) + + [] + let length (list: 'T list) = list.Length + + [] + let last (list: 'T list) = + match Microsoft.FSharp.Primitives.Basics.List.tryLastV list with + | ValueSome x -> x + | ValueNone -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + + [] + let rec tryLast (list: 'T list) = + match Microsoft.FSharp.Primitives.Basics.List.tryLastV list with + | ValueSome x -> Some x + | ValueNone -> None + + [] + let rev list = Microsoft.FSharp.Primitives.Basics.List.rev list + + [] + let concat lists = Microsoft.FSharp.Primitives.Basics.List.concat lists + + let inline countByImpl (comparer:IEqualityComparer<'SafeKey>) ([] projection: 'T->'SafeKey) ([] getKey:'SafeKey->'Key) (list: 'T list) = + let dict = Dictionary comparer + let rec loop srcList = + match srcList with + | [] -> () + | h :: t -> + let safeKey = projection h + let mutable prev = 0 + if dict.TryGetValue(safeKey, &prev) then dict.[safeKey] <- prev + 1 else dict.[safeKey] <- 1 + loop t + loop list + Microsoft.FSharp.Primitives.Basics.List.countBy dict getKey + + // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance + let countByValueType (projection: 'T->'Key) (list: 'T list) = countByImpl HashIdentity.Structural<'Key> projection id list + + // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation + let countByRefType (projection: 'T->'Key) (list: 'T list) = countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (projection t)) (fun sb -> sb.Value) list + + [] + let countBy (projection: 'T->'Key) (list: 'T list) = + match list with + | [] -> [] + | _ -> + if typeof<'Key>.IsValueType + then countByValueType projection list + else countByRefType projection list + + [] + let map mapping list = Microsoft.FSharp.Primitives.Basics.List.map mapping list + + [] + let mapi mapping list = Microsoft.FSharp.Primitives.Basics.List.mapi mapping list + + [] + let indexed list = Microsoft.FSharp.Primitives.Basics.List.indexed list + + [] + let mapFold<'T, 'State, 'Result> (mapping:'State -> 'T -> 'Result * 'State) state list = + Microsoft.FSharp.Primitives.Basics.List.mapFold mapping state list + + [] + let mapFoldBack<'T, 'State, 'Result> (mapping: 'T -> 'State -> 'Result * 'State) list state = + match list with + | [] -> [], state + | [h] -> let h', s' = mapping h state in [h'], s' + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(mapping) + let rec loop res list = + match list, res with + | [], _ -> res + | h :: t, (list', acc') -> + let h', s' = f.Invoke(h, acc') + loop (h' :: list', s') t + loop ([], state) (rev list) + + [] + let inline iter ([] action) (list: 'T list) = for x in list do action x + + [] + let distinct (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctWithComparer HashIdentity.Structural<'T> list + + [] + let distinctBy projection (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.distinctByWithComparer HashIdentity.Structural<_> projection list + + [] + let ofArray (array: 'T array) = Microsoft.FSharp.Primitives.Basics.List.ofArray array + + [] + let toArray (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.toArray list + + [] + let empty<'T> = ([ ] : 'T list) + + [] + let head list = match list with x :: _ -> x | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + + [] + let tryHead list = match list with x :: _ -> Some x | [] -> None + + [] + let tail list = match list with _ :: t -> t | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + + [] + let isEmpty list = match list with [] -> true | _ -> false + + [] + let append list1 list2 = list1 @ list2 + + [] + let rec item index list = + match list with + | h :: t when index >= 0 -> + if index = 0 then h else item (index - 1) t + | _ -> + invalidArg "index" (SR.GetString(SR.indexOutOfBounds)) + + [] + let rec tryItem index list = + match list with + | h :: t when index >= 0 -> + if index = 0 then Some h else tryItem (index - 1) t + | _ -> + None + + [] + let nth list index = item index list + + [] + let choose chooser list = Microsoft.FSharp.Primitives.Basics.List.choose chooser list + + [] + let splitAt index (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.splitAt index list + + [] + let take count (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.take count list + + [] + let takeWhile predicate (list: 'T list) = Microsoft.FSharp.Primitives.Basics.List.takeWhile predicate list + + [] + let inline iteri ([] action) (list: 'T list) = + let mutable n = 0 + for x in list do action n x; n <- n + 1 + + [] + let init length initializer = Microsoft.FSharp.Primitives.Basics.List.init length initializer + + [] + let replicate count initial = + if count < 0 then invalidArg "count" (SR.GetString(SR.inputMustBeNonNegative)) + let mutable result = [] + for i in 0..count-1 do + result <- initial :: result + result + + [] + let iter2 action list1 list2 = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) + let rec loop list1 list2 = match list1, list2 with - | [], [] -> state - | h1 :: rest1, k1 :: rest2 -> - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) - match rest1, rest2 with - | [], [] -> f.Invoke(h1, k1, state) - | [h2], [k2] -> f.Invoke(h1, k1, f.Invoke(h2, k2, state)) - | [h2; h3], [k2; k3] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, state))) - | [h2; h3; h4], [k2; k3; k4] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, f.Invoke(h4, k4, state)))) - | _ -> foldBack2UsingArrays f list1 list2 state + | [], [] -> () + | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2); loop t1 t2 | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + loop list1 list2 - let rec forall2aux (f:OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = + [] + let iteri2 action list1 list2 = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(action) + let rec loop n list1 list2 = match list1, list2 with - | [], [] -> true - | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2) && forall2aux f t1 t2 + | [], [] -> () + | h1 :: t1, h2 :: t2 -> f.Invoke(n, h1, h2); loop (n+1) t1 t2 | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + loop 0 list1 list2 - [] - let forall2 predicate list1 list2 = - match list1, list2 with - | [], [] -> true - | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) - forall2aux f list1 list2 - - [] - let forall predicate list = Microsoft.FSharp.Primitives.Basics.List.forall predicate list - - [] - let exists predicate list = Microsoft.FSharp.Primitives.Basics.List.exists predicate list - - [] - let inline contains value source = - let rec contains e xs1 = - match xs1 with - | [] -> false - | h1 :: t1 -> e = h1 || contains e t1 - contains value source - - let rec exists2aux (f:OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = - match list1, list2 with - | [], [] -> false - | h1 :: t1, h2 :: t2 ->f.Invoke(h1, h2) || exists2aux f t1 t2 - | _ -> invalidArg "list2" (SR.GetString(SR.listsHadDifferentLengths)) + [] + let map3 mapping list1 list2 list3 = + Microsoft.FSharp.Primitives.Basics.List.map3 mapping list1 list2 list3 - [] - let rec exists2 predicate list1 list2 = - match list1, list2 with - | [], [] -> false - | _ -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) - exists2aux f list1 list2 - - [] - let rec find predicate list = - match list with - | [] -> indexNotFound() - | h :: t -> if predicate h then h else find predicate t - - [] - let rec tryFind predicate list = - match list with - | [] -> None - | h :: t -> if predicate h then Some h else tryFind predicate t + [] + let mapi2 mapping list1 list2 = + Microsoft.FSharp.Primitives.Basics.List.mapi2 mapping list1 list2 - [] - let findBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.findBack predicate - - [] - let tryFindBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.tryFindBack predicate - - [] - let rec tryPick chooser list = - match list with - | [] -> None - | h :: t -> - match chooser h with - | None -> tryPick chooser t - | r -> r + [] + let map2 mapping list1 list2 = Microsoft.FSharp.Primitives.Basics.List.map2 mapping list1 list2 - [] - let rec pick chooser list = - match list with + [] + let fold<'T, 'State> folder (state:'State) (list: 'T list) = + match list with + | [] -> state + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + let mutable acc = state + for x in list do + acc <- f.Invoke(acc, x) + acc + + [] + let pairwise (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.pairwise list + + [] + let reduce reduction list = + match list with + | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + | h :: t -> fold reduction h t + + [] + let scan<'T, 'State> folder (state:'State) (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.scan folder state list + + [] + let inline singleton value = [value] + + [] + let fold2<'T1, 'T2, 'State> folder (state:'State) (list1:'T1 list) (list2:'T2 list) = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) + let rec loop acc list1 list2 = + match list1, list2 with + | [], [] -> acc + | h1 :: t1, h2 :: t2 -> loop (f.Invoke(acc, h1, h2)) t1 t2 + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + loop state list1 list2 + + let foldArraySubRight (f:OptimizedClosures.FSharpFunc<'T, _, _>) (arr: 'T[]) start fin acc = + let mutable state = acc + for i = fin downto start do + state <- f.Invoke(arr.[i], state) + state + + // this version doesn't causes stack overflow - it uses a private stack + [] + let foldBack<'T, 'State> folder (list: 'T list) (state:'State) = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + match list with + | [] -> state + | [h] -> f.Invoke(h, state) + | [h1; h2] -> f.Invoke(h1, f.Invoke(h2, state)) + | [h1; h2; h3] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, state))) + | [h1; h2; h3; h4] -> f.Invoke(h1, f.Invoke(h2, f.Invoke(h3, f.Invoke(h4, state)))) + | _ -> + // It is faster to allocate and iterate an array than to create all those + // highly nested stacks. It also means we won't get stack overflows here. + let arr = toArray list + let arrn = arr.Length + foldArraySubRight f arr 0 (arrn - 1) state + + [] + let reduceBack reduction list = + match list with + | [] -> invalidArg "list" (SR.GetString(SR.inputListWasEmpty)) + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(reduction) + let arr = toArray list + let arrn = arr.Length + foldArraySubRight f arr 0 (arrn - 2) arr.[arrn - 1] + + let scanArraySubRight<'T, 'State> (f:OptimizedClosures.FSharpFunc<'T, 'State, 'State>) (arr: _[]) start fin initState = + let mutable state = initState + let mutable res = [state] + for i = fin downto start do + state <- f.Invoke(arr.[i], state) + res <- state :: res + res + + [] + let scanBack<'T, 'State> folder (list: 'T list) (state:'State) = + match list with + | [] -> [state] + | [h] -> + [folder h state; state] + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(folder) + // It is faster to allocate and iterate an array than to create all those + // highly nested stacks. It also means we won't get stack overflows here. + let arr = toArray list + let arrn = arr.Length + scanArraySubRight f arr 0 (arrn - 1) state + + let foldBack2UsingArrays (f:OptimizedClosures.FSharpFunc<_, _, _, _>) list1 list2 acc = + let arr1 = toArray list1 + let arr2 = toArray list2 + let n1 = arr1.Length + let n2 = arr2.Length + if n1 <> n2 then + invalidArgFmt "list1, list2" + "{0}\nlist1.Length = {1}, list2.Length = {2}" + [|SR.GetString SR.listsHadDifferentLengths; arr1.Length; arr2.Length|] + let mutable res = acc + for i = n1 - 1 downto 0 do + res <- f.Invoke(arr1.[i], arr2.[i], res) + res + + [] + let rec foldBack2<'T1, 'T2, 'State> folder (list1:'T1 list) (list2:'T2 list) (state:'State) = + match list1, list2 with + | [], [] -> state + | h1 :: rest1, k1 :: rest2 -> + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(folder) + match rest1, rest2 with + | [], [] -> f.Invoke(h1, k1, state) + | [h2], [k2] -> f.Invoke(h1, k1, f.Invoke(h2, k2, state)) + | [h2; h3], [k2; k3] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, state))) + | [h2; h3; h4], [k2; k3; k4] -> f.Invoke(h1, k1, f.Invoke(h2, k2, f.Invoke(h3, k3, f.Invoke(h4, k4, state)))) + | _ -> foldBack2UsingArrays f list1 list2 state + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + + let rec forall2aux (f:OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = + match list1, list2 with + | [], [] -> true + | h1 :: t1, h2 :: t2 -> f.Invoke(h1, h2) && forall2aux f t1 t2 + | [], xs2 -> invalidArgDifferentListLength "list1" "list2" xs2.Length + | xs1, [] -> invalidArgDifferentListLength "list2" "list1" xs1.Length + + [] + let forall2 predicate list1 list2 = + match list1, list2 with + | [], [] -> true + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) + forall2aux f list1 list2 + + [] + let forall predicate list = Microsoft.FSharp.Primitives.Basics.List.forall predicate list + + [] + let exists predicate list = Microsoft.FSharp.Primitives.Basics.List.exists predicate list + + [] + let inline contains value source = + let rec contains e xs1 = + match xs1 with + | [] -> false + | h1 :: t1 -> e = h1 || contains e t1 + contains value source + + let rec exists2aux (f:OptimizedClosures.FSharpFunc<_, _, _>) list1 list2 = + match list1, list2 with + | [], [] -> false + | h1 :: t1, h2 :: t2 ->f.Invoke(h1, h2) || exists2aux f t1 t2 + | _ -> invalidArg "list2" (SR.GetString(SR.listsHadDifferentLengths)) + + [] + let rec exists2 predicate list1 list2 = + match list1, list2 with + | [], [] -> false + | _ -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(predicate) + exists2aux f list1 list2 + + [] + let rec find predicate list = + match list with + | [] -> indexNotFound() + | h :: t -> if predicate h then h else find predicate t + + [] + let rec tryFind predicate list = + match list with + | [] -> None + | h :: t -> if predicate h then Some h else tryFind predicate t + + [] + let findBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.findBack predicate + + [] + let tryFindBack predicate list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.tryFindBack predicate + + [] + let rec tryPick chooser list = + match list with + | [] -> None + | h :: t -> + match chooser h with + | None -> tryPick chooser t + | r -> r + + [] + let rec pick chooser list = + match list with + | [] -> indexNotFound() + | h :: t -> + match chooser h with + | None -> pick chooser t + | Some r -> r + + [] + let filter predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate list + + [] + let except (itemsToExclude: seq<'T>) list = + checkNonNull "itemsToExclude" itemsToExclude + match list with + | [] -> list + | _ -> + let cached = HashSet(itemsToExclude, HashIdentity.Structural) + list |> filter cached.Add + + [] + let where predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate list + + let inline groupByImpl (comparer:IEqualityComparer<'SafeKey>) (keyf: 'T->'SafeKey) (getKey:'SafeKey->'Key) (list: 'T list) = + Microsoft.FSharp.Primitives.Basics.List.groupBy comparer keyf getKey list + + // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance + let groupByValueType (keyf: 'T->'Key) (list: 'T list) = groupByImpl HashIdentity.Structural<'Key> keyf id list + + // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation + let groupByRefType (keyf: 'T->'Key) (list: 'T list) = groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) list + + [] + let groupBy (projection: 'T->'Key) (list: 'T list) = + match list with + | [] -> [] + | _ -> + if typeof<'Key>.IsValueType + then groupByValueType projection list + else groupByRefType projection list + + [] + let partition predicate list = Microsoft.FSharp.Primitives.Basics.List.partition predicate list + + [] + let unzip list = Microsoft.FSharp.Primitives.Basics.List.unzip list + + [] + let unzip3 list = Microsoft.FSharp.Primitives.Basics.List.unzip3 list + + [] + let windowed windowSize list = Microsoft.FSharp.Primitives.Basics.List.windowed windowSize list + + [] + let chunkBySize chunkSize list = Microsoft.FSharp.Primitives.Basics.List.chunkBySize chunkSize list + + [] + let splitInto count list = Microsoft.FSharp.Primitives.Basics.List.splitInto count list + + [] + let zip list1 list2 = Microsoft.FSharp.Primitives.Basics.List.zip list1 list2 + + [] + let zip3 list1 list2 list3 = Microsoft.FSharp.Primitives.Basics.List.zip3 list1 list2 list3 + + [] + let skip count list = + if count <= 0 then list else + let rec loop i lst = + match lst with + | _ when i = 0 -> lst + | _ :: t -> loop (i-1) t + | [] -> invalidArgOutOfRange "count" count "distance past the list" i + loop count list + + [] + let rec skipWhile predicate list = + match list with + | head :: tail when predicate head -> skipWhile predicate tail + | _ -> list + + [] + let sortWith comparer list = + match list with + | [] | [_] -> list + | _ -> + let array = Microsoft.FSharp.Primitives.Basics.List.toArray list + Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceWith comparer array + Microsoft.FSharp.Primitives.Basics.List.ofArray array + + [] + let sortBy projection list = + match list with + | [] | [_] -> list + | _ -> + let array = Microsoft.FSharp.Primitives.Basics.List.toArray list + Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceBy projection array + Microsoft.FSharp.Primitives.Basics.List.ofArray array + + [] + let sort list = + match list with + | [] | [_] -> list + | _ -> + let array = Microsoft.FSharp.Primitives.Basics.List.toArray list + Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlace array + Microsoft.FSharp.Primitives.Basics.List.ofArray array + + [] + let inline sortByDescending projection list = + let inline compareDescending a b = compare (projection b) (projection a) + sortWith compareDescending list + + [] + let inline sortDescending list = + let inline compareDescending a b = compare b a + sortWith compareDescending list + + [] + let ofSeq source = Seq.toList source + + [] + let toSeq list = Seq.ofList list + + [] + let findIndex predicate list = + let rec loop n list = + match list with | [] -> indexNotFound() - | h :: t -> - match chooser h with - | None -> pick chooser t - | Some r -> r + | h :: t -> if predicate h then n else loop (n + 1) t - [] - let filter predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate list + loop 0 list - [] - let except (itemsToExclude: seq<'T>) list = - checkNonNull "itemsToExclude" itemsToExclude + [] + let tryFindIndex predicate list = + let rec loop n list = match list with - | [] -> list - | _ -> - let cached = HashSet(itemsToExclude, HashIdentity.Structural) - list |> filter cached.Add - - [] - let where predicate list = Microsoft.FSharp.Primitives.Basics.List.filter predicate list - - let inline groupByImpl (comparer:IEqualityComparer<'SafeKey>) (keyf: 'T->'SafeKey) (getKey:'SafeKey->'Key) (list: 'T list) = - Microsoft.FSharp.Primitives.Basics.List.groupBy comparer keyf getKey list - - // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let groupByValueType (keyf: 'T->'Key) (list: 'T list) = groupByImpl HashIdentity.Structural<'Key> keyf id list - - // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let groupByRefType (keyf: 'T->'Key) (list: 'T list) = groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) list - - [] - let groupBy (projection: 'T->'Key) (list: 'T list) = - match list with - | [] -> [] - | _ -> - if typeof<'Key>.IsValueType - then groupByValueType projection list - else groupByRefType projection list - - [] - let partition predicate list = Microsoft.FSharp.Primitives.Basics.List.partition predicate list - - [] - let unzip list = Microsoft.FSharp.Primitives.Basics.List.unzip list - - [] - let unzip3 list = Microsoft.FSharp.Primitives.Basics.List.unzip3 list - - [] - let windowed windowSize list = Microsoft.FSharp.Primitives.Basics.List.windowed windowSize list - - [] - let chunkBySize chunkSize list = Microsoft.FSharp.Primitives.Basics.List.chunkBySize chunkSize list - - [] - let splitInto count list = Microsoft.FSharp.Primitives.Basics.List.splitInto count list - - [] - let zip list1 list2 = Microsoft.FSharp.Primitives.Basics.List.zip list1 list2 - - [] - let zip3 list1 list2 list3 = Microsoft.FSharp.Primitives.Basics.List.zip3 list1 list2 list3 - - [] - let skip count list = - if count <= 0 then list else - let rec loop i lst = - match lst with - | _ when i = 0 -> lst - | _ :: t -> loop (i-1) t - | [] -> invalidArgOutOfRange "count" count "distance past the list" i - loop count list - - [] - let rec skipWhile predicate list = - match list with - | head :: tail when predicate head -> skipWhile predicate tail - | _ -> list - - [] - let sortWith comparer list = - match list with - | [] | [_] -> list - | _ -> - let array = Microsoft.FSharp.Primitives.Basics.List.toArray list - Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceWith comparer array - Microsoft.FSharp.Primitives.Basics.List.ofArray array - - [] - let sortBy projection list = - match list with - | [] | [_] -> list - | _ -> - let array = Microsoft.FSharp.Primitives.Basics.List.toArray list - Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlaceBy projection array - Microsoft.FSharp.Primitives.Basics.List.ofArray array - - [] - let sort list = - match list with - | [] | [_] -> list - | _ -> - let array = Microsoft.FSharp.Primitives.Basics.List.toArray list - Microsoft.FSharp.Primitives.Basics.Array.stableSortInPlace array - Microsoft.FSharp.Primitives.Basics.List.ofArray array - - [] - let inline sortByDescending projection list = - let inline compareDescending a b = compare (projection b) (projection a) - sortWith compareDescending list - - [] - let inline sortDescending list = - let inline compareDescending a b = compare b a - sortWith compareDescending list - - [] - let ofSeq source = Seq.toList source - - [] - let toSeq list = Seq.ofList list - - [] - let findIndex predicate list = - let rec loop n list = - match list with - | [] -> indexNotFound() - | h :: t -> if predicate h then n else loop (n + 1) t - - loop 0 list - - [] - let tryFindIndex predicate list = - let rec loop n list = - match list with - | [] -> None - | h :: t -> if predicate h then Some n else loop (n + 1) t - - loop 0 list - - [] - let findIndexBack predicate list = - list - |> toArray - |> Microsoft.FSharp.Primitives.Basics.Array.findIndexBack predicate - - [] - let tryFindIndexBack predicate list = - list - |> toArray - |> Microsoft.FSharp.Primitives.Basics.Array.tryFindIndexBack predicate - - [] - let inline sum (list: 'T list) = - match list with - | [] -> LanguagePrimitives.GenericZero<'T> - | t -> - let mutable acc = LanguagePrimitives.GenericZero<'T> - for x in t do - acc <- Checked.(+) acc x - acc - - [] - let inline sumBy ([] projection: 'T -> 'U) (list: 'T list) = - match list with - | [] -> LanguagePrimitives.GenericZero<'U> - | t -> - let mutable acc = LanguagePrimitives.GenericZero<'U> - for x in t do - acc <- Checked.(+) acc (projection x) - acc - - [] - let inline max (list: _ list) = - match list with - | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h :: t -> - let mutable acc = h - for x in t do - if x > acc then - acc <- x - acc - - [] - let inline maxBy projection (list: _ list) = - match list with - | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h :: t -> - let mutable acc = h - let mutable accv = projection h - for x in t do - let currv = projection x - if currv > accv then - acc <- x - accv <- currv - acc - - [] - let inline min (list: _ list) = - match list with - | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h :: t -> - let mutable acc = h - for x in t do - if x < acc then - acc <- x - acc - - [] - let inline minBy projection (list: _ list) = - match list with - | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | h :: t -> - let mutable acc = h - let mutable accv = projection h - for x in t do - let currv = projection x - if currv < accv then - acc <- x - accv <- currv - acc - - [] - let inline average (list: 'T list) = - match list with - | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | xs -> - let mutable sum = LanguagePrimitives.GenericZero<'T> - let mutable count = 0 - for x in xs do - sum <- Checked.(+) sum x - count <- count + 1 - LanguagePrimitives.DivideByInt sum count - - [] - let inline averageBy ([] projection: 'T -> 'U) (list: 'T list) = - match list with - | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | xs -> - let mutable sum = LanguagePrimitives.GenericZero<'U> - let mutable count = 0 - for x in xs do - sum <- Checked.(+) sum (projection x) - count <- count + 1 - LanguagePrimitives.DivideByInt sum count - - [] - let collect mapping list = Microsoft.FSharp.Primitives.Basics.List.collect mapping list - - [] - let allPairs list1 list2 = Microsoft.FSharp.Primitives.Basics.List.allPairs list1 list2 - - [] - let inline compareWith ([] comparer: 'T -> 'T -> int) (list1: 'T list) (list2: 'T list) = - let rec loop list1 list2 = - match list1, list2 with - | head1 :: tail1, head2 :: tail2 -> - let c = comparer head1 head2 - if c = 0 then loop tail1 tail2 else c - | [], [] -> 0 - | _, [] -> 1 - | [], _ -> -1 - - loop list1 list2 - - [] - let permute indexMap list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.permute indexMap |> ofArray - - [] - let exactlyOne (list: _ list) = - match list with - | [x] -> x - | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | _ -> invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) - - [] - let tryExactlyOne (list: _ list) = - match list with - | [x] -> Some x - | _ -> None - - [] - let transpose (lists: seq<'T list>) = - checkNonNull "lists" lists - Microsoft.FSharp.Primitives.Basics.List.transpose (ofSeq lists) - - [] - let truncate count list = Microsoft.FSharp.Primitives.Basics.List.truncate count list - - [] - let unfold<'T, 'State> (generator:'State -> ('T*'State) option) (state:'State) = Microsoft.FSharp.Primitives.Basics.List.unfold generator state - - [] - let removeAt (index: int) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" - - let mutable i = 0 - let mutable coll = ListCollector() - let mutable curr = source - while i < index do // traverse and save the linked list until item to be removed - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 - if curr.IsEmpty then invalidArg "index" "index must be within bounds of the list" - else coll.AddManyAndClose(curr.Tail) // when i = index, Head is the item which is ignored and Tail is the rest of the list - - [] - let removeManyAt (index: int) (count: int) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" - - let mutable i = 0 - let mutable coll = ListCollector() - let mutable curr = source - while i < index + count do // traverse and save the linked list until the last item to be removed - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - if i < index then coll.Add(h) //items before index we keep - curr <- t - i <- i + 1 - coll.AddManyAndClose(curr) // when i = index + count, we keep the rest of the list - - [] - let updateAt (index: int) (value: 'T) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" - - let mutable i = 0 - let mutable coll = ListCollector() - let mutable curr = source - while i < index do // Traverse and save the linked list until index - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 - coll.Add(value) // add value instead of Head - if curr.IsEmpty then invalidArg "index" "index must be within bounds of the list" - else coll.AddManyAndClose(curr.Tail) - - [] - let insertAt (index: int) (value: 'T) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" - - let mutable i = 0 - let mutable coll = ListCollector() - let mutable curr = source - while i < index do // traverse and save the linked list until index - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 - - coll.Add(value) - coll.AddManyAndClose(curr) // insert item BEFORE the item at the index - - [] - let insertManyAt (index: int) (values: seq<'T>) (source: 'T list) : 'T list = - if index < 0 then invalidArg "index" "index must be within bounds of the list" - - let mutable i = 0 - let mutable coll = ListCollector() - let mutable curr = source - while i < index do // traverse and save the linked list until index - match curr with - | [] -> invalidArg "index" "index must be within bounds of the list" - | h::t -> - coll.Add(h) - curr <- t - i <- i + 1 - coll.AddMany(values) // insert values BEFORE the item at the index - coll.AddManyAndClose(curr) \ No newline at end of file + | [] -> None + | h :: t -> if predicate h then Some n else loop (n + 1) t + + loop 0 list + + [] + let findIndexBack predicate list = + list + |> toArray + |> Microsoft.FSharp.Primitives.Basics.Array.findIndexBack predicate + + [] + let tryFindIndexBack predicate list = + list + |> toArray + |> Microsoft.FSharp.Primitives.Basics.Array.tryFindIndexBack predicate + + [] + let inline sum (list: 'T list) = + match list with + | [] -> LanguagePrimitives.GenericZero<'T> + | t -> + let mutable acc = LanguagePrimitives.GenericZero<'T> + for x in t do + acc <- Checked.(+) acc x + acc + + [] + let inline sumBy ([] projection: 'T -> 'U) (list: 'T list) = + match list with + | [] -> LanguagePrimitives.GenericZero<'U> + | t -> + let mutable acc = LanguagePrimitives.GenericZero<'U> + for x in t do + acc <- Checked.(+) acc (projection x) + acc + + [] + let inline max (list: _ list) = + match list with + | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | h :: t -> + let mutable acc = h + for x in t do + if x > acc then + acc <- x + acc + + [] + let inline maxBy projection (list: _ list) = + match list with + | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | h :: t -> + let mutable acc = h + let mutable accv = projection h + for x in t do + let currv = projection x + if currv > accv then + acc <- x + accv <- currv + acc + + [] + let inline min (list: _ list) = + match list with + | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | h :: t -> + let mutable acc = h + for x in t do + if x < acc then + acc <- x + acc + + [] + let inline minBy projection (list: _ list) = + match list with + | [] -> invalidArg "list" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | h :: t -> + let mutable acc = h + let mutable accv = projection h + for x in t do + let currv = projection x + if currv < accv then + acc <- x + accv <- currv + acc + + [] + let inline average (list: 'T list) = + match list with + | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | xs -> + let mutable sum = LanguagePrimitives.GenericZero<'T> + let mutable count = 0 + for x in xs do + sum <- Checked.(+) sum x + count <- count + 1 + LanguagePrimitives.DivideByInt sum count + + [] + let inline averageBy ([] projection: 'T -> 'U) (list: 'T list) = + match list with + | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | xs -> + let mutable sum = LanguagePrimitives.GenericZero<'U> + let mutable count = 0 + for x in xs do + sum <- Checked.(+) sum (projection x) + count <- count + 1 + LanguagePrimitives.DivideByInt sum count + + [] + let collect mapping list = Microsoft.FSharp.Primitives.Basics.List.collect mapping list + + [] + let allPairs list1 list2 = Microsoft.FSharp.Primitives.Basics.List.allPairs list1 list2 + + [] + let inline compareWith ([] comparer: 'T -> 'T -> int) (list1: 'T list) (list2: 'T list) = + let rec loop list1 list2 = + match list1, list2 with + | head1 :: tail1, head2 :: tail2 -> + let c = comparer head1 head2 + if c = 0 then loop tail1 tail2 else c + | [], [] -> 0 + | _, [] -> 1 + | [], _ -> -1 + + loop list1 list2 + + [] + let permute indexMap list = list |> toArray |> Microsoft.FSharp.Primitives.Basics.Array.permute indexMap |> ofArray + + [] + let exactlyOne (list: _ list) = + match list with + | [x] -> x + | [] -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | _ -> invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) + + [] + let tryExactlyOne (list: _ list) = + match list with + | [x] -> Some x + | _ -> None + + [] + let transpose (lists: seq<'T list>) = + checkNonNull "lists" lists + Microsoft.FSharp.Primitives.Basics.List.transpose (ofSeq lists) + + [] + let truncate count list = Microsoft.FSharp.Primitives.Basics.List.truncate count list + + [] + let unfold<'T, 'State> (generator:'State -> ('T*'State) option) (state:'State) = Microsoft.FSharp.Primitives.Basics.List.unfold generator state + + [] + let removeAt (index: int) (source: 'T list) : 'T list = + if index < 0 then invalidArg "index" "index must be within bounds of the list" + + let mutable i = 0 + let mutable coll = ListCollector() + let mutable curr = source + while i < index do // traverse and save the linked list until item to be removed + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h::t -> + coll.Add(h) + curr <- t + i <- i + 1 + if curr.IsEmpty then invalidArg "index" "index must be within bounds of the list" + else coll.AddManyAndClose(curr.Tail) // when i = index, Head is the item which is ignored and Tail is the rest of the list + + [] + let removeManyAt (index: int) (count: int) (source: 'T list) : 'T list = + if index < 0 then invalidArg "index" "index must be within bounds of the list" + + let mutable i = 0 + let mutable coll = ListCollector() + let mutable curr = source + while i < index + count do // traverse and save the linked list until the last item to be removed + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h::t -> + if i < index then coll.Add(h) //items before index we keep + curr <- t + i <- i + 1 + coll.AddManyAndClose(curr) // when i = index + count, we keep the rest of the list + + [] + let updateAt (index: int) (value: 'T) (source: 'T list) : 'T list = + if index < 0 then invalidArg "index" "index must be within bounds of the list" + + let mutable i = 0 + let mutable coll = ListCollector() + let mutable curr = source + while i < index do // Traverse and save the linked list until index + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h::t -> + coll.Add(h) + curr <- t + i <- i + 1 + coll.Add(value) // add value instead of Head + if curr.IsEmpty then invalidArg "index" "index must be within bounds of the list" + else coll.AddManyAndClose(curr.Tail) + + [] + let insertAt (index: int) (value: 'T) (source: 'T list) : 'T list = + if index < 0 then invalidArg "index" "index must be within bounds of the list" + + let mutable i = 0 + let mutable coll = ListCollector() + let mutable curr = source + while i < index do // traverse and save the linked list until index + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h::t -> + coll.Add(h) + curr <- t + i <- i + 1 + + coll.Add(value) + coll.AddManyAndClose(curr) // insert item BEFORE the item at the index + + [] + let insertManyAt (index: int) (values: seq<'T>) (source: 'T list) : 'T list = + if index < 0 then invalidArg "index" "index must be within bounds of the list" + + let mutable i = 0 + let mutable coll = ListCollector() + let mutable curr = source + while i < index do // traverse and save the linked list until index + match curr with + | [] -> invalidArg "index" "index must be within bounds of the list" + | h::t -> + coll.Add(h) + curr <- t + i <- i + 1 + coll.AddMany(values) // insert values BEFORE the item at the index + coll.AddManyAndClose(curr) \ No newline at end of file diff --git a/src/FSharp.Core/local.fs b/src/FSharp.Core/local.fs index 16c7c77e63e1a2b9714f7f173b4b6063316e0496..f7184b9ae366ec5fd2d967591efdfc02a1798096 100644 --- a/src/FSharp.Core/local.fs +++ b/src/FSharp.Core/local.fs @@ -2,8 +2,10 @@ namespace Microsoft.FSharp.Core + [] module internal DetailedExceptions = + open System open Microsoft.FSharp.Core diff --git a/src/FSharp.Core/mailbox.fs b/src/FSharp.Core/mailbox.fs index 96782fa1e15930105e004f7a1380a67f5717bcf3..78035f34727c9571853a2075abd46497770beddb 100644 --- a/src/FSharp.Core/mailbox.fs +++ b/src/FSharp.Core/mailbox.fs @@ -2,439 +2,439 @@ namespace Microsoft.FSharp.Control - open System - open System.Threading - open System.Collections.Generic - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Control - open Microsoft.FSharp.Control.AsyncBuilderImpl - open Microsoft.FSharp.Control.AsyncPrimitives - open Microsoft.FSharp.Collections - - module AsyncHelpers = - - let awaitEither a1 a2 = - async { - let resultCell = new ResultCell<_>() - let! cancellationToken = Async.CancellationToken - let start a f = - Async.StartWithContinuationsUsingDispatchInfo(a, - (fun res -> resultCell.RegisterResult(f res |> AsyncResult.Ok, reuseThread=false) |> ignore), - (fun edi -> resultCell.RegisterResult(edi |> AsyncResult.Error, reuseThread=false) |> ignore), - (fun oce -> resultCell.RegisterResult(oce |> AsyncResult.Canceled, reuseThread=false) |> ignore), - cancellationToken = cancellationToken - ) - start a1 Choice1Of2 - start a2 Choice2Of2 - // Note: It is ok to use "NoDirectCancel" here because the started computations use the same - // cancellation token and will register a cancelled result if cancellation occurs. - // Note: It is ok to use "NoDirectTimeout" here because there is no specific timeout log to this routine. - let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout - return! CreateAsyncResultAsync result - } - - let timeout msec cancellationToken = - assert (msec >= 0) +open System +open System.Threading +open System.Collections.Generic +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Control.AsyncBuilderImpl +open Microsoft.FSharp.Control.AsyncPrimitives +open Microsoft.FSharp.Collections + +module AsyncHelpers = + + let awaitEither a1 a2 = + async { let resultCell = new ResultCell<_>() - Async.StartWithContinuations( - computation=Async.Sleep msec, - continuation=(fun () -> resultCell.RegisterResult((), reuseThread = false) |> ignore), - exceptionContinuation=ignore, - cancellationContinuation=ignore, - cancellationToken = cancellationToken) + let! cancellationToken = Async.CancellationToken + let start a f = + Async.StartWithContinuationsUsingDispatchInfo(a, + (fun res -> resultCell.RegisterResult(f res |> AsyncResult.Ok, reuseThread=false) |> ignore), + (fun edi -> resultCell.RegisterResult(edi |> AsyncResult.Error, reuseThread=false) |> ignore), + (fun oce -> resultCell.RegisterResult(oce |> AsyncResult.Canceled, reuseThread=false) |> ignore), + cancellationToken = cancellationToken + ) + start a1 Choice1Of2 + start a2 Choice2Of2 // Note: It is ok to use "NoDirectCancel" here because the started computations use the same // cancellation token and will register a cancelled result if cancellation occurs. - // Note: It is ok to use "NoDirectTimeout" here because the child compuation above looks after the timeout. - resultCell.AwaitResult_NoDirectCancelOrTimeout - - [] - [] - type Mailbox<'Msg>(cancellationSupported: bool) = - let mutable inboxStore = null - let arrivals = Queue<'Msg>() - let syncRoot = arrivals - - // Control elements indicating the state of the reader. When the reader is "blocked" at an - // asynchronous receive, either - // -- "cont" is non-null and the reader is "activated" by re-scheduling cont in the thread pool; or - // -- "pulse" is non-null and the reader is "activated" by setting this event - let mutable savedCont : (bool -> AsyncReturn) option = None - - // Readers who have a timeout use this event - let mutable pulse : AutoResetEvent = null - - // Make sure that the "pulse" value is created - let ensurePulse() = - match pulse with - | null -> - pulse <- new AutoResetEvent(false) - | _ -> - () - pulse - - let waitOneNoTimeoutOrCancellation = - MakeAsync (fun ctxt -> - match savedCont with - | None -> - let descheduled = - // An arrival may have happened while we're preparing to deschedule - lock syncRoot (fun () -> - if arrivals.Count = 0 then - // OK, no arrival so deschedule - savedCont <- Some(fun res -> ctxt.QueueContinuationWithTrampoline res) - true - else - false) - if descheduled then - Unchecked.defaultof<_> - else - // If we didn't deschedule then run the continuation immediately - ctxt.CallContinuation true - | Some _ -> - failwith "multiple waiting reader continuations for mailbox") - - let waitOneWithCancellation timeout = - Async.AwaitWaitHandle(ensurePulse(), millisecondsTimeout=timeout) - - let waitOne timeout = - if timeout < 0 && not cancellationSupported then - waitOneNoTimeoutOrCancellation - else - waitOneWithCancellation timeout - - member _.inbox = - match inboxStore with - | null -> inboxStore <- new System.Collections.Generic.List<'Msg>(1) - | _ -> () - inboxStore - - member x.CurrentQueueLength = - lock syncRoot (fun () -> x.inbox.Count + arrivals.Count) - - member x.ScanArrivalsUnsafe f = - if arrivals.Count = 0 then - None + // Note: It is ok to use "NoDirectTimeout" here because there is no specific timeout log to this routine. + let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout + return! CreateAsyncResultAsync result + } + + let timeout msec cancellationToken = + assert (msec >= 0) + let resultCell = new ResultCell<_>() + Async.StartWithContinuations( + computation=Async.Sleep msec, + continuation=(fun () -> resultCell.RegisterResult((), reuseThread = false) |> ignore), + exceptionContinuation=ignore, + cancellationContinuation=ignore, + cancellationToken = cancellationToken) + // Note: It is ok to use "NoDirectCancel" here because the started computations use the same + // cancellation token and will register a cancelled result if cancellation occurs. + // Note: It is ok to use "NoDirectTimeout" here because the child compuation above looks after the timeout. + resultCell.AwaitResult_NoDirectCancelOrTimeout + +[] +[] +type Mailbox<'Msg>(cancellationSupported: bool) = + let mutable inboxStore = null + let arrivals = Queue<'Msg>() + let syncRoot = arrivals + + // Control elements indicating the state of the reader. When the reader is "blocked" at an + // asynchronous receive, either + // -- "cont" is non-null and the reader is "activated" by re-scheduling cont in the thread pool; or + // -- "pulse" is non-null and the reader is "activated" by setting this event + let mutable savedCont : (bool -> AsyncReturn) option = None + + // Readers who have a timeout use this event + let mutable pulse : AutoResetEvent = null + + // Make sure that the "pulse" value is created + let ensurePulse() = + match pulse with + | null -> + pulse <- new AutoResetEvent(false) + | _ -> + () + pulse + + let waitOneNoTimeoutOrCancellation = + MakeAsync (fun ctxt -> + match savedCont with + | None -> + let descheduled = + // An arrival may have happened while we're preparing to deschedule + lock syncRoot (fun () -> + if arrivals.Count = 0 then + // OK, no arrival so deschedule + savedCont <- Some(fun res -> ctxt.QueueContinuationWithTrampoline res) + true + else + false) + if descheduled then + Unchecked.defaultof<_> + else + // If we didn't deschedule then run the continuation immediately + ctxt.CallContinuation true + | Some _ -> + failwith "multiple waiting reader continuations for mailbox") + + let waitOneWithCancellation timeout = + Async.AwaitWaitHandle(ensurePulse(), millisecondsTimeout=timeout) + + let waitOne timeout = + if timeout < 0 && not cancellationSupported then + waitOneNoTimeoutOrCancellation + else + waitOneWithCancellation timeout + + member _.inbox = + match inboxStore with + | null -> inboxStore <- new System.Collections.Generic.List<'Msg>(1) + | _ -> () + inboxStore + + member x.CurrentQueueLength = + lock syncRoot (fun () -> x.inbox.Count + arrivals.Count) + + member x.ScanArrivalsUnsafe f = + if arrivals.Count = 0 then + None + else + let msg = arrivals.Dequeue() + match f msg with + | None -> + x.inbox.Add msg + x.ScanArrivalsUnsafe f + | res -> res + + // Lock the arrivals queue while we scan that + member x.ScanArrivals f = + lock syncRoot (fun () -> x.ScanArrivalsUnsafe f) + + member x.ScanInbox(f, n) = + match inboxStore with + | null -> None + | inbox -> + if n >= inbox.Count + then None else - let msg = arrivals.Dequeue() + let msg = inbox.[n] match f msg with - | None -> - x.inbox.Add msg - x.ScanArrivalsUnsafe f - | res -> res - - // Lock the arrivals queue while we scan that - member x.ScanArrivals f = - lock syncRoot (fun () -> x.ScanArrivalsUnsafe f) - - member x.ScanInbox(f, n) = - match inboxStore with - | null -> None - | inbox -> - if n >= inbox.Count - then None - else - let msg = inbox.[n] - match f msg with - | None -> x.ScanInbox (f, n+1) - | res -> inbox.RemoveAt n; res - - member x.ReceiveFromArrivalsUnsafe() = - if arrivals.Count = 0 then + | None -> x.ScanInbox (f, n+1) + | res -> inbox.RemoveAt n; res + + member x.ReceiveFromArrivalsUnsafe() = + if arrivals.Count = 0 then + None + else + Some(arrivals.Dequeue()) + + member x.ReceiveFromArrivals() = + lock syncRoot (fun () -> x.ReceiveFromArrivalsUnsafe()) + + member x.ReceiveFromInbox() = + match inboxStore with + | null -> None + | inbox -> + if inbox.Count = 0 then None else - Some(arrivals.Dequeue()) - - member x.ReceiveFromArrivals() = - lock syncRoot (fun () -> x.ReceiveFromArrivalsUnsafe()) - - member x.ReceiveFromInbox() = - match inboxStore with - | null -> None - | inbox -> - if inbox.Count = 0 then - None - else - let x = inbox.[0] - inbox.RemoveAt 0 - Some x - - member x.Post msg = - lock syncRoot (fun () -> - - // Add the message to the arrivals queue - arrivals.Enqueue msg - - // Cooperatively unblock any waiting reader. If there is no waiting - // reader we just leave the message in the incoming queue - match savedCont with - | None -> - match pulse with - | null -> - () // no one waiting, leaving the message in the queue is sufficient - | ev -> - // someone is waiting on the wait handle - ev.Set() |> ignore - - | Some action -> - savedCont <- None - action true |> ignore) - - member x.TryScan ((f: 'Msg -> (Async<'T>) option), timeout) : Async<'T option> = - let rec scan timeoutAsync (timeoutCts:CancellationTokenSource) = - async { - match x.ScanArrivals f with - | None -> - // Deschedule and wait for a message. When it comes, rescan the arrivals - let! ok = AsyncHelpers.awaitEither waitOneNoTimeoutOrCancellation timeoutAsync - match ok with - | Choice1Of2 true -> - return! scan timeoutAsync timeoutCts - | Choice1Of2 false -> - return failwith "should not happen - waitOneNoTimeoutOrCancellation always returns true" - | Choice2Of2 () -> - lock syncRoot (fun () -> - // Cancel the outstanding wait for messages installed by waitOneWithCancellation - // - // HERE BE DRAGONS. This is bestowed on us because we only support - // a single mailbox reader at any one time. - // If awaitEither returned control because timeoutAsync has terminated, waitOneNoTimeoutOrCancellation - // might still be in-flight. In practical terms, it means that the push-to-async-result-cell - // continuation that awaitEither registered on it is still pending, i.e. it is still in savedCont. - // That continuation is a no-op now, but it is still a registered reader for arriving messages. - // Therefore we just abandon it - a brutal way of canceling. - // This ugly non-compositionality is only needed because we only support a single mailbox reader - // (i.e. the user is not allowed to run several Receive/TryReceive/Scan/TryScan in parallel) - otherwise - // we would just have an extra no-op reader in the queue. - savedCont <- None) - - return None - | Some resP -> - timeoutCts.Cancel() // cancel the timeout watcher - let! res = resP - return Some res - } - let rec scanNoTimeout () = - async { - match x.ScanArrivals f with - | None -> - let! ok = waitOne Timeout.Infinite - if ok then - return! scanNoTimeout() - else - return (failwith "Timed out with infinite timeout??") - | Some resP -> - let! res = resP - return Some res - } - - // Look in the inbox first + let x = inbox.[0] + inbox.RemoveAt 0 + Some x + + member x.Post msg = + lock syncRoot (fun () -> + + // Add the message to the arrivals queue + arrivals.Enqueue msg + + // Cooperatively unblock any waiting reader. If there is no waiting + // reader we just leave the message in the incoming queue + match savedCont with + | None -> + match pulse with + | null -> + () // no one waiting, leaving the message in the queue is sufficient + | ev -> + // someone is waiting on the wait handle + ev.Set() |> ignore + + | Some action -> + savedCont <- None + action true |> ignore) + + member x.TryScan ((f: 'Msg -> (Async<'T>) option), timeout) : Async<'T option> = + let rec scan timeoutAsync (timeoutCts:CancellationTokenSource) = async { - match x.ScanInbox(f, 0) with - | None when timeout < 0 -> - return! scanNoTimeout() + match x.ScanArrivals f with | None -> - let! cancellationToken = Async.CancellationToken - let timeoutCts = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, CancellationToken.None) - let timeoutAsync = AsyncHelpers.timeout timeout timeoutCts.Token - return! scan timeoutAsync timeoutCts + // Deschedule and wait for a message. When it comes, rescan the arrivals + let! ok = AsyncHelpers.awaitEither waitOneNoTimeoutOrCancellation timeoutAsync + match ok with + | Choice1Of2 true -> + return! scan timeoutAsync timeoutCts + | Choice1Of2 false -> + return failwith "should not happen - waitOneNoTimeoutOrCancellation always returns true" + | Choice2Of2 () -> + lock syncRoot (fun () -> + // Cancel the outstanding wait for messages installed by waitOneWithCancellation + // + // HERE BE DRAGONS. This is bestowed on us because we only support + // a single mailbox reader at any one time. + // If awaitEither returned control because timeoutAsync has terminated, waitOneNoTimeoutOrCancellation + // might still be in-flight. In practical terms, it means that the push-to-async-result-cell + // continuation that awaitEither registered on it is still pending, i.e. it is still in savedCont. + // That continuation is a no-op now, but it is still a registered reader for arriving messages. + // Therefore we just abandon it - a brutal way of canceling. + // This ugly non-compositionality is only needed because we only support a single mailbox reader + // (i.e. the user is not allowed to run several Receive/TryReceive/Scan/TryScan in parallel) - otherwise + // we would just have an extra no-op reader in the queue. + savedCont <- None) + + return None | Some resP -> + timeoutCts.Cancel() // cancel the timeout watcher let! res = resP return Some res } - - member x.Scan((f: 'Msg -> (Async<'T>) option), timeout) = + let rec scanNoTimeout () = async { - let! resOpt = x.TryScan(f, timeout) - match resOpt with - | None -> return raise(TimeoutException(SR.GetString(SR.mailboxScanTimedOut))) - | Some res -> return res + match x.ScanArrivals f with + | None -> + let! ok = waitOne Timeout.Infinite + if ok then + return! scanNoTimeout() + else + return (failwith "Timed out with infinite timeout??") + | Some resP -> + let! res = resP + return Some res } - member x.TryReceive timeout = - let rec processFirstArrival() = - async { - match x.ReceiveFromArrivals() with - | None -> - // Make sure the pulse is created if it is going to be needed. - // If it isn't, then create it, and go back to the start to - // check arrivals again. - match pulse with - | null when timeout >= 0 || cancellationSupported -> - ensurePulse() |> ignore - return! processFirstArrival() - | _ -> - // Wait until we have been notified about a message. When that happens, rescan the arrivals - let! ok = waitOne timeout - if ok then - return! processFirstArrival() - else - return None - | res -> return res - } - - // look in the inbox first + // Look in the inbox first + async { + match x.ScanInbox(f, 0) with + | None when timeout < 0 -> + return! scanNoTimeout() + | None -> + let! cancellationToken = Async.CancellationToken + let timeoutCts = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, CancellationToken.None) + let timeoutAsync = AsyncHelpers.timeout timeout timeoutCts.Token + return! scan timeoutAsync timeoutCts + | Some resP -> + let! res = resP + return Some res + } + + member x.Scan((f: 'Msg -> (Async<'T>) option), timeout) = + async { + let! resOpt = x.TryScan(f, timeout) + match resOpt with + | None -> return raise(TimeoutException(SR.GetString(SR.mailboxScanTimedOut))) + | Some res -> return res + } + + member x.TryReceive timeout = + let rec processFirstArrival() = async { - match x.ReceiveFromInbox() with - | None -> return! processFirstArrival() + match x.ReceiveFromArrivals() with + | None -> + // Make sure the pulse is created if it is going to be needed. + // If it isn't, then create it, and go back to the start to + // check arrivals again. + match pulse with + | null when timeout >= 0 || cancellationSupported -> + ensurePulse() |> ignore + return! processFirstArrival() + | _ -> + // Wait until we have been notified about a message. When that happens, rescan the arrivals + let! ok = waitOne timeout + if ok then + return! processFirstArrival() + else + return None | res -> return res } - member x.Receive timeout = - - let rec processFirstArrival() = - async { - match x.ReceiveFromArrivals() with - | None -> - // Make sure the pulse is created if it is going to be needed. - // If it isn't, then create it, and go back to the start to - // check arrivals again. - match pulse with - | null when timeout >= 0 || cancellationSupported -> - ensurePulse() |> ignore - return! processFirstArrival() - | _ -> - // Wait until we have been notified about a message. When that happens, rescan the arrivals - let! ok = waitOne timeout - if ok then - return! processFirstArrival() - else - return raise(TimeoutException(SR.GetString(SR.mailboxReceiveTimedOut))) - | Some res -> return res - } - - // look in the inbox first + // look in the inbox first + async { + match x.ReceiveFromInbox() with + | None -> return! processFirstArrival() + | res -> return res + } + + member x.Receive timeout = + + let rec processFirstArrival() = async { - match x.ReceiveFromInbox() with - | None -> return! processFirstArrival() + match x.ReceiveFromArrivals() with + | None -> + // Make sure the pulse is created if it is going to be needed. + // If it isn't, then create it, and go back to the start to + // check arrivals again. + match pulse with + | null when timeout >= 0 || cancellationSupported -> + ensurePulse() |> ignore + return! processFirstArrival() + | _ -> + // Wait until we have been notified about a message. When that happens, rescan the arrivals + let! ok = waitOne timeout + if ok then + return! processFirstArrival() + else + return raise(TimeoutException(SR.GetString(SR.mailboxReceiveTimedOut))) | Some res -> return res } - interface System.IDisposable with - member _.Dispose() = - if isNotNull pulse then (pulse :> IDisposable).Dispose() + // look in the inbox first + async { + match x.ReceiveFromInbox() with + | None -> return! processFirstArrival() + | Some res -> return res + } + + interface System.IDisposable with + member _.Dispose() = + if isNotNull pulse then (pulse :> IDisposable).Dispose() #if DEBUG - member x.UnsafeContents = - (x.inbox, arrivals, pulse, savedCont) |> box + member x.UnsafeContents = + (x.inbox, arrivals, pulse, savedCont) |> box #endif - [] - [] - type AsyncReplyChannel<'Reply>(replyf : 'Reply -> unit) = - member x.Reply value = replyf value +[] +[] +type AsyncReplyChannel<'Reply>(replyf : 'Reply -> unit) = + member x.Reply value = replyf value - [] - [] - [] - type MailboxProcessor<'Msg>(body, ?cancellationToken) = +[] +[] +[] +type MailboxProcessor<'Msg>(body, ?cancellationToken) = - let cancellationSupported = cancellationToken.IsSome - let cancellationToken = defaultArg cancellationToken Async.DefaultCancellationToken - let mailbox = new Mailbox<'Msg>(cancellationSupported) - let mutable defaultTimeout = Threading.Timeout.Infinite - let mutable started = false - let errorEvent = new Event() + let cancellationSupported = cancellationToken.IsSome + let cancellationToken = defaultArg cancellationToken Async.DefaultCancellationToken + let mailbox = new Mailbox<'Msg>(cancellationSupported) + let mutable defaultTimeout = Threading.Timeout.Infinite + let mutable started = false + let errorEvent = new Event() - member _.CurrentQueueLength = mailbox.CurrentQueueLength // nb. unprotected access gives an approximation of the queue length + member _.CurrentQueueLength = mailbox.CurrentQueueLength // nb. unprotected access gives an approximation of the queue length - member _.DefaultTimeout - with get() = defaultTimeout - and set v = defaultTimeout <- v + member _.DefaultTimeout + with get() = defaultTimeout + and set v = defaultTimeout <- v - [] - member _.Error = errorEvent.Publish + [] + member _.Error = errorEvent.Publish #if DEBUG - member _.UnsafeMessageQueueContents = mailbox.UnsafeContents + member _.UnsafeMessageQueueContents = mailbox.UnsafeContents #endif - member x.Start() = - if started then - raise (new InvalidOperationException(SR.GetString(SR.mailboxProcessorAlreadyStarted))) - else - started <- true - - // Protect the execution and send errors to the event. - // Note that exception stack traces are lost in this design - in an extended design - // the event could propagate an ExceptionDispatchInfo instead of an Exception. - let p = - async { try - do! body x - with exn -> - errorEvent.Trigger exn } - - Async.Start(computation=p, cancellationToken=cancellationToken) - - member _.Post message = mailbox.Post message - - member _.TryPostAndReply(buildMessage : (_ -> 'Msg), ?timeout) : 'Reply option = - let timeout = defaultArg timeout defaultTimeout - use resultCell = new ResultCell<_>() - let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> - // Note the ResultCell may have been disposed if the operation - // timed out. In this case RegisterResult drops the result on the floor. - resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) + member x.Start() = + if started then + raise (new InvalidOperationException(SR.GetString(SR.mailboxProcessorAlreadyStarted))) + else + started <- true + + // Protect the execution and send errors to the event. + // Note that exception stack traces are lost in this design - in an extended design + // the event could propagate an ExceptionDispatchInfo instead of an Exception. + let p = + async { try + do! body x + with exn -> + errorEvent.Trigger exn } + + Async.Start(computation=p, cancellationToken=cancellationToken) + + member _.Post message = mailbox.Post message + + member _.TryPostAndReply(buildMessage : (_ -> 'Msg), ?timeout) : 'Reply option = + let timeout = defaultArg timeout defaultTimeout + use resultCell = new ResultCell<_>() + let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> + // Note the ResultCell may have been disposed if the operation + // timed out. In this case RegisterResult drops the result on the floor. + resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) + mailbox.Post msg + resultCell.TryWaitForResultSynchronously(timeout=timeout) + + member x.PostAndReply(buildMessage, ?timeout) : 'Reply = + match x.TryPostAndReply(buildMessage, ?timeout=timeout) with + | None -> raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndReplyTimedOut))) + | Some res -> res + + member _.PostAndTryAsyncReply(buildMessage, ?timeout) : Async<'Reply option> = + let timeout = defaultArg timeout defaultTimeout + let resultCell = new ResultCell<_>() + let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> + // Note the ResultCell may have been disposed if the operation + // timed out. In this case RegisterResult drops the result on the floor. + resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) + mailbox.Post msg + match timeout with + | Threading.Timeout.Infinite when not cancellationSupported -> + async { let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout + return Some result } + + | _ -> + async { use _disposeCell = resultCell + let! ok = Async.AwaitWaitHandle(resultCell.GetWaitHandle(), millisecondsTimeout=timeout) + let res = (if ok then Some(resultCell.GrabResult()) else None) + return res } + + member x.PostAndAsyncReply(buildMessage, ?timeout:int) = + let timeout = defaultArg timeout defaultTimeout + match timeout with + | Threading.Timeout.Infinite when not cancellationSupported -> + // Nothing to dispose, no wait handles used + let resultCell = new ResultCell<_>() + let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) mailbox.Post msg - resultCell.TryWaitForResultSynchronously(timeout=timeout) + resultCell.AwaitResult_NoDirectCancelOrTimeout + | _ -> + let asyncReply = x.PostAndTryAsyncReply(buildMessage, timeout=timeout) + async { let! res = asyncReply + match res with + | None -> return! raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndAsyncReplyTimedOut))) + | Some res -> return res } - member x.PostAndReply(buildMessage, ?timeout) : 'Reply = - match x.TryPostAndReply(buildMessage, ?timeout=timeout) with - | None -> raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndReplyTimedOut))) - | Some res -> res + member _.Receive(?timeout) = + mailbox.Receive(timeout=defaultArg timeout defaultTimeout) - member _.PostAndTryAsyncReply(buildMessage, ?timeout) : Async<'Reply option> = - let timeout = defaultArg timeout defaultTimeout - let resultCell = new ResultCell<_>() - let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> - // Note the ResultCell may have been disposed if the operation - // timed out. In this case RegisterResult drops the result on the floor. - resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) - mailbox.Post msg - match timeout with - | Threading.Timeout.Infinite when not cancellationSupported -> - async { let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout - return Some result } - - | _ -> - async { use _disposeCell = resultCell - let! ok = Async.AwaitWaitHandle(resultCell.GetWaitHandle(), millisecondsTimeout=timeout) - let res = (if ok then Some(resultCell.GrabResult()) else None) - return res } - - member x.PostAndAsyncReply(buildMessage, ?timeout:int) = - let timeout = defaultArg timeout defaultTimeout - match timeout with - | Threading.Timeout.Infinite when not cancellationSupported -> - // Nothing to dispose, no wait handles used - let resultCell = new ResultCell<_>() - let msg = buildMessage (new AsyncReplyChannel<_>(fun reply -> resultCell.RegisterResult(reply, reuseThread=false) |> ignore)) - mailbox.Post msg - resultCell.AwaitResult_NoDirectCancelOrTimeout - | _ -> - let asyncReply = x.PostAndTryAsyncReply(buildMessage, timeout=timeout) - async { let! res = asyncReply - match res with - | None -> return! raise (TimeoutException(SR.GetString(SR.mailboxProcessorPostAndAsyncReplyTimedOut))) - | Some res -> return res } - - member _.Receive(?timeout) = - mailbox.Receive(timeout=defaultArg timeout defaultTimeout) - - member _.TryReceive(?timeout) = - mailbox.TryReceive(timeout=defaultArg timeout defaultTimeout) - - member _.Scan(scanner: 'Msg -> (Async<'T>) option, ?timeout) = - mailbox.Scan(scanner, timeout=defaultArg timeout defaultTimeout) - - member _.TryScan(scanner: 'Msg -> (Async<'T>) option, ?timeout) = - mailbox.TryScan(scanner, timeout=defaultArg timeout defaultTimeout) - - interface System.IDisposable with - member _.Dispose() = (mailbox :> IDisposable).Dispose() - - static member Start(body, ?cancellationToken) = - let mailboxProcessor = new MailboxProcessor<'Msg>(body, ?cancellationToken=cancellationToken) - mailboxProcessor.Start() - mailboxProcessor + member _.TryReceive(?timeout) = + mailbox.TryReceive(timeout=defaultArg timeout defaultTimeout) + + member _.Scan(scanner: 'Msg -> (Async<'T>) option, ?timeout) = + mailbox.Scan(scanner, timeout=defaultArg timeout defaultTimeout) + + member _.TryScan(scanner: 'Msg -> (Async<'T>) option, ?timeout) = + mailbox.TryScan(scanner, timeout=defaultArg timeout defaultTimeout) + + interface System.IDisposable with + member _.Dispose() = (mailbox :> IDisposable).Dispose() + + static member Start(body, ?cancellationToken) = + let mailboxProcessor = new MailboxProcessor<'Msg>(body, ?cancellationToken=cancellationToken) + mailboxProcessor.Start() + mailboxProcessor diff --git a/src/FSharp.Core/math/z.fs b/src/FSharp.Core/math/z.fs index fa65994315f1c3b43633a4dd3b94a8e77a182855..b79ad3671fd62e5852ca9efd55a6efda57ca0047 100644 --- a/src/FSharp.Core/math/z.fs +++ b/src/FSharp.Core/math/z.fs @@ -14,72 +14,72 @@ namespace Microsoft.FSharp.Math namespace Microsoft.FSharp.Core - type bigint = System.Numerics.BigInteger +type bigint = System.Numerics.BigInteger - open System - open System.Diagnostics.CodeAnalysis - open System.Globalization - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open System.Numerics +open System +open System.Diagnostics.CodeAnalysis +open System.Globalization +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open System.Numerics - [] - module NumericLiterals = +[] +module NumericLiterals = - module NumericLiteralI = + module NumericLiteralI = - let tab64 = new System.Collections.Generic.Dictionary() - let tabParse = new System.Collections.Generic.Dictionary() - - let FromInt64Dynamic (value:int64) : obj = - lock tab64 (fun () -> - let mutable res = Unchecked.defaultof<_> - let ok = tab64.TryGetValue(value,&res) - if ok then res else - res <- BigInteger(value) - tab64.[value] <- res - res) + let tab64 = new System.Collections.Generic.Dictionary() + let tabParse = new System.Collections.Generic.Dictionary() + + let FromInt64Dynamic (value:int64) : obj = + lock tab64 (fun () -> + let mutable res = Unchecked.defaultof<_> + let ok = tab64.TryGetValue(value,&res) + if ok then res else + res <- BigInteger(value) + tab64.[value] <- res + res) - let inline get32 (x32:int32) = FromInt64Dynamic (int64 x32) + let inline get32 (x32:int32) = FromInt64Dynamic (int64 x32) - let inline isOX s = not (System.String.IsNullOrEmpty(s)) && s.Length > 2 && s.[0] = '0' && s.[1] = 'x' - - let FromZero () : 'T = - (get32 0 :?> 'T) - when 'T : BigInteger = BigInteger.Zero + let inline isOX s = not (System.String.IsNullOrEmpty(s)) && s.Length > 2 && s.[0] = '0' && s.[1] = 'x' + + let FromZero () : 'T = + (get32 0 :?> 'T) + when 'T : BigInteger = BigInteger.Zero - let FromOne () : 'T = - (get32 1 :?> 'T) - when 'T : BigInteger = BigInteger.One + let FromOne () : 'T = + (get32 1 :?> 'T) + when 'T : BigInteger = BigInteger.One - let FromInt32 (value:int32): 'T = - (get32 value :?> 'T) - when 'T : BigInteger = new BigInteger(value) + let FromInt32 (value:int32): 'T = + (get32 value :?> 'T) + when 'T : BigInteger = new BigInteger(value) + + let FromInt64 (value:int64): 'T = + (FromInt64Dynamic value :?> 'T) + when 'T : BigInteger = new BigInteger(value) - let FromInt64 (value:int64): 'T = - (FromInt64Dynamic value :?> 'T) - when 'T : BigInteger = new BigInteger(value) - - let getParse s = - lock tabParse (fun () -> - let mutable res = Unchecked.defaultof<_> - let ok = tabParse.TryGetValue(s,&res) - if ok then - res - else - let v = - if isOX s then - BigInteger.Parse (s.[2..],NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture) - else - BigInteger.Parse (s,NumberStyles.AllowLeadingSign,CultureInfo.InvariantCulture) - res <- v - tabParse.[s] <- res - res) + let getParse s = + lock tabParse (fun () -> + let mutable res = Unchecked.defaultof<_> + let ok = tabParse.TryGetValue(s,&res) + if ok then + res + else + let v = + if isOX s then + BigInteger.Parse (s.[2..],NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture) + else + BigInteger.Parse (s,NumberStyles.AllowLeadingSign,CultureInfo.InvariantCulture) + res <- v + tabParse.[s] <- res + res) - let FromStringDynamic (text:string) : obj = - getParse text - - let FromString (text:string) : 'T = - (FromStringDynamic text :?> 'T) - when 'T : BigInteger = getParse text + let FromStringDynamic (text:string) : obj = + getParse text + + let FromString (text:string) : 'T = + (FromStringDynamic text :?> 'T) + when 'T : BigInteger = getParse text diff --git a/src/FSharp.Core/observable.fs b/src/FSharp.Core/observable.fs index 75ef1d081b1104e43c903b997e7de4be666affd5..4e5af5232c72efa47645b9c6fd73d95d3b1f7f5b 100644 --- a/src/FSharp.Core/observable.fs +++ b/src/FSharp.Core/observable.fs @@ -2,176 +2,176 @@ namespace Microsoft.FSharp.Control - open System - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Control - - [] - [] - module Observable = - - let inline protect f succeed fail = - match (try Choice1Of2 (f ()) with e -> Choice2Of2 e) with - | Choice1Of2 x -> (succeed x) - | Choice2Of2 e -> (fail e) - - [] - type BasicObserver<'T>() = - - let mutable stopped = false - - abstract Next : value : 'T -> unit - - abstract Error : error : exn -> unit - - abstract Completed : unit -> unit - - interface IObserver<'T> with - - member x.OnNext value = - if not stopped then - x.Next value - - member x.OnError e = - if not stopped then - stopped <- true - x.Error e - - member x.OnCompleted () = - if not stopped then - stopped <- true - x.Completed () - - [] - let map mapping (source: IObservable<'T>) = - { new IObservable<'U> with - member x.Subscribe(observer) = - source.Subscribe - { new BasicObserver<'T>() with - - member x.Next(v) = - protect (fun () -> mapping v) observer.OnNext observer.OnError - - member x.Error(e) = observer.OnError(e) - - member x.Completed() = observer.OnCompleted() } } - - [] - let choose chooser (source: IObservable<'T>) = - { new IObservable<'U> with - member x.Subscribe(observer) = - source.Subscribe - { new BasicObserver<'T>() with - - member x.Next(v) = - protect (fun () -> chooser v) (function None -> () | Some v2 -> observer.OnNext v2) observer.OnError - - member x.Error(e) = observer.OnError(e) - - member x.Completed() = observer.OnCompleted() } } - - [] - let filter predicate (source: IObservable<'T>) = - choose (fun x -> if predicate x then Some x else None) source - - [] - let partition predicate (source: IObservable<'T>) = - filter predicate source, filter (predicate >> not) source - - [] - let scan collector state (source: IObservable<'T>) = - { new IObservable<'U> with - member x.Subscribe(observer) = - let mutable state = state - source.Subscribe - { new BasicObserver<'T>() with - - member x.Next(v) = - let z = state - protect (fun () -> collector z v) (fun z -> - state <- z - observer.OnNext z) observer.OnError - - member x.Error(e) = observer.OnError(e) - - member x.Completed() = observer.OnCompleted() } } - - [] - let add callback (source: IObservable<'T>) = source.Add(callback) - - [] - let subscribe (callback: 'T -> unit) (source: IObservable<'T>) = source.Subscribe(callback) - - [] - let pairwise (source : IObservable<'T>) : IObservable<'T * 'T> = - { new IObservable<_> with - member x.Subscribe(observer) = - let mutable lastArgs = None - source.Subscribe - { new BasicObserver<'T>() with - - member x.Next(args2) = - match lastArgs with - | None -> () - | Some args1 -> observer.OnNext (args1,args2) - lastArgs <- Some args2 - - member x.Error(e) = observer.OnError(e) - - member x.Completed() = observer.OnCompleted() } } - - [] - let merge (source1: IObservable<'T>) (source2: IObservable<'T>) = - { new IObservable<_> with - member x.Subscribe(observer) = - let mutable stopped = false - let mutable completed1 = false - let mutable completed2 = false - let h1 = - source1.Subscribe - { new IObserver<'T> with - member x.OnNext(v) = - if not stopped then - observer.OnNext v - - member x.OnError(e) = - if not stopped then +open System +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Control + +[] +[] +module Observable = + + let inline protect f succeed fail = + match (try Choice1Of2 (f ()) with e -> Choice2Of2 e) with + | Choice1Of2 x -> (succeed x) + | Choice2Of2 e -> (fail e) + + [] + type BasicObserver<'T>() = + + let mutable stopped = false + + abstract Next : value : 'T -> unit + + abstract Error : error : exn -> unit + + abstract Completed : unit -> unit + + interface IObserver<'T> with + + member x.OnNext value = + if not stopped then + x.Next value + + member x.OnError e = + if not stopped then + stopped <- true + x.Error e + + member x.OnCompleted () = + if not stopped then + stopped <- true + x.Completed () + + [] + let map mapping (source: IObservable<'T>) = + { new IObservable<'U> with + member x.Subscribe(observer) = + source.Subscribe + { new BasicObserver<'T>() with + + member x.Next(v) = + protect (fun () -> mapping v) observer.OnNext observer.OnError + + member x.Error(e) = observer.OnError(e) + + member x.Completed() = observer.OnCompleted() } } + + [] + let choose chooser (source: IObservable<'T>) = + { new IObservable<'U> with + member x.Subscribe(observer) = + source.Subscribe + { new BasicObserver<'T>() with + + member x.Next(v) = + protect (fun () -> chooser v) (function None -> () | Some v2 -> observer.OnNext v2) observer.OnError + + member x.Error(e) = observer.OnError(e) + + member x.Completed() = observer.OnCompleted() } } + + [] + let filter predicate (source: IObservable<'T>) = + choose (fun x -> if predicate x then Some x else None) source + + [] + let partition predicate (source: IObservable<'T>) = + filter predicate source, filter (predicate >> not) source + + [] + let scan collector state (source: IObservable<'T>) = + { new IObservable<'U> with + member x.Subscribe(observer) = + let mutable state = state + source.Subscribe + { new BasicObserver<'T>() with + + member x.Next(v) = + let z = state + protect (fun () -> collector z v) (fun z -> + state <- z + observer.OnNext z) observer.OnError + + member x.Error(e) = observer.OnError(e) + + member x.Completed() = observer.OnCompleted() } } + + [] + let add callback (source: IObservable<'T>) = source.Add(callback) + + [] + let subscribe (callback: 'T -> unit) (source: IObservable<'T>) = source.Subscribe(callback) + + [] + let pairwise (source : IObservable<'T>) : IObservable<'T * 'T> = + { new IObservable<_> with + member x.Subscribe(observer) = + let mutable lastArgs = None + source.Subscribe + { new BasicObserver<'T>() with + + member x.Next(args2) = + match lastArgs with + | None -> () + | Some args1 -> observer.OnNext (args1,args2) + lastArgs <- Some args2 + + member x.Error(e) = observer.OnError(e) + + member x.Completed() = observer.OnCompleted() } } + + [] + let merge (source1: IObservable<'T>) (source2: IObservable<'T>) = + { new IObservable<_> with + member x.Subscribe(observer) = + let mutable stopped = false + let mutable completed1 = false + let mutable completed2 = false + let h1 = + source1.Subscribe + { new IObserver<'T> with + member x.OnNext(v) = + if not stopped then + observer.OnNext v + + member x.OnError(e) = + if not stopped then + stopped <- true + observer.OnError(e) + + member x.OnCompleted() = + if not stopped then + completed1 <- true + if completed1 && completed2 then stopped <- true - observer.OnError(e) - - member x.OnCompleted() = - if not stopped then - completed1 <- true - if completed1 && completed2 then - stopped <- true - observer.OnCompleted() } - let h2 = - source2.Subscribe - { new IObserver<'T> with - member x.OnNext(v) = - if not stopped then - observer.OnNext v - - member x.OnError(e) = - if not stopped then + observer.OnCompleted() } + let h2 = + source2.Subscribe + { new IObserver<'T> with + member x.OnNext(v) = + if not stopped then + observer.OnNext v + + member x.OnError(e) = + if not stopped then + stopped <- true + observer.OnError(e) + + member x.OnCompleted() = + if not stopped then + completed2 <- true + if completed1 && completed2 then stopped <- true - observer.OnError(e) - - member x.OnCompleted() = - if not stopped then - completed2 <- true - if completed1 && completed2 then - stopped <- true - observer.OnCompleted() } - - { new IDisposable with - member x.Dispose() = - h1.Dispose() - h2.Dispose() } } - - [] - let split (splitter : 'T -> Choice<'U1,'U2>) (source: IObservable<'T>) = - choose (fun v -> match splitter v with Choice1Of2 x -> Some x | _ -> None) source, - choose (fun v -> match splitter v with Choice2Of2 x -> Some x | _ -> None) source + observer.OnCompleted() } + + { new IDisposable with + member x.Dispose() = + h1.Dispose() + h2.Dispose() } } + + [] + let split (splitter : 'T -> Choice<'U1,'U2>) (source: IObservable<'T>) = + choose (fun v -> match splitter v with Choice1Of2 x -> Some x | _ -> None) source, + choose (fun v -> match splitter v with Choice2Of2 x -> Some x | _ -> None) source diff --git a/src/FSharp.Core/quotations.fs b/src/FSharp.Core/quotations.fs index ed8829414d6687d09c5b8c387f1a9512f1b489d4..2dd9abf11b90755f559a6027f27ad81f42c05b47 100644 --- a/src/FSharp.Core/quotations.fs +++ b/src/FSharp.Core/quotations.fs @@ -91,10 +91,13 @@ type Var(name: string, typ: Type, ?isMutable: bool) = let stamp = getStamp () let isMutable = defaultArg isMutable false - member v.Name = name - member v.IsMutable = isMutable - member v.Type = typ - member v.Stamp = stamp + member _.Name = name + + member _.IsMutable = isMutable + + member _.Type = typ + + member _.Stamp = stamp static member Global(name, typ: Type) = checkNonNull "name" name @@ -107,9 +110,9 @@ type Var(name: string, typ: Type, ?isMutable: bool) = globals.[(name, typ)] <- res res) - override v.ToString() = name + override _.ToString() = name - override v.GetHashCode() = base.GetHashCode() + override _.GetHashCode() = base.GetHashCode() override v.Equals(obj:obj) = match obj with diff --git a/src/FSharp.Core/seq.fs b/src/FSharp.Core/seq.fs index fb6fd554ff7fd6bf7a770f7ed7f37c623199e27b..6e82b071ba783bfc162cb7285c4ff369505ab7ce 100644 --- a/src/FSharp.Core/seq.fs +++ b/src/FSharp.Core/seq.fs @@ -1,78 +1,84 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. namespace Microsoft.FSharp.Collections - #nowarn "52" // The value has been copied to ensure the original is not mutated by this operation - - open System - open System.Diagnostics - open System.Collections - open System.Collections.Generic - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Control - open Microsoft.FSharp.Collections - - module Internal = - module IEnumerator = - open Microsoft.FSharp.Collections.IEnumerator - - let rec tryItem index (e : IEnumerator<'T>) = - if not (e.MoveNext()) then None - elif index = 0 then Some e.Current - else tryItem (index-1) e - - let rec nth index (e : IEnumerator<'T>) = - if not (e.MoveNext()) then - let shortBy = index + 1 - invalidArgFmt "index" - "{0}\nseq was short by {1} {2}" - [|SR.GetString SR.notEnoughElements; shortBy; (if shortBy = 1 then "element" else "elements")|] - if index = 0 then e.Current - else nth (index - 1) e - - [] - type MapEnumeratorState = - | NotStarted - | InProcess - | Finished - - [] - type MapEnumerator<'T> () = - let mutable state = NotStarted - - [] - val mutable private curr : 'T - - member this.GetCurrent () = - match state with - | NotStarted -> notStarted() - | Finished -> alreadyFinished() - | InProcess -> () - this.curr - - abstract DoMoveNext : byref<'T> -> bool - abstract Dispose : unit -> unit - - interface IEnumerator<'T> with - member this.Current = this.GetCurrent() - - interface IEnumerator with - member this.Current = box(this.GetCurrent()) - member this.MoveNext () = - state <- InProcess - if this.DoMoveNext(&this.curr) then - true - else - state <- Finished - false - member _.Reset() = noReset() - interface System.IDisposable with - member this.Dispose() = this.Dispose() - - let map f (e : IEnumerator<_>) : IEnumerator<_>= - upcast - { new MapEnumerator<_>() with + +#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation + +open System +open System.Diagnostics +open System.Collections +open System.Collections.Generic +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Primitives.Basics + +module Internal = + + module IEnumerator = + + open Microsoft.FSharp.Collections.IEnumerator + + let rec tryItem index (e : IEnumerator<'T>) = + if not (e.MoveNext()) then None + elif index = 0 then Some e.Current + else tryItem (index-1) e + + let rec nth index (e : IEnumerator<'T>) = + if not (e.MoveNext()) then + let shortBy = index + 1 + invalidArgFmt "index" + "{0}\nseq was short by {1} {2}" + [|SR.GetString SR.notEnoughElements; shortBy; (if shortBy = 1 then "element" else "elements")|] + if index = 0 then e.Current + else nth (index - 1) e + + [] + type MapEnumeratorState = + | NotStarted + | InProcess + | Finished + + [] + type MapEnumerator<'T> () = + let mutable state = NotStarted + + [] + val mutable private curr : 'T + + member this.GetCurrent () = + match state with + | NotStarted -> notStarted() + | Finished -> alreadyFinished() + | InProcess -> () + this.curr + + abstract DoMoveNext : byref<'T> -> bool + abstract Dispose : unit -> unit + + interface IEnumerator<'T> with + member this.Current = this.GetCurrent() + + interface IEnumerator with + member this.Current = box(this.GetCurrent()) + member this.MoveNext () = + state <- InProcess + if this.DoMoveNext(&this.curr) then + true + else + state <- Finished + false + member _.Reset() = noReset() + + interface System.IDisposable with + member this.Dispose() = this.Dispose() + + let map f (e : IEnumerator<_>) : IEnumerator<_>= + upcast + { new MapEnumerator<_>() with member _.DoMoveNext (curr : byref<_>) = if e.MoveNext() then curr <- f e.Current @@ -80,97 +86,101 @@ namespace Microsoft.FSharp.Collections else false member _.Dispose() = e.Dispose() - } - - let mapi f (e : IEnumerator<_>) : IEnumerator<_> = - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) - let mutable i = -1 - upcast - { new MapEnumerator<_>() with - member _.DoMoveNext curr = + } + + let mapi f (e : IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + let mutable i = -1 + upcast + { new MapEnumerator<_>() with + member _.DoMoveNext curr = i <- i + 1 if e.MoveNext() then - curr <- f.Invoke(i, e.Current) - true + curr <- f.Invoke(i, e.Current) + true else - false - member _.Dispose() = e.Dispose() - } - - let map2 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) : IEnumerator<_>= - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) - upcast - { new MapEnumerator<_>() with - member _.DoMoveNext curr = + false + member _.Dispose() = e.Dispose() + } + + let map2 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) : IEnumerator<_>= + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(f) + upcast + { new MapEnumerator<_>() with + member _.DoMoveNext curr = let n1 = e1.MoveNext() let n2 = e2.MoveNext() if n1 && n2 then - curr <- f.Invoke(e1.Current, e2.Current) - true + curr <- f.Invoke(e1.Current, e2.Current) + true else - false + false + member _.Dispose() = try e1.Dispose() finally e2.Dispose() - } - - let mapi2 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) : IEnumerator<_> = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) - let mutable i = -1 - upcast - { new MapEnumerator<_>() with - member _.DoMoveNext curr = + } + + let mapi2 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) + let mutable i = -1 + upcast + { new MapEnumerator<_>() with + member _.DoMoveNext curr = i <- i + 1 if (e1.MoveNext() && e2.MoveNext()) then curr <- f.Invoke(i, e1.Current, e2.Current) true else false - member _.Dispose() = + + member _.Dispose() = try e1.Dispose() finally e2.Dispose() - } - - let map3 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) (e3 : IEnumerator<_>) : IEnumerator<_> = - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) - upcast - { new MapEnumerator<_>() with - member _.DoMoveNext curr = - let n1 = e1.MoveNext() - let n2 = e2.MoveNext() - let n3 = e3.MoveNext() - - if n1 && n2 && n3 then - curr <- f.Invoke(e1.Current, e2.Current, e3.Current) - true - else - false - member _.Dispose() = - try - e1.Dispose() - finally - try - e2.Dispose() - finally - e3.Dispose() - } - - let choose f (e : IEnumerator<'T>) = - let mutable started = false - let mutable curr = None - let get() = - check started - match curr with - | None -> alreadyFinished() - | Some x -> x - - { new IEnumerator<'U> with + } + + let map3 f (e1 : IEnumerator<_>) (e2 : IEnumerator<_>) (e3 : IEnumerator<_>) : IEnumerator<_> = + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt(f) + upcast + { new MapEnumerator<_>() with + member _.DoMoveNext curr = + let n1 = e1.MoveNext() + let n2 = e2.MoveNext() + let n3 = e3.MoveNext() + + if n1 && n2 && n3 then + curr <- f.Invoke(e1.Current, e2.Current, e3.Current) + true + else + false + + member _.Dispose() = + try + e1.Dispose() + finally + try + e2.Dispose() + finally + e3.Dispose() + } + + let choose f (e : IEnumerator<'T>) = + let mutable started = false + let mutable curr = None + let get() = + check started + match curr with + | None -> alreadyFinished() + | Some x -> x + + { new IEnumerator<'U> with member _.Current = get() - interface IEnumerator with + + interface IEnumerator with member _.Current = box (get()) member _.MoveNext() = if not started then started <- true @@ -178,74 +188,87 @@ namespace Microsoft.FSharp.Collections while (curr.IsNone && e.MoveNext()) do curr <- f e.Current Option.isSome curr + member _.Reset() = noReset() - interface System.IDisposable with + + interface System.IDisposable with member _.Dispose() = e.Dispose() } - let filter f (e : IEnumerator<'T>) = - let mutable started = false - let this = - { new IEnumerator<'T> with + let filter f (e : IEnumerator<'T>) = + let mutable started = false + let this = + { new IEnumerator<'T> with member _.Current = check started; e.Current - interface IEnumerator with + + interface IEnumerator with member _.Current = check started; box e.Current + member _.MoveNext() = let rec next() = if not started then started <- true e.MoveNext() && (f e.Current || next()) next() + member _.Reset() = noReset() - interface System.IDisposable with + + interface System.IDisposable with member _.Dispose() = e.Dispose() } - this + this - let unfold f x : IEnumerator<_> = - let mutable state = x - upcast - { new MapEnumerator<_>() with + let unfold f x : IEnumerator<_> = + let mutable state = x + upcast + { new MapEnumerator<_>() with member _.DoMoveNext curr = match f state with - | None -> false - | Some (r,s) -> - curr <- r - state <- s - true + | None -> false + | Some (r,s) -> + curr <- r + state <- s + true + member _.Dispose() = () - } - - let upto lastOption f = - match lastOption with - | Some b when b < 0 -> Empty() // a request for -ve length returns empty sequence - | _ -> - let unstarted = -1 // index value means unstarted (and no valid index) - let completed = -2 // index value means completed (and no valid index) - let unreachable = -3 // index is unreachable from 0,1,2,3,... - let finalIndex = match lastOption with - | Some b -> b // here b>=0, a valid end value. - | None -> unreachable // run "forever", well as far as Int32.MaxValue since indexing with a bounded type. - // The Current value for a valid index is "f i". - // Lazy<_> values are used as caches, to store either the result or an exception if thrown. - // These "Lazy<_>" caches are created only on the first call to current and forced immediately. - // The lazy creation of the cache nodes means enumerations that skip many Current values are not delayed by GC. - // For example, the full enumeration of Seq.initInfinite in the tests. - // state - let mutable index = unstarted - // a Lazy node to cache the result/exception - let mutable current = Unchecked.defaultof<_> - let setIndex i = - index <- i - current <- (Unchecked.defaultof<_>) // cache node unprimed, initialised on demand. - let getCurrent() = - if index = unstarted then notStarted() - if index = completed then alreadyFinished() - match box current with - | null -> current <- Lazy<_>.Create(fun () -> f index) - | _ -> () - // forced or re-forced immediately. - current.Force() - { new IEnumerator<'U> with + } + + let upto lastOption f = + match lastOption with + | Some b when b < 0 -> Empty() // a request for -ve length returns empty sequence + | _ -> + let unstarted = -1 // index value means unstarted (and no valid index) + let completed = -2 // index value means completed (and no valid index) + let unreachable = -3 // index is unreachable from 0,1,2,3,... + let finalIndex = + match lastOption with + | Some b -> b // here b>=0, a valid end value. + | None -> unreachable // run "forever", well as far as Int32.MaxValue since indexing with a bounded type. + + // The Current value for a valid index is "f i". + // Lazy<_> values are used as caches, to store either the result or an exception if thrown. + // These "Lazy<_>" caches are created only on the first call to current and forced immediately. + // The lazy creation of the cache nodes means enumerations that skip many Current values are not delayed by GC. + // For example, the full enumeration of Seq.initInfinite in the tests. + // state + let mutable index = unstarted + + // a Lazy node to cache the result/exception + let mutable current = Unchecked.defaultof<_> + let setIndex i = + index <- i + current <- (Unchecked.defaultof<_>) // cache node unprimed, initialised on demand. + + let getCurrent() = + if index = unstarted then notStarted() + if index = completed then alreadyFinished() + match box current with + | null -> + current <- Lazy<_>.Create(fun () -> f index) + | _ -> () + // forced or re-forced immediately. + current.Force() + { new IEnumerator<'U> with member _.Current = getCurrent() - interface IEnumerator with + + interface IEnumerator with member _.Current = box (getCurrent()) member _.MoveNext() = if index = completed then @@ -262,41 +285,46 @@ namespace Microsoft.FSharp.Collections true member _.Reset() = noReset() - interface System.IDisposable with - member _.Dispose() = () } - - [] - type ArrayEnumerator<'T>(arr: 'T array) = - let mutable curr = -1 - let mutable len = arr.Length - member _.Get() = - if curr >= 0 then - if curr >= len then alreadyFinished() - else arr.[curr] - else - notStarted() - interface IEnumerator<'T> with + + interface System.IDisposable with + member _.Dispose() = () + } + + [] + type ArrayEnumerator<'T>(arr: 'T array) = + let mutable curr = -1 + let mutable len = arr.Length + member _.Get() = + if curr >= 0 then + if curr >= len then alreadyFinished() + else arr.[curr] + else + notStarted() + + interface IEnumerator<'T> with member x.Current = x.Get() - interface System.Collections.IEnumerator with + + interface System.Collections.IEnumerator with member _.MoveNext() = - if curr >= len then false - else - curr <- curr + 1 - curr < len + if curr >= len then + false + else + curr <- curr + 1 + curr < len + member x.Current = box(x.Get()) - member x.Reset() = noReset() - interface System.IDisposable with - member x.Dispose() = () - let ofArray arr = (new ArrayEnumerator<'T>(arr) :> IEnumerator<'T>) + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = () + + let ofArray arr = (new ArrayEnumerator<'T>(arr) :> IEnumerator<'T>) // Use generators for some implementations of IEnumerables. // module Generator = - open System.Collections - open System.Collections.Generic - [] type Step<'T> = | Stop @@ -335,29 +363,33 @@ namespace Microsoft.FSharp.Collections // yield n } type GenerateThen<'T>(g:Generator<'T>, cont : unit -> Generator<'T>) = + member _.Generator = g + member _.Cont = cont + interface Generator<'T> with + member _.Apply = (fun () -> - match appG g with - | Stop -> - // OK, move onto the generator given by the continuation - Goto(cont()) + match appG g with + | Stop -> + // OK, move onto the generator given by the continuation + Goto(cont()) + + | Yield _ as res -> + res - | Yield _ as res -> - res + | Goto next -> + Goto(GenerateThen<_>.Bind(next, cont))) - | Goto next -> - Goto(GenerateThen<_>.Bind(next, cont))) member _.Disposer = - g.Disposer + g.Disposer static member Bind (g:Generator<'T>, cont) = match g with | :? GenerateThen<'T> as g -> GenerateThen<_>.Bind(g.Generator, (fun () -> GenerateThen<_>.Bind (g.Cont(), cont))) | g -> (new GenerateThen<'T>(g, cont) :> Generator<'T>) - let bindG g cont = GenerateThen<_>.Bind(g,cont) // Internal type. Drive an underlying generator. Crucially when the generator returns @@ -386,7 +418,9 @@ namespace Microsoft.FSharp.Collections let mutable g = g let mutable curr = None let mutable finished = false + member _.Generator = g + interface IEnumerator<'T> with member _.Current = match curr with @@ -395,6 +429,7 @@ namespace Microsoft.FSharp.Collections interface System.Collections.IEnumerator with member x.Current = box (x :> IEnumerator<_>).Current + member x.MoveNext() = not finished && match appG g with @@ -408,7 +443,9 @@ namespace Microsoft.FSharp.Collections | Goto next -> (g <- next) (x :> IEnumerator).MoveNext() + member _.Reset() = IEnumerator.noReset() + interface System.IDisposable with member _.Dispose() = if not finished then disposeG g @@ -435,254 +472,250 @@ namespace Microsoft.FSharp.Collections | _ -> (new LazyGeneratorWrappingEnumerator<'T>(e) :> Generator<'T>) -namespace Microsoft.FSharp.Collections - - open System - open System.Diagnostics - open System.Collections - open System.Collections.Generic - open System.Reflection - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.CompilerServices - open Microsoft.FSharp.Control - open Microsoft.FSharp.Collections - open Microsoft.FSharp.Primitives.Basics - - [] - type CachedSeq<'T>(cleanup,res:seq<'T>) = - interface System.IDisposable with - member x.Dispose() = cleanup() - interface System.Collections.Generic.IEnumerable<'T> with - member x.GetEnumerator() = res.GetEnumerator() - interface System.Collections.IEnumerable with - member x.GetEnumerator() = (res :> System.Collections.IEnumerable).GetEnumerator() - member obj.Clear() = cleanup() - - - [] - [] - module Seq = - - open Microsoft.FSharp.Collections.Internal - open Microsoft.FSharp.Collections.IEnumerator - - let mkDelayedSeq (f: unit -> IEnumerable<'T>) = mkSeq (fun () -> f().GetEnumerator()) - let mkUnfoldSeq f x = mkSeq (fun () -> IEnumerator.unfold f x) - let inline indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) - - [] - let delay generator = mkDelayedSeq generator - - [] - let unfold generator state = mkUnfoldSeq generator state - - [] - let empty<'T> = (EmptyEnumerable :> seq<'T>) - - [] - let initInfinite initializer = mkSeq (fun () -> IEnumerator.upto None initializer) - - [] - let init count initializer = - if count < 0 then invalidArgInputMustBeNonNegative "count" count - mkSeq (fun () -> IEnumerator.upto (Some (count - 1)) initializer) - - [] - let iter action (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - while e.MoveNext() do - action e.Current - - [] - let item index (source : seq<'T>) = - checkNonNull "source" source - if index < 0 then invalidArgInputMustBeNonNegative "index" index - use e = source.GetEnumerator() - IEnumerator.nth index e - - [] - let tryItem index (source : seq<'T>) = - checkNonNull "source" source - if index < 0 then None else - use e = source.GetEnumerator() - IEnumerator.tryItem index e - - [] - let nth index (source : seq<'T>) = item index source - - [] - let iteri action (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) - let mutable i = 0 - while e.MoveNext() do - f.Invoke(i, e.Current) - i <- i + 1 - - [] - let exists predicate (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable state = false - while (not state && e.MoveNext()) do - state <- predicate e.Current - state - - [] - let inline contains value (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable state = false - while (not state && e.MoveNext()) do - state <- value = e.Current - state - - [] - let forall predicate (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable state = true - while (state && e.MoveNext()) do - state <- predicate e.Current - state - - [] - let iter2 action (source1 : seq<_>) (source2 : seq<_>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - use e1 = source1.GetEnumerator() - use e2 = source2.GetEnumerator() - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt action - while (e1.MoveNext() && e2.MoveNext()) do - f.Invoke(e1.Current, e2.Current) - - [] - let iteri2 action (source1 : seq<_>) (source2 : seq<_>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - use e1 = source1.GetEnumerator() - use e2 = source2.GetEnumerator() - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt action - let mutable i = 0 - while (e1.MoveNext() && e2.MoveNext()) do - f.Invoke(i, e1.Current, e2.Current) - i <- i + 1 - - // Build an IEnumerable by wrapping/transforming iterators as they get generated. - let revamp f (ie : seq<_>) = mkSeq (fun () -> f (ie.GetEnumerator())) - let revamp2 f (ie1 : seq<_>) (source2 : seq<_>) = - mkSeq (fun () -> f (ie1.GetEnumerator()) (source2.GetEnumerator())) - let revamp3 f (ie1 : seq<_>) (source2 : seq<_>) (source3 : seq<_>) = - mkSeq (fun () -> f (ie1.GetEnumerator()) (source2.GetEnumerator()) (source3.GetEnumerator())) - - [] - let filter predicate source = - checkNonNull "source" source - revamp (IEnumerator.filter predicate) source - - [] - let where predicate source = filter predicate source - - [] - let map mapping source = - checkNonNull "source" source - revamp (IEnumerator.map mapping) source - - [] - let mapi mapping source = - checkNonNull "source" source - revamp (IEnumerator.mapi mapping) source - - [] - let mapi2 mapping source1 source2 = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - revamp2 (IEnumerator.mapi2 mapping) source1 source2 - - [] - let map2 mapping source1 source2 = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - revamp2 (IEnumerator.map2 mapping) source1 source2 - - [] - let map3 mapping source1 source2 source3 = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - checkNonNull "source3" source3 - revamp3 (IEnumerator.map3 mapping) source1 source2 source3 - - [] - let choose chooser source = - checkNonNull "source" source - revamp (IEnumerator.choose chooser) source - - [] - let indexed source = - checkNonNull "source" source - mapi (fun i x -> i, x) source - - [] - let zip source1 source2 = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - map2 (fun x y -> x, y) source1 source2 - - [] - let zip3 source1 source2 source3 = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - checkNonNull "source3" source3 - map2 (fun x (y,z) -> x, y, z) source1 (zip source2 source3) - - [] - let cast (source: IEnumerable) = - checkNonNull "source" source - mkSeq (fun () -> IEnumerator.cast (source.GetEnumerator())) - - [] - let tryPick chooser (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable res = None - while (Option.isNone res && e.MoveNext()) do - res <- chooser e.Current - res - - [] - let pick chooser source = - checkNonNull "source" source - match tryPick chooser source with - | None -> indexNotFound() - | Some x -> x - - [] - let tryFind predicate (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable res = None - while (Option.isNone res && e.MoveNext()) do - let c = e.Current - if predicate c then res <- Some c - res - - [] - let find predicate source = - checkNonNull "source" source - match tryFind predicate source with - | None -> indexNotFound() - | Some x -> x - - [] - let take count (source : seq<'T>) = - checkNonNull "source" source - if count < 0 then invalidArgInputMustBeNonNegative "count" count - (* Note: don't create or dispose any IEnumerable if n = 0 *) - if count = 0 then empty else +[] +type CachedSeq<'T>(cleanup,res:seq<'T>) = + interface System.IDisposable with + member x.Dispose() = cleanup() + interface System.Collections.Generic.IEnumerable<'T> with + member x.GetEnumerator() = res.GetEnumerator() + interface System.Collections.IEnumerable with + member x.GetEnumerator() = (res :> System.Collections.IEnumerable).GetEnumerator() + member obj.Clear() = cleanup() + + +[] +[] +module Seq = + + open Internal + open IEnumerator + + let mkDelayedSeq (f: unit -> IEnumerable<'T>) = mkSeq (fun () -> f().GetEnumerator()) + let mkUnfoldSeq f x = mkSeq (fun () -> IEnumerator.unfold f x) + let inline indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException(SR.GetString(SR.keyNotFoundAlt))) + + [] + let delay generator = mkDelayedSeq generator + + [] + let unfold generator state = mkUnfoldSeq generator state + + [] + let empty<'T> = (EmptyEnumerable :> seq<'T>) + + [] + let initInfinite initializer = mkSeq (fun () -> IEnumerator.upto None initializer) + + [] + let init count initializer = + if count < 0 then invalidArgInputMustBeNonNegative "count" count + mkSeq (fun () -> IEnumerator.upto (Some (count - 1)) initializer) + + [] + let iter action (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + while e.MoveNext() do + action e.Current + + [] + let item index (source : seq<'T>) = + checkNonNull "source" source + if index < 0 then invalidArgInputMustBeNonNegative "index" index + use e = source.GetEnumerator() + IEnumerator.nth index e + + [] + let tryItem index (source : seq<'T>) = + checkNonNull "source" source + if index < 0 then None else + use e = source.GetEnumerator() + IEnumerator.tryItem index e + + [] + let nth index (source : seq<'T>) = + item index source + + [] + let iteri action (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt(action) + let mutable i = 0 + while e.MoveNext() do + f.Invoke(i, e.Current) + i <- i + 1 + + [] + let exists predicate (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable state = false + while (not state && e.MoveNext()) do + state <- predicate e.Current + state + + [] + let inline contains value (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable state = false + while (not state && e.MoveNext()) do + state <- value = e.Current + state + + [] + let forall predicate (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable state = true + while (state && e.MoveNext()) do + state <- predicate e.Current + state + + [] + let iter2 action (source1 : seq<_>) (source2 : seq<_>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + use e1 = source1.GetEnumerator() + use e2 = source2.GetEnumerator() + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt action + while (e1.MoveNext() && e2.MoveNext()) do + f.Invoke(e1.Current, e2.Current) + + [] + let iteri2 action (source1 : seq<_>) (source2 : seq<_>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + use e1 = source1.GetEnumerator() + use e2 = source2.GetEnumerator() + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt action + let mutable i = 0 + while (e1.MoveNext() && e2.MoveNext()) do + f.Invoke(i, e1.Current, e2.Current) + i <- i + 1 + + // Build an IEnumerable by wrapping/transforming iterators as they get generated. + let revamp f (ie : seq<_>) = mkSeq (fun () -> f (ie.GetEnumerator())) + + let revamp2 f (ie1 : seq<_>) (source2 : seq<_>) = + mkSeq (fun () -> f (ie1.GetEnumerator()) (source2.GetEnumerator())) + + let revamp3 f (ie1 : seq<_>) (source2 : seq<_>) (source3 : seq<_>) = + mkSeq (fun () -> f (ie1.GetEnumerator()) (source2.GetEnumerator()) (source3.GetEnumerator())) + + [] + let filter predicate source = + checkNonNull "source" source + revamp (IEnumerator.filter predicate) source + + [] + let where predicate source = filter predicate source + + [] + let map mapping source = + checkNonNull "source" source + revamp (IEnumerator.map mapping) source + + [] + let mapi mapping source = + checkNonNull "source" source + revamp (IEnumerator.mapi mapping) source + + [] + let mapi2 mapping source1 source2 = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + revamp2 (IEnumerator.mapi2 mapping) source1 source2 + + [] + let map2 mapping source1 source2 = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + revamp2 (IEnumerator.map2 mapping) source1 source2 + + [] + let map3 mapping source1 source2 source3 = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + checkNonNull "source3" source3 + revamp3 (IEnumerator.map3 mapping) source1 source2 source3 + + [] + let choose chooser source = + checkNonNull "source" source + revamp (IEnumerator.choose chooser) source + + [] + let indexed source = + checkNonNull "source" source + mapi (fun i x -> i, x) source + + [] + let zip source1 source2 = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + map2 (fun x y -> x, y) source1 source2 + + [] + let zip3 source1 source2 source3 = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + checkNonNull "source3" source3 + map2 (fun x (y,z) -> x, y, z) source1 (zip source2 source3) + + [] + let cast (source: IEnumerable) = + checkNonNull "source" source + mkSeq (fun () -> IEnumerator.cast (source.GetEnumerator())) + + [] + let tryPick chooser (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable res = None + + while (Option.isNone res && e.MoveNext()) do + res <- chooser e.Current + + res + + [] + let pick chooser source = + checkNonNull "source" source + + match tryPick chooser source with + | None -> indexNotFound() + | Some x -> x + + [] + let tryFind predicate (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable res = None + + while (Option.isNone res && e.MoveNext()) do + let c = e.Current + if predicate c then res <- Some c + + res + + [] + let find predicate source = + checkNonNull "source" source + + match tryFind predicate source with + | None -> indexNotFound() + | Some x -> x + + [] + let take count (source : seq<'T>) = + checkNonNull "source" source + if count < 0 then invalidArgInputMustBeNonNegative "count" count + // Note: don't create or dispose any IEnumerable if n = 0 + if count = 0 then + empty + else seq { use e = source.GetEnumerator() for x in count .. - 1 .. 1 do if not (e.MoveNext()) then @@ -690,876 +723,841 @@ namespace Microsoft.FSharp.Collections [|SR.GetString SR.notEnoughElements; x; (if x = 1 then "element" else "elements"); count|] yield e.Current } - [] - let isEmpty (source : seq<'T>) = - checkNonNull "source" source - match source with - | :? ('T[]) as a -> a.Length = 0 - | :? ('T list) as a -> a.IsEmpty - | :? ICollection<'T> as a -> a.Count = 0 - | _ -> - use ie = source.GetEnumerator() - not (ie.MoveNext()) - - - [] - let concat sources = - checkNonNull "sources" sources - RuntimeHelpers.mkConcatSeq sources - - [] - let length (source : seq<'T>) = - checkNonNull "source" source - match source with - | :? ('T[]) as a -> a.Length - | :? ('T list) as a -> a.Length - | :? ICollection<'T> as a -> a.Count - | _ -> - use e = source.GetEnumerator() - let mutable state = 0 - while e.MoveNext() do - state <- state + 1 - state - - [] - let fold<'T,'State> folder (state:'State) (source : seq<'T>) = - checkNonNull "source" source - use e = source.GetEnumerator() - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder - let mutable state = state - while e.MoveNext() do - state <- f.Invoke(state, e.Current) - state - - [] - let fold2<'T1,'T2,'State> folder (state:'State) (source1: seq<'T1>) (source2: seq<'T2>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - - use e1 = source1.GetEnumerator() - use e2 = source2.GetEnumerator() - - let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt folder - - let mutable state = state - while e1.MoveNext() && e2.MoveNext() do - state <- f.Invoke(state, e1.Current, e2.Current) - - state - - [] - let reduce reduction (source : seq<'T>) = - checkNonNull "source" source + [] + let isEmpty (source : seq<'T>) = + checkNonNull "source" source + match source with + | :? ('T[]) as a -> a.Length = 0 + | :? ('T list) as a -> a.IsEmpty + | :? ICollection<'T> as a -> a.Count = 0 + | _ -> + use ie = source.GetEnumerator() + not (ie.MoveNext()) + + + [] + let concat sources = + checkNonNull "sources" sources + RuntimeHelpers.mkConcatSeq sources + + [] + let length (source : seq<'T>) = + checkNonNull "source" source + match source with + | :? ('T[]) as a -> a.Length + | :? ('T list) as a -> a.Length + | :? ICollection<'T> as a -> a.Count + | _ -> use e = source.GetEnumerator() - if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt reduction - let mutable state = e.Current + let mutable state = 0 while e.MoveNext() do - state <- f.Invoke(state, e.Current) + state <- state + 1 state - let fromGenerator f = mkSeq(fun () -> Generator.EnumerateFromGenerator (f())) - let toGenerator (ie : seq<_>) = Generator.GenerateFromEnumerator (ie.GetEnumerator()) - - [] - let replicate count initial = - System.Linq.Enumerable.Repeat(initial,count) - - [] - let append (source1: seq<'T>) (source2: seq<'T>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - fromGenerator(fun () -> Generator.bindG (toGenerator source1) (fun () -> toGenerator source2)) - - [] - let collect mapping source = map mapping source |> concat - - [] - let compareWith (comparer:'T -> 'T -> int) (source1 : seq<'T>) (source2: seq<'T>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - use e1 = source1.GetEnumerator() - use e2 = source2.GetEnumerator() - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt comparer - let rec go () = - let e1ok = e1.MoveNext() - let e2ok = e2.MoveNext() - let c = if e1ok = e2ok then 0 else if e1ok then 1 else -1 + [] + let fold<'T,'State> folder (state:'State) (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder + let mutable state = state + while e.MoveNext() do + state <- f.Invoke(state, e.Current) + state + + [] + let fold2<'T1,'T2,'State> folder (state:'State) (source1: seq<'T1>) (source2: seq<'T2>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + + use e1 = source1.GetEnumerator() + use e2 = source2.GetEnumerator() + + let f = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt folder + + let mutable state = state + while e1.MoveNext() && e2.MoveNext() do + state <- f.Invoke(state, e1.Current, e2.Current) + + state + + [] + let reduce reduction (source : seq<'T>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if not (e.MoveNext()) then invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt reduction + let mutable state = e.Current + while e.MoveNext() do + state <- f.Invoke(state, e.Current) + state + + let fromGenerator f = mkSeq(fun () -> Generator.EnumerateFromGenerator (f())) + let toGenerator (ie : seq<_>) = Generator.GenerateFromEnumerator (ie.GetEnumerator()) + + [] + let replicate count initial = + System.Linq.Enumerable.Repeat(initial,count) + + [] + let append (source1: seq<'T>) (source2: seq<'T>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + fromGenerator(fun () -> Generator.bindG (toGenerator source1) (fun () -> toGenerator source2)) + + [] + let collect mapping source = map mapping source |> concat + + [] + let compareWith (comparer:'T -> 'T -> int) (source1 : seq<'T>) (source2: seq<'T>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + use e1 = source1.GetEnumerator() + use e2 = source2.GetEnumerator() + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt comparer + let rec go () = + let e1ok = e1.MoveNext() + let e2ok = e2.MoveNext() + let c = if e1ok = e2ok then 0 else if e1ok then 1 else -1 + if c <> 0 then c else + if not e1ok || not e2ok then 0 + else + let c = f.Invoke(e1.Current, e2.Current) if c <> 0 then c else - if not e1ok || not e2ok then 0 - else - let c = f.Invoke(e1.Current, e2.Current) - if c <> 0 then c else - go () - go() - - [] - let ofList (source : 'T list) = - (source :> seq<'T>) - - [] - let toList (source : seq<'T>) = - checkNonNull "source" source - Microsoft.FSharp.Primitives.Basics.List.ofSeq source - - // Create a new object to ensure underlying array may not be mutated by a backdoor cast - [] - let ofArray (source : 'T array) = - checkNonNull "source" source - mkSeq (fun () -> IEnumerator.ofArray source) - - [] - let toArray (source : seq<'T>) = - checkNonNull "source" source - match source with - | :? ('T[]) as res -> (res.Clone() :?> 'T[]) - | :? ('T list) as res -> List.toArray res - | :? ICollection<'T> as res -> - // Directly create an array and copy ourselves. - // This avoids an extra copy if using ResizeArray in fallback below. - let arr = Array.zeroCreateUnchecked res.Count - res.CopyTo(arr, 0) - arr - | _ -> - let res = ResizeArray<_>(source) - res.ToArray() - - let foldArraySubRight (f:OptimizedClosures.FSharpFunc<'T,_,_>) (arr: 'T[]) start fin acc = - let mutable state = acc - for i = fin downto start do - state <- f.Invoke(arr.[i], state) - state - - [] - let foldBack<'T,'State> folder (source : seq<'T>) (state:'State) = - checkNonNull "source" source - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder - let arr = toArray source - let len = arr.Length - foldArraySubRight f arr 0 (len - 1) state - - [] - let foldBack2<'T1,'T2,'State> folder (source1 : seq<'T1>) (source2 : seq<'T2>) (state:'State) = - let zipped = zip source1 source2 - foldBack ((<||) folder) zipped state - - [] - let reduceBack reduction (source : seq<'T>) = - checkNonNull "source" source - let arr = toArray source - match arr.Length with - | 0 -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - | len -> - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt reduction - foldArraySubRight f arr 0 (len - 2) arr.[len - 1] - - [] - let singleton value = mkSeq (fun () -> IEnumerator.Singleton value) - - [] - let truncate count (source: seq<'T>) = - checkNonNull "source" source - if count <= 0 then empty else - seq { let mutable i = 0 - use ie = source.GetEnumerator() - while i < count && ie.MoveNext() do - i <- i + 1 - yield ie.Current } - - [] - let pairwise (source: seq<'T>) = - checkNonNull "source" source - seq { use ie = source.GetEnumerator() - if ie.MoveNext() then - let mutable iref = ie.Current - while ie.MoveNext() do - let j = ie.Current - yield (iref, j) - iref <- j } - - [] - let scan<'T,'State> folder (state:'State) (source : seq<'T>) = - checkNonNull "source" source - let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder - seq { let mutable zref = state - yield zref - use ie = source.GetEnumerator() + go () + go() + + [] + let ofList (source : 'T list) = + (source :> seq<'T>) + + [] + let toList (source : seq<'T>) = + checkNonNull "source" source + Microsoft.FSharp.Primitives.Basics.List.ofSeq source + + // Create a new object to ensure underlying array may not be mutated by a backdoor cast + [] + let ofArray (source : 'T array) = + checkNonNull "source" source + mkSeq (fun () -> IEnumerator.ofArray source) + + [] + let toArray (source : seq<'T>) = + checkNonNull "source" source + match source with + | :? ('T[]) as res -> (res.Clone() :?> 'T[]) + | :? ('T list) as res -> List.toArray res + | :? ICollection<'T> as res -> + // Directly create an array and copy ourselves. + // This avoids an extra copy if using ResizeArray in fallback below. + let arr = Array.zeroCreateUnchecked res.Count + res.CopyTo(arr, 0) + arr + | _ -> + let res = ResizeArray<_>(source) + res.ToArray() + + let foldArraySubRight (f:OptimizedClosures.FSharpFunc<'T,_,_>) (arr: 'T[]) start fin acc = + let mutable state = acc + for i = fin downto start do + state <- f.Invoke(arr.[i], state) + state + + [] + let foldBack<'T,'State> folder (source : seq<'T>) (state:'State) = + checkNonNull "source" source + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder + let arr = toArray source + let len = arr.Length + foldArraySubRight f arr 0 (len - 1) state + + [] + let foldBack2<'T1,'T2,'State> folder (source1 : seq<'T1>) (source2 : seq<'T2>) (state:'State) = + let zipped = zip source1 source2 + foldBack ((<||) folder) zipped state + + [] + let reduceBack reduction (source : seq<'T>) = + checkNonNull "source" source + let arr = toArray source + match arr.Length with + | 0 -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + | len -> + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt reduction + foldArraySubRight f arr 0 (len - 2) arr.[len - 1] + + [] + let singleton value = mkSeq (fun () -> IEnumerator.Singleton value) + + [] + let truncate count (source: seq<'T>) = + checkNonNull "source" source + if count <= 0 then empty else + seq { let mutable i = 0 + use ie = source.GetEnumerator() + while i < count && ie.MoveNext() do + i <- i + 1 + yield ie.Current } + + [] + let pairwise (source: seq<'T>) = + checkNonNull "source" source + seq { use ie = source.GetEnumerator() + if ie.MoveNext() then + let mutable iref = ie.Current while ie.MoveNext() do - zref <- f.Invoke(zref, ie.Current) - yield zref } - - [] - let tryFindBack predicate (source : seq<'T>) = - checkNonNull "source" source - source |> toArray |> Array.tryFindBack predicate - - [] - let findBack predicate source = - checkNonNull "source" source - source |> toArray |> Array.findBack predicate - - [] - let scanBack<'T,'State> folder (source : seq<'T>) (state:'State) = - checkNonNull "source" source - mkDelayedSeq(fun () -> - let arr = source |> toArray - let res = Array.scanSubRight folder arr 0 (arr.Length - 1) state - res :> seq<_>) - - [] - let findIndex predicate (source:seq<_>) = - checkNonNull "source" source - use ie = source.GetEnumerator() - let rec loop i = - if ie.MoveNext() then - if predicate ie.Current then - i - else loop (i + 1) - else - indexNotFound() - loop 0 - - [] - let tryFindIndex predicate (source:seq<_>) = - checkNonNull "source" source - use ie = source.GetEnumerator() - let rec loop i = - if ie.MoveNext() then - if predicate ie.Current then - Some i - else loop (i + 1) - else - None - loop 0 - - [] - let tryFindIndexBack predicate (source : seq<'T>) = - checkNonNull "source" source - source |> toArray |> Array.tryFindIndexBack predicate - - [] - let findIndexBack predicate source = - checkNonNull "source" source - source |> toArray |> Array.findIndexBack predicate - - // windowed : int -> seq<'T> -> seq<'T[]> - [] - let windowed windowSize (source: seq<_>) = - checkNonNull "source" source - if windowSize <= 0 then invalidArgFmt "windowSize" "{0}\nwindowSize = {1}" - [|SR.GetString SR.inputMustBePositive; windowSize|] - seq { - let arr = Array.zeroCreateUnchecked windowSize - let mutable r =windowSize - 1 - let mutable i = 0 - use e = source.GetEnumerator() - while e.MoveNext() do - arr.[i] <- e.Current - i <- (i + 1) % windowSize - if r = 0 then - if windowSize < 32 then - yield Array.init windowSize (fun j -> arr.[(i+j) % windowSize]) - else - let result = Array.zeroCreateUnchecked windowSize - Array.Copy(arr, i, result, 0, windowSize - i) - Array.Copy(arr, 0, result, windowSize - i, i) - yield result - else r <- (r - 1) - } - - [] - let cache (source : seq<'T>) = - checkNonNull "source" source - // Wrap a seq to ensure that it is enumerated just once and only as far as is necessary. - // - // This code is required to be thread safe. - // The necessary calls should be called at most once (include .MoveNext() = false). - // The enumerator should be disposed (and dropped) when no longer required. - //------ - // The state is (prefix,enumerator) with invariants: - // * the prefix followed by elts from the enumerator are the initial sequence. - // * the prefix contains only as many elements as the longest enumeration so far. - let prefix = ResizeArray<_>() - - // None = Unstarted. - // Some(Some e) = Started. - // Some None = Finished. - let mutable enumeratorR = None - - let oneStepTo i = - // If possible, step the enumeration to prefix length i (at most one step). - // Be speculative, since this could have already happened via another thread. - if i >= prefix.Count then // is a step still required? - // If not yet started, start it (create enumerator). - let optEnumerator = - match enumeratorR with - | None -> - let optEnumerator = Some (source.GetEnumerator()) - enumeratorR <- Some optEnumerator - optEnumerator - | Some optEnumerator -> - optEnumerator - - match optEnumerator with - | Some enumerator -> - if enumerator.MoveNext() then - prefix.Add(enumerator.Current) - else - enumerator.Dispose() // Move failed, dispose enumerator, - enumeratorR <- Some None // drop it and record finished. - | None -> () - - let result = - unfold (fun i -> - // i being the next position to be returned - // A lock is needed over the reads to prefix.Count since the list may be being resized - // NOTE: we could change to a reader/writer lock here - lock prefix (fun () -> + let j = ie.Current + yield (iref, j) + iref <- j } + + [] + let scan<'T,'State> folder (state:'State) (source : seq<'T>) = + checkNonNull "source" source + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt folder + seq { let mutable zref = state + yield zref + use ie = source.GetEnumerator() + while ie.MoveNext() do + zref <- f.Invoke(zref, ie.Current) + yield zref } + + [] + let tryFindBack predicate (source : seq<'T>) = + checkNonNull "source" source + source |> toArray |> Array.tryFindBack predicate + + [] + let findBack predicate source = + checkNonNull "source" source + source |> toArray |> Array.findBack predicate + + [] + let scanBack<'T,'State> folder (source : seq<'T>) (state:'State) = + checkNonNull "source" source + mkDelayedSeq(fun () -> + let arr = source |> toArray + let res = Array.scanSubRight folder arr 0 (arr.Length - 1) state + res :> seq<_>) + + [] + let findIndex predicate (source:seq<_>) = + checkNonNull "source" source + use ie = source.GetEnumerator() + let rec loop i = + if ie.MoveNext() then + if predicate ie.Current then + i + else loop (i + 1) + else + indexNotFound() + loop 0 + + [] + let tryFindIndex predicate (source:seq<_>) = + checkNonNull "source" source + use ie = source.GetEnumerator() + let rec loop i = + if ie.MoveNext() then + if predicate ie.Current then + Some i + else loop (i + 1) + else + None + loop 0 + + [] + let tryFindIndexBack predicate (source : seq<'T>) = + checkNonNull "source" source + source |> toArray |> Array.tryFindIndexBack predicate + + [] + let findIndexBack predicate source = + checkNonNull "source" source + source |> toArray |> Array.findIndexBack predicate + + // windowed : int -> seq<'T> -> seq<'T[]> + [] + let windowed windowSize (source: seq<_>) = + checkNonNull "source" source + if windowSize <= 0 then invalidArgFmt "windowSize" "{0}\nwindowSize = {1}" + [|SR.GetString SR.inputMustBePositive; windowSize|] + seq { + let arr = Array.zeroCreateUnchecked windowSize + let mutable r =windowSize - 1 + let mutable i = 0 + use e = source.GetEnumerator() + while e.MoveNext() do + arr.[i] <- e.Current + i <- (i + 1) % windowSize + if r = 0 then + if windowSize < 32 then + yield Array.init windowSize (fun j -> arr.[(i+j) % windowSize]) + else + let result = Array.zeroCreateUnchecked windowSize + Array.Copy(arr, i, result, 0, windowSize - i) + Array.Copy(arr, 0, result, windowSize - i, i) + yield result + else r <- (r - 1) + } + + [] + let cache (source : seq<'T>) = + checkNonNull "source" source + // Wrap a seq to ensure that it is enumerated just once and only as far as is necessary. + // + // This code is required to be thread safe. + // The necessary calls should be called at most once (include .MoveNext() = false). + // The enumerator should be disposed (and dropped) when no longer required. + //------ + // The state is (prefix,enumerator) with invariants: + // * the prefix followed by elts from the enumerator are the initial sequence. + // * the prefix contains only as many elements as the longest enumeration so far. + let prefix = ResizeArray<_>() + + // None = Unstarted. + // Some(Some e) = Started. + // Some None = Finished. + let mutable enumeratorR = None + + let oneStepTo i = + // If possible, step the enumeration to prefix length i (at most one step). + // Be speculative, since this could have already happened via another thread. + if i >= prefix.Count then // is a step still required? + // If not yet started, start it (create enumerator). + let optEnumerator = + match enumeratorR with + | None -> + let optEnumerator = Some (source.GetEnumerator()) + enumeratorR <- Some optEnumerator + optEnumerator + | Some optEnumerator -> + optEnumerator + + match optEnumerator with + | Some enumerator -> + if enumerator.MoveNext() then + prefix.Add(enumerator.Current) + else + enumerator.Dispose() // Move failed, dispose enumerator, + enumeratorR <- Some None // drop it and record finished. + | None -> () + + let result = + unfold (fun i -> + // i being the next position to be returned + // A lock is needed over the reads to prefix.Count since the list may be being resized + // NOTE: we could change to a reader/writer lock here + lock prefix (fun () -> + if i < prefix.Count then + Some (prefix.[i],i+1) + else + oneStepTo i if i < prefix.Count then Some (prefix.[i],i+1) else - oneStepTo i - if i < prefix.Count then - Some (prefix.[i],i+1) - else - None)) 0 - let cleanup() = - lock prefix (fun () -> - prefix.Clear() - match enumeratorR with - | Some (Some e) -> IEnumerator.dispose e - | _ -> () - enumeratorR <- None) - - (new CachedSeq<_>(cleanup, result) :> seq<_>) - - [] - let allPairs source1 source2 = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - let cached = cache source2 - source1 |> collect (fun x -> cached |> map (fun y -> x, y)) - - [] - [] - let readonly (source:seq<_>) = - checkNonNull "source" source - mkSeq (fun () -> source.GetEnumerator()) - - let inline groupByImpl (comparer:IEqualityComparer<'SafeKey>) ([] keyf:'T->'SafeKey) ([] getKey:'SafeKey->'Key) (seq:seq<'T>) = - checkNonNull "seq" seq - - let dict = Dictionary<_,ResizeArray<_>> comparer - - // Previously this was 1, but I think this is rather stingy, considering that we are already paying - // for at least a key, the ResizeArray reference, which includes an array reference, an Entry in the - // Dictionary, plus any empty space in the Dictionary of unfilled hash buckets. - let minimumBucketSize = 4 - - // Build the groupings - seq |> iter (fun v -> - let safeKey = keyf v - let mutable prev = Unchecked.defaultof<_> - match dict.TryGetValue (safeKey, &prev) with - | true -> prev.Add v - | false -> - let prev = ResizeArray () - dict.[safeKey] <- prev - prev.Add v) - - // Trim the size of each result group, don't trim very small buckets, as excessive work, and garbage for - // minimal gain - dict |> iter (fun group -> if group.Value.Count > minimumBucketSize then group.Value.TrimExcess()) - - // Return the sequence-of-sequences. Don't reveal the - // internal collections: just reveal them as sequences - dict |> map (fun group -> (getKey group.Key, readonly group.Value)) - - // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let groupByValueType (keyf:'T->'Key) (seq:seq<'T>) = seq |> groupByImpl HashIdentity.Structural<'Key> keyf id - - // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let groupByRefType (keyf:'T->'Key) (seq:seq<'T>) = seq |> groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) - - [] - let groupBy (projection:'T->'Key) (source:seq<'T>) = - if typeof<'Key>.IsValueType - then mkDelayedSeq (fun () -> groupByValueType projection source) - else mkDelayedSeq (fun () -> groupByRefType projection source) - - [] - let transpose (source: seq<#seq<'T>>) = - checkNonNull "source" source - source - |> collect indexed - |> groupBy fst - |> map (snd >> (map snd)) - - [] - let distinct source = - checkNonNull "source" source - seq { let hashSet = HashSet<'T>(HashIdentity.Structural<'T>) - for v in source do - if hashSet.Add v then - yield v } - - [] - let distinctBy projection source = - checkNonNull "source" source - seq { let hashSet = HashSet<_>(HashIdentity.Structural<_>) - for v in source do - if hashSet.Add(projection v) then - yield v } - - [] - let sortBy projection source = - checkNonNull "source" source - mkDelayedSeq (fun () -> - let array = source |> toArray - Array.stableSortInPlaceBy projection array - array :> seq<_>) - - [] - let sort source = - checkNonNull "source" source - mkDelayedSeq (fun () -> - let array = source |> toArray - Array.stableSortInPlace array - array :> seq<_>) - - [] - let sortWith comparer source = - checkNonNull "source" source - mkDelayedSeq (fun () -> - let array = source |> toArray - Array.stableSortInPlaceWith comparer array - array :> seq<_>) - - [] - let inline sortByDescending projection source = - checkNonNull "source" source - let inline compareDescending a b = compare (projection b) (projection a) - sortWith compareDescending source - - [] - let inline sortDescending source = - checkNonNull "source" source - let inline compareDescending a b = compare b a - sortWith compareDescending source - - let inline countByImpl (comparer:IEqualityComparer<'SafeKey>) ([] keyf:'T->'SafeKey) ([] getKey:'SafeKey->'Key) (source:seq<'T>) = - checkNonNull "source" source - - let dict = Dictionary comparer - - // Build the groupings - source |> iter (fun v -> - let safeKey = keyf v - let mutable prev = Unchecked.defaultof<_> - if dict.TryGetValue(safeKey, &prev) - then dict.[safeKey] <- prev + 1 - else dict.[safeKey] <- 1) - - dict |> map (fun group -> (getKey group.Key, group.Value)) - - // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance - let countByValueType (keyf:'T->'Key) (seq:seq<'T>) = seq |> countByImpl HashIdentity.Structural<'Key> keyf id - - // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation - let countByRefType (keyf:'T->'Key) (seq:seq<'T>) = seq |> countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) - - [] - let countBy (projection:'T->'Key) (source:seq<'T>) = - checkNonNull "source" source - - if typeof<'Key>.IsValueType - then mkDelayedSeq (fun () -> countByValueType projection source) - else mkDelayedSeq (fun () -> countByRefType projection source) - - [] - let inline sum (source: seq< ^a>) : ^a = - use e = source.GetEnumerator() - let mutable acc = LanguagePrimitives.GenericZero< ^a> - while e.MoveNext() do - acc <- Checked.(+) acc e.Current - acc + None)) 0 + let cleanup() = + lock prefix (fun () -> + prefix.Clear() + match enumeratorR with + | Some (Some e) -> IEnumerator.dispose e + | _ -> () + enumeratorR <- None) + + (new CachedSeq<_>(cleanup, result) :> seq<_>) + + [] + let allPairs source1 source2 = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + let cached = cache source2 + source1 |> collect (fun x -> cached |> map (fun y -> x, y)) + + [] + [] + let readonly (source:seq<_>) = + checkNonNull "source" source + mkSeq (fun () -> source.GetEnumerator()) + + let inline groupByImpl (comparer:IEqualityComparer<'SafeKey>) ([] keyf:'T->'SafeKey) ([] getKey:'SafeKey->'Key) (seq:seq<'T>) = + checkNonNull "seq" seq + + let dict = Dictionary<_,ResizeArray<_>> comparer + + // Previously this was 1, but I think this is rather stingy, considering that we are already paying + // for at least a key, the ResizeArray reference, which includes an array reference, an Entry in the + // Dictionary, plus any empty space in the Dictionary of unfilled hash buckets. + let minimumBucketSize = 4 + + // Build the groupings + seq |> iter (fun v -> + let safeKey = keyf v + let mutable prev = Unchecked.defaultof<_> + match dict.TryGetValue (safeKey, &prev) with + | true -> prev.Add v + | false -> + let prev = ResizeArray () + dict.[safeKey] <- prev + prev.Add v) + + // Trim the size of each result group, don't trim very small buckets, as excessive work, and garbage for + // minimal gain + dict |> iter (fun group -> if group.Value.Count > minimumBucketSize then group.Value.TrimExcess()) + + // Return the sequence-of-sequences. Don't reveal the + // internal collections: just reveal them as sequences + dict |> map (fun group -> (getKey group.Key, readonly group.Value)) + + // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance + let groupByValueType (keyf:'T->'Key) (seq:seq<'T>) = seq |> groupByImpl HashIdentity.Structural<'Key> keyf id + + // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation + let groupByRefType (keyf:'T->'Key) (seq:seq<'T>) = seq |> groupByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) + + [] + let groupBy (projection:'T->'Key) (source:seq<'T>) = + if typeof<'Key>.IsValueType + then mkDelayedSeq (fun () -> groupByValueType projection source) + else mkDelayedSeq (fun () -> groupByRefType projection source) + + [] + let transpose (source: seq<#seq<'T>>) = + checkNonNull "source" source + source + |> collect indexed + |> groupBy fst + |> map (snd >> (map snd)) + + [] + let distinct source = + checkNonNull "source" source + seq { let hashSet = HashSet<'T>(HashIdentity.Structural<'T>) + for v in source do + if hashSet.Add v then + yield v } + + [] + let distinctBy projection source = + checkNonNull "source" source + seq { let hashSet = HashSet<_>(HashIdentity.Structural<_>) + for v in source do + if hashSet.Add(projection v) then + yield v } + + [] + let sortBy projection source = + checkNonNull "source" source + mkDelayedSeq (fun () -> + let array = source |> toArray + Array.stableSortInPlaceBy projection array + array :> seq<_>) - [] - let inline sumBy ([] projection : 'T -> ^U) (source: seq<'T>) : ^U = - use e = source.GetEnumerator() - let mutable acc = LanguagePrimitives.GenericZero< ^U> - while e.MoveNext() do - acc <- Checked.(+) acc (projection e.Current) - acc + [] + let sort source = + checkNonNull "source" source + mkDelayedSeq (fun () -> + let array = source |> toArray + Array.stableSortInPlace array + array :> seq<_>) - [] - let inline average (source: seq< ^a>) : ^a = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable acc = LanguagePrimitives.GenericZero< ^a> - let mutable count = 0 - while e.MoveNext() do - acc <- Checked.(+) acc e.Current - count <- count + 1 - if count = 0 then - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - LanguagePrimitives.DivideByInt< ^a> acc count - - [] - let inline averageBy ([] projection : 'T -> ^U) (source: seq<'T>) : ^U = - checkNonNull "source" source - use e = source.GetEnumerator() - let mutable acc = LanguagePrimitives.GenericZero< ^U> - let mutable count = 0 - while e.MoveNext() do - acc <- Checked.(+) acc (projection e.Current) - count <- count + 1 - if count = 0 then - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - LanguagePrimitives.DivideByInt< ^U> acc count - - [] - let inline min (source: seq<_>) = - checkNonNull "source" source - use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - let mutable acc = e.Current - while e.MoveNext() do - let curr = e.Current - if curr < acc then - acc <- curr - acc - - [] - let inline minBy (projection : 'T -> 'U) (source: seq<'T>) : 'T = - checkNonNull "source" source - use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - let first = e.Current - let mutable acc = projection first - let mutable accv = first - while e.MoveNext() do - let currv = e.Current - let curr = projection currv - if curr < acc then - acc <- curr - accv <- currv - accv - -(* - [] - let inline minValBy (f : 'T -> 'U) (source: seq<'T>) : 'U = - checkNonNull "source" source - use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" InputSequenceEmptyString - let first = e.Current - let mutable acc = f first - while e.MoveNext() do - let currv = e.Current - let curr = f currv - if curr < acc then - acc <- curr - acc - -*) - [] - let inline max (source: seq<_>) = - checkNonNull "source" source - use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - let mutable acc = e.Current - while e.MoveNext() do - let curr = e.Current - if curr > acc then - acc <- curr - acc - - [] - let inline maxBy (projection : 'T -> 'U) (source: seq<'T>) : 'T = - checkNonNull "source" source - use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - let first = e.Current - let mutable acc = projection first - let mutable accv = first - while e.MoveNext() do - let currv = e.Current - let curr = projection currv - if curr > acc then - acc <- curr - accv <- currv - accv - - -(* - [] - let inline maxValBy (f : 'T -> 'U) (source: seq<'T>) : 'U = - checkNonNull "source" source - use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" InputSequenceEmptyString - let first = e.Current - let mutable acc = f first - while e.MoveNext() do - let currv = e.Current - let curr = f currv - if curr > acc then - acc <- curr - acc - -*) - [] - let takeWhile predicate (source: seq<_>) = - checkNonNull "source" source - seq { use e = source.GetEnumerator() - let mutable latest = Unchecked.defaultof<_> - while e.MoveNext() && (latest <- e.Current; predicate latest) do + [] + let sortWith comparer source = + checkNonNull "source" source + mkDelayedSeq (fun () -> + let array = source |> toArray + Array.stableSortInPlaceWith comparer array + array :> seq<_>) + + [] + let inline sortByDescending projection source = + checkNonNull "source" source + let inline compareDescending a b = compare (projection b) (projection a) + sortWith compareDescending source + + [] + let inline sortDescending source = + checkNonNull "source" source + let inline compareDescending a b = compare b a + sortWith compareDescending source + + let inline countByImpl (comparer:IEqualityComparer<'SafeKey>) ([] keyf:'T->'SafeKey) ([] getKey:'SafeKey->'Key) (source:seq<'T>) = + checkNonNull "source" source + + let dict = Dictionary comparer + + // Build the groupings + source |> iter (fun v -> + let safeKey = keyf v + let mutable prev = Unchecked.defaultof<_> + if dict.TryGetValue(safeKey, &prev) + then dict.[safeKey] <- prev + 1 + else dict.[safeKey] <- 1) + + dict |> map (fun group -> (getKey group.Key, group.Value)) + + // We avoid wrapping a StructBox, because under 64 JIT we get some "hard" tailcalls which affect performance + let countByValueType (keyf:'T->'Key) (seq:seq<'T>) = seq |> countByImpl HashIdentity.Structural<'Key> keyf id + + // Wrap a StructBox around all keys in case the key type is itself a type using null as a representation + let countByRefType (keyf:'T->'Key) (seq:seq<'T>) = seq |> countByImpl RuntimeHelpers.StructBox<'Key>.Comparer (fun t -> RuntimeHelpers.StructBox (keyf t)) (fun sb -> sb.Value) + + [] + let countBy (projection:'T->'Key) (source:seq<'T>) = + checkNonNull "source" source + + if typeof<'Key>.IsValueType + then mkDelayedSeq (fun () -> countByValueType projection source) + else mkDelayedSeq (fun () -> countByRefType projection source) + + [] + let inline sum (source: seq< ^a>) : ^a = + use e = source.GetEnumerator() + let mutable acc = LanguagePrimitives.GenericZero< ^a> + while e.MoveNext() do + acc <- Checked.(+) acc e.Current + acc + + [] + let inline sumBy ([] projection : 'T -> ^U) (source: seq<'T>) : ^U = + use e = source.GetEnumerator() + let mutable acc = LanguagePrimitives.GenericZero< ^U> + while e.MoveNext() do + acc <- Checked.(+) acc (projection e.Current) + acc + + [] + let inline average (source: seq< ^a>) : ^a = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable acc = LanguagePrimitives.GenericZero< ^a> + let mutable count = 0 + while e.MoveNext() do + acc <- Checked.(+) acc e.Current + count <- count + 1 + if count = 0 then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + LanguagePrimitives.DivideByInt< ^a> acc count + + [] + let inline averageBy ([] projection : 'T -> ^U) (source: seq<'T>) : ^U = + checkNonNull "source" source + use e = source.GetEnumerator() + let mutable acc = LanguagePrimitives.GenericZero< ^U> + let mutable count = 0 + while e.MoveNext() do + acc <- Checked.(+) acc (projection e.Current) + count <- count + 1 + if count = 0 then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + LanguagePrimitives.DivideByInt< ^U> acc count + + [] + let inline min (source: seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if not (e.MoveNext()) then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let mutable acc = e.Current + while e.MoveNext() do + let curr = e.Current + if curr < acc then + acc <- curr + acc + + [] + let inline minBy (projection : 'T -> 'U) (source: seq<'T>) : 'T = + checkNonNull "source" source + use e = source.GetEnumerator() + if not (e.MoveNext()) then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let first = e.Current + let mutable acc = projection first + let mutable accv = first + while e.MoveNext() do + let currv = e.Current + let curr = projection currv + if curr < acc then + acc <- curr + accv <- currv + accv + + [] + let inline max (source: seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if not (e.MoveNext()) then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let mutable acc = e.Current + while e.MoveNext() do + let curr = e.Current + if curr > acc then + acc <- curr + acc + + [] + let inline maxBy (projection : 'T -> 'U) (source: seq<'T>) : 'T = + checkNonNull "source" source + use e = source.GetEnumerator() + if not (e.MoveNext()) then + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + let first = e.Current + let mutable acc = projection first + let mutable accv = first + while e.MoveNext() do + let currv = e.Current + let curr = projection currv + if curr > acc then + acc <- curr + accv <- currv + accv + + [] + let takeWhile predicate (source: seq<_>) = + checkNonNull "source" source + seq { use e = source.GetEnumerator() + let mutable latest = Unchecked.defaultof<_> + while e.MoveNext() && (latest <- e.Current; predicate latest) do + yield latest } + + [] + let skip count (source: seq<_>) = + checkNonNull "source" source + seq { use e = source.GetEnumerator() + for x in 1 .. count do + if not (e.MoveNext()) then + invalidOpFmt "tried to skip {0} {1} past the end of the seq" + [|SR.GetString SR.notEnoughElements; x; (if x=1 then "element" else "elements")|] + while e.MoveNext() do + yield e.Current } + + [] + let skipWhile predicate (source: seq<_>) = + checkNonNull "source" source + seq { use e = source.GetEnumerator() + let mutable latest = Unchecked.defaultof<_> + let mutable ok = false + while e.MoveNext() do + if (latest <- e.Current; (ok || not (predicate latest))) then + ok <- true yield latest } - [] - let skip count (source: seq<_>) = - checkNonNull "source" source - seq { use e = source.GetEnumerator() - for x in 1 .. count do - if not (e.MoveNext()) then - invalidOpFmt "tried to skip {0} {1} past the end of the seq" - [|SR.GetString SR.notEnoughElements; x; (if x=1 then "element" else "elements")|] - while e.MoveNext() do - yield e.Current } - - [] - let skipWhile predicate (source: seq<_>) = - checkNonNull "source" source - seq { use e = source.GetEnumerator() - let mutable latest = Unchecked.defaultof<_> - let mutable ok = false - while e.MoveNext() do - if (latest <- e.Current; (ok || not (predicate latest))) then - ok <- true - yield latest } - - [] - let forall2 predicate (source1: seq<_>) (source2: seq<_>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - use e1 = source1.GetEnumerator() - use e2 = source2.GetEnumerator() - let p = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate - let mutable ok = true - while (ok && e1.MoveNext() && e2.MoveNext()) do - ok <- p.Invoke(e1.Current, e2.Current) - ok - - [] - let exists2 predicate (source1: seq<_>) (source2: seq<_>) = - checkNonNull "source1" source1 - checkNonNull "source2" source2 - use e1 = source1.GetEnumerator() - use e2 = source2.GetEnumerator() - let p = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate - let mutable ok = false - while (not ok && e1.MoveNext() && e2.MoveNext()) do - ok <- p.Invoke(e1.Current, e2.Current) - ok - - [] - let head (source : seq<_>) = - checkNonNull "source" source - use e = source.GetEnumerator() - if (e.MoveNext()) then e.Current - else invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - - [] - let tryHead (source : seq<_>) = - checkNonNull "source" source - use e = source.GetEnumerator() - if (e.MoveNext()) then Some e.Current - else None - - [] - let tail (source: seq<'T>) = - checkNonNull "source" source - seq { use e = source.GetEnumerator() - if not (e.MoveNext()) then - invalidArg "source" (SR.GetString(SR.notEnoughElements)) - while e.MoveNext() do - yield e.Current } - - [] - let last (source : seq<_>) = - checkNonNull "source" source - match Microsoft.FSharp.Primitives.Basics.Seq.tryLastV source with - | ValueSome x -> x - | ValueNone -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + [] + let forall2 predicate (source1: seq<_>) (source2: seq<_>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + use e1 = source1.GetEnumerator() + use e2 = source2.GetEnumerator() + let p = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate + let mutable ok = true + while (ok && e1.MoveNext() && e2.MoveNext()) do + ok <- p.Invoke(e1.Current, e2.Current) + ok + + [] + let exists2 predicate (source1: seq<_>) (source2: seq<_>) = + checkNonNull "source1" source1 + checkNonNull "source2" source2 + use e1 = source1.GetEnumerator() + use e2 = source2.GetEnumerator() + let p = OptimizedClosures.FSharpFunc<_,_,_>.Adapt predicate + let mutable ok = false + while (not ok && e1.MoveNext() && e2.MoveNext()) do + ok <- p.Invoke(e1.Current, e2.Current) + ok + + [] + let head (source : seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if (e.MoveNext()) then e.Current + else invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + + [] + let tryHead (source : seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if (e.MoveNext()) then Some e.Current + else None + + [] + let tail (source: seq<'T>) = + checkNonNull "source" source + seq { use e = source.GetEnumerator() + if not (e.MoveNext()) then + invalidArg "source" (SR.GetString(SR.notEnoughElements)) + while e.MoveNext() do + yield e.Current } + + [] + let last (source : seq<_>) = + checkNonNull "source" source + match Microsoft.FSharp.Primitives.Basics.Seq.tryLastV source with + | ValueSome x -> x + | ValueNone -> invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + + [] + let tryLast (source : seq<_>) = + checkNonNull "source" source + match Microsoft.FSharp.Primitives.Basics.Seq.tryLastV source with + | ValueSome x -> Some x + | ValueNone -> None - [] - let tryLast (source : seq<_>) = - checkNonNull "source" source - match Microsoft.FSharp.Primitives.Basics.Seq.tryLastV source with - | ValueSome x -> Some x - | ValueNone -> None - - [] - let exactlyOne (source : seq<_>) = - checkNonNull "source" source - use e = source.GetEnumerator() + [] + let exactlyOne (source : seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if e.MoveNext() then + let v = e.Current if e.MoveNext() then - let v = e.Current - if e.MoveNext() then - invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) - else - v + invalidArg "source" (SR.GetString(SR.inputSequenceTooLong)) else - invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString - - [] - let tryExactlyOne (source : seq<_>) = - checkNonNull "source" source - use e = source.GetEnumerator() + v + else + invalidArg "source" LanguagePrimitives.ErrorStrings.InputSequenceEmptyString + + [] + let tryExactlyOne (source : seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + if e.MoveNext() then + let v = e.Current if e.MoveNext() then - let v = e.Current - if e.MoveNext() then - None - else - Some v - else None - - [] - let rev source = - checkNonNull "source" source - mkDelayedSeq (fun () -> - let array = source |> toArray - Array.Reverse array - array :> seq<_>) - - [] - let permute indexMap (source : seq<_>) = - checkNonNull "source" source - mkDelayedSeq (fun () -> - source |> toArray |> Array.permute indexMap :> seq<_>) - - [] - let mapFold<'T,'State,'Result> (mapping: 'State -> 'T -> 'Result * 'State) state source = - checkNonNull "source" source - let arr,state = source |> toArray |> Array.mapFold mapping state - readonly arr, state - - [] - let mapFoldBack<'T,'State,'Result> (mapping: 'T -> 'State -> 'Result * 'State) source state = - checkNonNull "source" source + else + Some v + else + None + + [] + let rev source = + checkNonNull "source" source + mkDelayedSeq (fun () -> let array = source |> toArray - let arr,state = Array.mapFoldBack mapping array state - readonly arr, state - - [] - let except (itemsToExclude: seq<'T>) (source: seq<'T>) = - checkNonNull "itemsToExclude" itemsToExclude - checkNonNull "source" source - - seq { - use e = source.GetEnumerator() - if e.MoveNext() then - let cached = HashSet(itemsToExclude, HashIdentity.Structural) + Array.Reverse array + array :> seq<_>) + + [] + let permute indexMap (source : seq<_>) = + checkNonNull "source" source + mkDelayedSeq (fun () -> + source |> toArray |> Array.permute indexMap :> seq<_>) + + [] + let mapFold<'T,'State,'Result> (mapping: 'State -> 'T -> 'Result * 'State) state source = + checkNonNull "source" source + let arr,state = source |> toArray |> Array.mapFold mapping state + readonly arr, state + + [] + let mapFoldBack<'T,'State,'Result> (mapping: 'T -> 'State -> 'Result * 'State) source state = + checkNonNull "source" source + let array = source |> toArray + let arr,state = Array.mapFoldBack mapping array state + readonly arr, state + + [] + let except (itemsToExclude: seq<'T>) (source: seq<'T>) = + checkNonNull "itemsToExclude" itemsToExclude + checkNonNull "source" source + + seq { + use e = source.GetEnumerator() + if e.MoveNext() then + let cached = HashSet(itemsToExclude, HashIdentity.Structural) + let next = e.Current + if cached.Add next then yield next + while e.MoveNext() do let next = e.Current - if cached.Add next then yield next - while e.MoveNext() do - let next = e.Current - if cached.Add next then yield next } - - [] - let chunkBySize chunkSize (source : seq<_>) = - checkNonNull "source" source - if chunkSize <= 0 then invalidArgFmt "chunkSize" "{0}\nchunkSize = {1}" - [|SR.GetString SR.inputMustBePositive; chunkSize|] - seq { use e = source.GetEnumerator() - let nextChunk() = - let res = Array.zeroCreateUnchecked chunkSize - res.[0] <- e.Current - let mutable i = 1 - while i < chunkSize && e.MoveNext() do - res.[i] <- e.Current - i <- i + 1 - if i = chunkSize then - res - else - res |> Array.subUnchecked 0 i - while e.MoveNext() do - yield nextChunk() } - - [] - let splitInto count source = - checkNonNull "source" source - if count <= 0 then invalidArgFmt "count" "{0}\ncount = {1}" - [|SR.GetString SR.inputMustBePositive; count|] - mkDelayedSeq (fun () -> - source |> toArray |> Array.splitInto count :> seq<_>) - - [] - let removeAt (index: int) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" - seq { - let mutable i = 0 - for item in source do - if i <> index then - yield item - i <- i + 1 - if i <= index then invalidArg "index" "index must be within bounds of the array" - } - - [] - let removeManyAt (index: int) (count: int) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" - seq { - let mutable i = 0 - for item in source do - if i < index || i >= index + count then - yield item - i <- i + 1 - if i <= index then invalidArg "index" "index must be within bounds of the array" - } - - [] - let updateAt (index: int) (value: 'T) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" - seq { - let mutable i = 0 - for item in source do - if i <> index then - yield item - else yield value - i <- i + 1 - if i <= index then invalidArg "index" "index must be within bounds of the array" - } - - [] - let insertAt (index: int) (value: 'T) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" - seq { - let mutable i = 0 - for item in source do - if i = index then - yield value + if cached.Add next then yield next } + + [] + let chunkBySize chunkSize (source : seq<_>) = + checkNonNull "source" source + if chunkSize <= 0 then invalidArgFmt "chunkSize" "{0}\nchunkSize = {1}" + [|SR.GetString SR.inputMustBePositive; chunkSize|] + seq { use e = source.GetEnumerator() + let nextChunk() = + let res = Array.zeroCreateUnchecked chunkSize + res.[0] <- e.Current + let mutable i = 1 + while i < chunkSize && e.MoveNext() do + res.[i] <- e.Current + i <- i + 1 + if i = chunkSize then + res + else + res |> Array.subUnchecked 0 i + while e.MoveNext() do + yield nextChunk() } + + [] + let splitInto count source = + checkNonNull "source" source + if count <= 0 then invalidArgFmt "count" "{0}\ncount = {1}" + [|SR.GetString SR.inputMustBePositive; count|] + mkDelayedSeq (fun () -> + source |> toArray |> Array.splitInto count :> seq<_>) + + [] + let removeAt (index: int) (source: seq<'T>) : seq<'T> = + if index < 0 then invalidArg "index" "index must be within bounds of the array" + seq { + let mutable i = 0 + for item in source do + if i <> index then yield item - i <- i + 1 - if i = index then yield value - if i < index then invalidArg "index" "index must be within bounds of the array" - } - - [] - let insertManyAt (index: int) (values: seq<'T>) (source: seq<'T>) : seq<'T> = - if index < 0 then invalidArg "index" "index must be within bounds of the array" - seq { - let mutable i = 0 - for item in source do - if i = index then yield! values - yield item - i <- i + 1 - if i = index then yield! values // support inserting at the end - if i < index then invalidArg "index" "index must be within bounds of the array" - } \ No newline at end of file + i <- i + 1 + if i <= index then invalidArg "index" "index must be within bounds of the array" + } + + [] + let removeManyAt (index: int) (count: int) (source: seq<'T>) : seq<'T> = + if index < 0 then invalidArg "index" "index must be within bounds of the array" + seq { + let mutable i = 0 + for item in source do + if i < index || i >= index + count then + yield item + i <- i + 1 + if i <= index then invalidArg "index" "index must be within bounds of the array" + } + + [] + let updateAt (index: int) (value: 'T) (source: seq<'T>) : seq<'T> = + if index < 0 then invalidArg "index" "index must be within bounds of the array" + seq { + let mutable i = 0 + for item in source do + if i <> index then + yield item + else yield value + i <- i + 1 + if i <= index then invalidArg "index" "index must be within bounds of the array" + } + + [] + let insertAt (index: int) (value: 'T) (source: seq<'T>) : seq<'T> = + if index < 0 then invalidArg "index" "index must be within bounds of the array" + seq { + let mutable i = 0 + for item in source do + if i = index then + yield value + yield item + i <- i + 1 + if i = index then yield value + if i < index then invalidArg "index" "index must be within bounds of the array" + } + + [] + let insertManyAt (index: int) (values: seq<'T>) (source: seq<'T>) : seq<'T> = + if index < 0 then invalidArg "index" "index must be within bounds of the array" + seq { + let mutable i = 0 + for item in source do + if i = index then yield! values + yield item + i <- i + 1 + if i = index then yield! values // support inserting at the end + if i < index then invalidArg "index" "index must be within bounds of the array" + } \ No newline at end of file diff --git a/src/FSharp.Core/seqcore.fs b/src/FSharp.Core/seqcore.fs index b7e45a0ec1ebdc8354564b09decf11c147da80da..6a2e81061cc539475687e540cf4fb1b3b7de90e5 100644 --- a/src/FSharp.Core/seqcore.fs +++ b/src/FSharp.Core/seqcore.fs @@ -1,467 +1,546 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. namespace Microsoft.FSharp.Collections - #nowarn "52" // The value has been copied to ensure the original is not mutated by this operation - - open System - open System.Diagnostics - open System.Collections - open System.Collections.Generic - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Control - open Microsoft.FSharp.Collections - - module internal IEnumerator = - - let noReset() = raise (new System.NotSupportedException(SR.GetString(SR.resetNotSupported))) - let notStarted() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) - let check started = if not started then notStarted() - let dispose (r : System.IDisposable) = r.Dispose() - - let cast (e : IEnumerator) : IEnumerator<'T> = - { new IEnumerator<'T> with - member _.Current = unbox<'T> e.Current - - interface IEnumerator with - member _.Current = unbox<'T> e.Current :> obj - member _.MoveNext() = e.MoveNext() - member _.Reset() = noReset() - - interface System.IDisposable with - member _.Dispose() = - match e with - | :? System.IDisposable as e -> e.Dispose() - | _ -> () } - - /// A concrete implementation of an enumerator that returns no values - [] - type EmptyEnumerator<'T>() = - let mutable started = false - interface IEnumerator<'T> with - member _.Current = - check started - (alreadyFinished() : 'T) - - interface System.Collections.IEnumerator with - member _.Current = - check started - (alreadyFinished() : obj) - - member _.MoveNext() = - if not started then started <- true - false - - member _.Reset() = noReset() - - interface System.IDisposable with - member _.Dispose() = () - - let Empty<'T> () = (new EmptyEnumerator<'T>() :> IEnumerator<'T>) - - [] - type EmptyEnumerable<'T> = - - | EmptyEnumerable - - interface IEnumerable<'T> with - member _.GetEnumerator() = Empty<'T>() - - interface IEnumerable with - member _.GetEnumerator() = (Empty<'T>() :> IEnumerator) - - type GeneratedEnumerable<'T, 'State>(openf: unit -> 'State, compute: 'State -> 'T option, closef: 'State -> unit) = - let mutable started = false - let mutable curr = None - let state = ref (Some (openf ())) - let getCurr() : 'T = + +#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation + +open System +open System.Diagnostics +open System.Collections +open System.Collections.Generic +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections + +module internal IEnumerator = + + let noReset() = raise (new System.NotSupportedException(SR.GetString(SR.resetNotSupported))) + let notStarted() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) + let alreadyFinished() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + let check started = if not started then notStarted() + let dispose (r : System.IDisposable) = r.Dispose() + + let cast (e : IEnumerator) : IEnumerator<'T> = + { new IEnumerator<'T> with + member _.Current = unbox<'T> e.Current + + interface IEnumerator with + member _.Current = unbox<'T> e.Current :> obj + member _.MoveNext() = e.MoveNext() + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = + match e with + | :? System.IDisposable as e -> e.Dispose() + | _ -> () } + + /// A concrete implementation of an enumerator that returns no values + [] + type EmptyEnumerator<'T>() = + let mutable started = false + interface IEnumerator<'T> with + member _.Current = + check started + (alreadyFinished() : 'T) + + interface System.Collections.IEnumerator with + member _.Current = check started - match curr with - | None -> alreadyFinished() - | Some x -> x - - let readAndClear () = - lock state (fun () -> - match state.Value with - | None -> None - | Some _ as res -> - state.Value <- None - res) - - let start() = - if not started then - started <- true - - let dispose() = - readAndClear() |> Option.iter closef - - let finish() = - try dispose() - finally curr <- None - - interface IEnumerator<'T> with - member _.Current = getCurr() - - interface IEnumerator with - member _.Current = box (getCurr()) - member _.MoveNext() = - start() - match state.Value with - | None -> false // we started, then reached the end, then got another MoveNext - | Some s -> - match (try compute s with e -> finish(); reraise()) with - | None -> finish(); false - | Some _ as x -> - curr <- x - true - - member _.Reset() = noReset() - - interface System.IDisposable with - member _.Dispose() = dispose() - - [] - type Singleton<'T>(v:'T) = - let mutable started = false - - interface IEnumerator<'T> with - member _.Current = v - - interface IEnumerator with - member _.Current = box v - member _.MoveNext() = if started then false else (started <- true; true) - member _.Reset() = noReset() - - interface System.IDisposable with - member _.Dispose() = () - - let Singleton x = (new Singleton<'T>(x) :> IEnumerator<'T>) - - let EnumerateThenFinally f (e : IEnumerator<'T>) = - { new IEnumerator<'T> with - member _.Current = e.Current - - interface IEnumerator with - member _.Current = (e :> IEnumerator).Current - member _.MoveNext() = e.MoveNext() - member _.Reset() = noReset() - - interface System.IDisposable with - member _.Dispose() = - try - e.Dispose() - finally - f() - } - - let inline checkNonNull argName arg = - if isNull arg then - nullArg argName - - let mkSeq f = - { new IEnumerable<'U> with - member _.GetEnumerator() = f() - - interface IEnumerable with - member _.GetEnumerator() = (f() :> IEnumerator) } + (alreadyFinished() : obj) + + member _.MoveNext() = + if not started then started <- true + false + + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = () + + let Empty<'T> () = (new EmptyEnumerator<'T>() :> IEnumerator<'T>) + + [] + type EmptyEnumerable<'T> = + + | EmptyEnumerable + + interface IEnumerable<'T> with + member _.GetEnumerator() = Empty<'T>() + + interface IEnumerable with + member _.GetEnumerator() = (Empty<'T>() :> IEnumerator) + + type GeneratedEnumerable<'T, 'State>(openf: unit -> 'State, compute: 'State -> 'T option, closef: 'State -> unit) = + let mutable started = false + let mutable curr = None + let state = ref (Some (openf ())) + let getCurr() : 'T = + check started + match curr with + | None -> alreadyFinished() + | Some x -> x + + let readAndClear () = + lock state (fun () -> + match state.Value with + | None -> None + | Some _ as res -> + state.Value <- None + res) + + let start() = + if not started then + started <- true + + let dispose() = + readAndClear() |> Option.iter closef + + let finish() = + try dispose() + finally curr <- None + + interface IEnumerator<'T> with + member _.Current = getCurr() + + interface IEnumerator with + member _.Current = box (getCurr()) + member _.MoveNext() = + start() + match state.Value with + | None -> false // we started, then reached the end, then got another MoveNext + | Some s -> + match (try compute s with e -> finish(); reraise()) with + | None -> finish(); false + | Some _ as x -> + curr <- x + true + + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = dispose() + + [] + type Singleton<'T>(v:'T) = + let mutable started = false + + interface IEnumerator<'T> with + member _.Current = v + + interface IEnumerator with + member _.Current = box v + member _.MoveNext() = if started then false else (started <- true; true) + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = () + + let Singleton x = (new Singleton<'T>(x) :> IEnumerator<'T>) + + let EnumerateThenFinally f (e : IEnumerator<'T>) = + { new IEnumerator<'T> with + member _.Current = e.Current + + interface IEnumerator with + member _.Current = (e :> IEnumerator).Current + member _.MoveNext() = e.MoveNext() + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = + try + e.Dispose() + finally + f() + } + + let inline checkNonNull argName arg = + if isNull arg then + nullArg argName + + let mkSeq f = + { new IEnumerable<'U> with + member _.GetEnumerator() = f() + + interface IEnumerable with + member _.GetEnumerator() = (f() :> IEnumerator) } namespace Microsoft.FSharp.Core.CompilerServices - open System - open System.Diagnostics - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Control - open Microsoft.FSharp.Collections - open Microsoft.FSharp.Collections.IEnumerator - open Microsoft.FSharp.Primitives.Basics - open System.Collections - open System.Collections.Generic - open System.Runtime.CompilerServices - - module RuntimeHelpers = - - [] - type internal StructBox<'T when 'T:equality>(value:'T) = - member x.Value = value - static member Comparer = - let gcomparer = HashIdentity.Structural<'T> - { new IEqualityComparer> with - member _.GetHashCode(v) = gcomparer.GetHashCode(v.Value) - member _.Equals(v1,v2) = gcomparer.Equals(v1.Value,v2.Value) } - - let Generate openf compute closef = - mkSeq (fun () -> new IEnumerator.GeneratedEnumerable<_,_>(openf, compute, closef) :> IEnumerator<'T>) - - let GenerateUsing (openf : unit -> ('U :> System.IDisposable)) compute = - Generate openf compute (fun (s:'U) -> s.Dispose()) - - let EnumerateFromFunctions create moveNext current = - Generate - create - (fun x -> if moveNext x then Some(current x) else None) - (fun x -> match box(x) with :? System.IDisposable as id -> id.Dispose() | _ -> ()) - - // A family of enumerators that can have additional 'finally' actions added to the enumerator through - // the use of mutation. This is used to 'push' the disposal action for a 'use' into the next enumerator. - // For example, - // seq { use x = ... - // while ... } - // results in the 'while' loop giving an adjustable enumerator. This is then adjusted by adding the disposal action - // from the 'use' into the enumerator. This means that we avoid constructing a two-deep enumerator chain in this - // common case. - type IFinallyEnumerator = - abstract AppendFinallyAction : (unit -> unit) -> unit - - /// A concrete implementation of IEnumerable that adds the given compensation to the "Dispose" chain of any - /// enumerators returned by the enumerable. - [] - type FinallyEnumerable<'T>(compensation: unit -> unit, restf: unit -> seq<'T>) = - interface IEnumerable<'T> with - member _.GetEnumerator() = +open System +open System.Diagnostics +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Collections.IEnumerator +open Microsoft.FSharp.Primitives.Basics +open System.Collections +open System.Collections.Generic +open System.Runtime.CompilerServices + +module RuntimeHelpers = + + [] + type internal StructBox<'T when 'T:equality>(value:'T) = + member x.Value = value + static member Comparer = + let gcomparer = HashIdentity.Structural<'T> + { new IEqualityComparer> with + member _.GetHashCode(v) = gcomparer.GetHashCode(v.Value) + member _.Equals(v1,v2) = gcomparer.Equals(v1.Value,v2.Value) } + + let Generate openf compute closef = + mkSeq (fun () -> new IEnumerator.GeneratedEnumerable<_,_>(openf, compute, closef) :> IEnumerator<'T>) + + let GenerateUsing (openf : unit -> ('U :> System.IDisposable)) compute = + Generate openf compute (fun (s:'U) -> s.Dispose()) + + let EnumerateFromFunctions create moveNext current = + Generate + create + (fun x -> if moveNext x then Some(current x) else None) + (fun x -> match box(x) with :? System.IDisposable as id -> id.Dispose() | _ -> ()) + + // A family of enumerators that can have additional 'finally' actions added to the enumerator through + // the use of mutation. This is used to 'push' the disposal action for a 'use' into the next enumerator. + // For example, + // seq { use x = ... + // while ... } + // results in the 'while' loop giving an adjustable enumerator. This is then adjusted by adding the disposal action + // from the 'use' into the enumerator. This means that we avoid constructing a two-deep enumerator chain in this + // common case. + type IFinallyEnumerator = + abstract AppendFinallyAction : (unit -> unit) -> unit + + /// A concrete implementation of IEnumerable that adds the given compensation to the "Dispose" chain of any + /// enumerators returned by the enumerable. + [] + type FinallyEnumerable<'T>(compensation: unit -> unit, restf: unit -> seq<'T>) = + interface IEnumerable<'T> with + member _.GetEnumerator() = + try + let ie = restf().GetEnumerator() + match ie with + | :? IFinallyEnumerator as a -> + a.AppendFinallyAction(compensation) + ie + | _ -> + IEnumerator.EnumerateThenFinally compensation ie + with e -> + compensation() + reraise() + interface IEnumerable with + member x.GetEnumerator() = ((x :> IEnumerable<'T>).GetEnumerator() :> IEnumerator) + + /// An optimized object for concatenating a sequence of enumerables + [] + type ConcatEnumerator<'T,'U when 'U :> seq<'T>>(sources: seq<'U>) = + let mutable outerEnum = sources.GetEnumerator() + let mutable currInnerEnum = IEnumerator.Empty() + + let mutable started = false + let mutable finished = false + let mutable compensations = [] + + [] // false = unchecked + val mutable private currElement : 'T + + member _.Finish() = + finished <- true + try + match currInnerEnum with + | null -> () + | _ -> try - let ie = restf().GetEnumerator() - match ie with - | :? IFinallyEnumerator as a -> - a.AppendFinallyAction(compensation) - ie - | _ -> - IEnumerator.EnumerateThenFinally compensation ie - with e -> - compensation() - reraise() - interface IEnumerable with - member x.GetEnumerator() = ((x :> IEnumerable<'T>).GetEnumerator() :> IEnumerator) - - /// An optimized object for concatenating a sequence of enumerables - [] - type ConcatEnumerator<'T,'U when 'U :> seq<'T>>(sources: seq<'U>) = - let mutable outerEnum = sources.GetEnumerator() - let mutable currInnerEnum = IEnumerator.Empty() - - let mutable started = false - let mutable finished = false - let mutable compensations = [] - - [] // false = unchecked - val mutable private currElement : 'T - - member _.Finish() = - finished <- true + currInnerEnum.Dispose() + finally + currInnerEnum <- null + finally try - match currInnerEnum with + match outerEnum with | null -> () | _ -> try - currInnerEnum.Dispose() + outerEnum.Dispose() finally - currInnerEnum <- null + outerEnum <- null finally + let rec iter comps = + match comps with + | [] -> () + | h :: t -> + try h() finally iter t try - match outerEnum with - | null -> () - | _ -> - try - outerEnum.Dispose() - finally - outerEnum <- null + compensations |> List.rev |> iter finally - let rec iter comps = - match comps with - | [] -> () - | h :: t -> - try h() finally iter t - try - compensations |> List.rev |> iter - finally - compensations <- [] - - member x.GetCurrent() = - IEnumerator.check started - if finished then IEnumerator.alreadyFinished() else x.currElement - - interface IFinallyEnumerator with - member _.AppendFinallyAction(f) = - compensations <- f :: compensations - - interface IEnumerator<'T> with - member x.Current = x.GetCurrent() - - interface IEnumerator with - member x.Current = box (x.GetCurrent()) - - member x.MoveNext() = - if not started then started <- true - if finished then false - else - let rec takeInner () = - // check the inner list - if currInnerEnum.MoveNext() then - x.currElement <- currInnerEnum.Current - true - else - // check the outer list - let rec takeOuter() = - if outerEnum.MoveNext() then - let ie = outerEnum.Current - // Optimization to detect the statically-allocated empty IEnumerables - match box ie with - | :? EmptyEnumerable<'T> -> - // This one is empty, just skip, don't call GetEnumerator, try again - takeOuter() - | _ -> - // OK, this one may not be empty. - // Don't forget to dispose of the enumerator for the inner list now we're done with it - currInnerEnum.Dispose() - currInnerEnum <- ie.GetEnumerator() - takeInner () - else - // We're done - x.Finish() - false - takeOuter() - takeInner () - - member _.Reset() = IEnumerator.noReset() - - interface System.IDisposable with - member x.Dispose() = - if not finished then - x.Finish() - - let EnumerateUsing (resource : 'T :> System.IDisposable) (source: 'T -> #seq<'U>) = - (FinallyEnumerable((fun () -> match box resource with null -> () | _ -> resource.Dispose()), - (fun () -> source resource :> seq<_>)) :> seq<_>) - - let mkConcatSeq (sources: seq<'U :> seq<'T>>) = - mkSeq (fun () -> new ConcatEnumerator<_,_>(sources) :> IEnumerator<'T>) - - let EnumerateWhile (guard: unit -> bool) (source: seq<'T>) : seq<'T> = - let mutable started = false - let mutable curr = None - let getCurr() = - IEnumerator.check started - match curr with None -> IEnumerator.alreadyFinished() | Some x -> x - let start() = if not started then (started <- true) - - let finish() = (curr <- None) - mkConcatSeq - (mkSeq (fun () -> - { new IEnumerator<_> with - member x.Current = getCurr() - interface IEnumerator with - member x.Current = box (getCurr()) - member x.MoveNext() = - start() - let keepGoing = (try guard() with e -> finish (); reraise ()) in - if keepGoing then - curr <- Some(source); true - else - finish(); false - member x.Reset() = IEnumerator.noReset() - interface System.IDisposable with - member x.Dispose() = () })) - - let EnumerateThenFinally (source: seq<'T>) (compensation: unit -> unit) = - (FinallyEnumerable(compensation, (fun () -> source)) :> seq<_>) - - let CreateEvent (addHandler : 'Delegate -> unit) (removeHandler : 'Delegate -> unit) (createHandler : (obj -> 'Args -> unit) -> 'Delegate ) :IEvent<'Delegate,'Args> = - { new obj() with - member x.ToString() = "" - interface IEvent<'Delegate,'Args> with - member x.AddHandler(h) = addHandler h - member x.RemoveHandler(h) = removeHandler h - interface System.IObservable<'Args> with - member x.Subscribe(r:IObserver<'Args>) = - let h = createHandler (fun _ args -> r.OnNext(args)) - addHandler h - { new System.IDisposable with - member x.Dispose() = removeHandler h } } - - let inline SetFreshConsTail cons tail = cons.( :: ).1 <- tail - - let inline FreshConsNoTail head = head :: (# "ldnull" : 'T list #) - - [] - type GeneratedSequenceBase<'T>() = - let mutable redirectTo : GeneratedSequenceBase<'T> = Unchecked.defaultof<_> - let mutable redirect : bool = false - - abstract GetFreshEnumerator : unit -> IEnumerator<'T> - abstract GenerateNext : result:byref> -> int // 0 = Stop, 1 = Yield, 2 = Goto - abstract Close: unit -> unit - abstract CheckClose: bool - abstract LastGenerated : 'T + compensations <- [] - //[] - member x.MoveNextImpl() = - let active = - if redirect then redirectTo - else x - let mutable target = null - match active.GenerateNext(&target) with - | 1 -> - true - | 2 -> - match target.GetEnumerator() with - | :? GeneratedSequenceBase<'T> as g when not active.CheckClose -> - redirectTo <- g - | e -> - redirectTo <- - { new GeneratedSequenceBase<'T>() with - member x.GetFreshEnumerator() = e - member x.GenerateNext(_) = if e.MoveNext() then 1 else 0 - member x.Close() = try e.Dispose() finally active.Close() - member x.CheckClose = true - member x.LastGenerated = e.Current } - redirect <- true - x.MoveNextImpl() - | _ (* 0 *) -> - false - - interface IEnumerable<'T> with - member x.GetEnumerator() = x.GetFreshEnumerator() + member x.GetCurrent() = + IEnumerator.check started + if finished then IEnumerator.alreadyFinished() else x.currElement - interface IEnumerable with - member x.GetEnumerator() = (x.GetFreshEnumerator() :> IEnumerator) + interface IFinallyEnumerator with + member _.AppendFinallyAction(f) = + compensations <- f :: compensations interface IEnumerator<'T> with - member x.Current = if redirect then redirectTo.LastGenerated else x.LastGenerated - - interface IDisposable with - member x.Dispose() = if redirect then redirectTo.Close() else x.Close() + member x.Current = x.GetCurrent() interface IEnumerator with - member x.Current = box (if redirect then redirectTo.LastGenerated else x.LastGenerated) - - //[] - member x.MoveNext() = x.MoveNextImpl() - - member _.Reset() = raise <| new System.NotSupportedException() + member x.Current = box (x.GetCurrent()) + + member x.MoveNext() = + if not started then started <- true + if finished then false + else + let rec takeInner () = + // check the inner list + if currInnerEnum.MoveNext() then + x.currElement <- currInnerEnum.Current + true + else + // check the outer list + let rec takeOuter() = + if outerEnum.MoveNext() then + let ie = outerEnum.Current + // Optimization to detect the statically-allocated empty IEnumerables + match box ie with + | :? EmptyEnumerable<'T> -> + // This one is empty, just skip, don't call GetEnumerator, try again + takeOuter() + | _ -> + // OK, this one may not be empty. + // Don't forget to dispose of the enumerator for the inner list now we're done with it + currInnerEnum.Dispose() + currInnerEnum <- ie.GetEnumerator() + takeInner () + else + // We're done + x.Finish() + false + takeOuter() + takeInner () + + member _.Reset() = IEnumerator.noReset() + + interface System.IDisposable with + member x.Dispose() = + if not finished then + x.Finish() + + let EnumerateUsing (resource : 'T :> System.IDisposable) (source: 'T -> #seq<'U>) = + (FinallyEnumerable((fun () -> match box resource with null -> () | _ -> resource.Dispose()), + (fun () -> source resource :> seq<_>)) :> seq<_>) + + let mkConcatSeq (sources: seq<'U :> seq<'T>>) = + mkSeq (fun () -> new ConcatEnumerator<_,_>(sources) :> IEnumerator<'T>) + + let EnumerateWhile (guard: unit -> bool) (source: seq<'T>) : seq<'T> = + let mutable started = false + let mutable curr = None + let getCurr() = + IEnumerator.check started + match curr with None -> IEnumerator.alreadyFinished() | Some x -> x + let start() = if not started then (started <- true) + + let finish() = (curr <- None) + mkConcatSeq + (mkSeq (fun () -> + { new IEnumerator<_> with + member x.Current = getCurr() + interface IEnumerator with + member x.Current = box (getCurr()) + member x.MoveNext() = + start() + let keepGoing = (try guard() with e -> finish (); reraise ()) in + if keepGoing then + curr <- Some(source); true + else + finish(); false + member x.Reset() = IEnumerator.noReset() + interface System.IDisposable with + member x.Dispose() = () })) + + let EnumerateThenFinally (source: seq<'T>) (compensation: unit -> unit) = + (FinallyEnumerable(compensation, (fun () -> source)) :> seq<_>) + + let CreateEvent (addHandler : 'Delegate -> unit) (removeHandler : 'Delegate -> unit) (createHandler : (obj -> 'Args -> unit) -> 'Delegate ) :IEvent<'Delegate,'Args> = + { new obj() with + member x.ToString() = "" + interface IEvent<'Delegate,'Args> with + member x.AddHandler(h) = addHandler h + member x.RemoveHandler(h) = removeHandler h + interface System.IObservable<'Args> with + member x.Subscribe(r:IObserver<'Args>) = + let h = createHandler (fun _ args -> r.OnNext(args)) + addHandler h + { new System.IDisposable with + member x.Dispose() = removeHandler h } } + + let inline SetFreshConsTail cons tail = cons.( :: ).1 <- tail + + let inline FreshConsNoTail head = head :: (# "ldnull" : 'T list #) + +[] +type GeneratedSequenceBase<'T>() = + let mutable redirectTo : GeneratedSequenceBase<'T> = Unchecked.defaultof<_> + let mutable redirect : bool = false + + abstract GetFreshEnumerator : unit -> IEnumerator<'T> + abstract GenerateNext : result:byref> -> int // 0 = Stop, 1 = Yield, 2 = Goto + abstract Close: unit -> unit + abstract CheckClose: bool + abstract LastGenerated : 'T + + //[] + member x.MoveNextImpl() = + let active = + if redirect then redirectTo + else x + let mutable target = null + match active.GenerateNext(&target) with + | 1 -> + true + | 2 -> + match target.GetEnumerator() with + | :? GeneratedSequenceBase<'T> as g when not active.CheckClose -> + redirectTo <- g + | e -> + redirectTo <- + { new GeneratedSequenceBase<'T>() with + member x.GetFreshEnumerator() = e + member x.GenerateNext(_) = if e.MoveNext() then 1 else 0 + member x.Close() = try e.Dispose() finally active.Close() + member x.CheckClose = true + member x.LastGenerated = e.Current } + redirect <- true + x.MoveNextImpl() + | _ (* 0 *) -> + false + + interface IEnumerable<'T> with + member x.GetEnumerator() = x.GetFreshEnumerator() + + interface IEnumerable with + member x.GetEnumerator() = (x.GetFreshEnumerator() :> IEnumerator) + + interface IEnumerator<'T> with + member x.Current = if redirect then redirectTo.LastGenerated else x.LastGenerated + + interface IDisposable with + member x.Dispose() = if redirect then redirectTo.Close() else x.Close() + + interface IEnumerator with + member x.Current = box (if redirect then redirectTo.LastGenerated else x.LastGenerated) - [] - type ListCollector<'T> = - [] - val mutable Result : 'T list - - [] - val mutable LastCons : 'T list - - member this.Add (value: 'T) = - match box this.Result with - | null -> - let ra = RuntimeHelpers.FreshConsNoTail value - this.Result <- ra - this.LastCons <- ra - | _ -> - let ra = RuntimeHelpers.FreshConsNoTail value - RuntimeHelpers.SetFreshConsTail this.LastCons ra - this.LastCons <- ra + //[] + member x.MoveNext() = x.MoveNextImpl() + + member _.Reset() = raise <| new System.NotSupportedException() + +[] +type ListCollector<'T> = + [] + val mutable Result : 'T list + + [] + val mutable LastCons : 'T list + + member this.Add (value: 'T) = + match box this.Result with + | null -> + let ra = RuntimeHelpers.FreshConsNoTail value + this.Result <- ra + this.LastCons <- ra + | _ -> + let ra = RuntimeHelpers.FreshConsNoTail value + RuntimeHelpers.SetFreshConsTail this.LastCons ra + this.LastCons <- ra + + member this.AddMany (values: seq<'T>) = + // cook a faster iterator for lists and arrays + match values with + | :? ('T[]) as valuesAsArray -> + for v in valuesAsArray do + this.Add v + | :? ('T list) as valuesAsList -> + for v in valuesAsList do + this.Add v + | _ -> + for v in values do + this.Add v + + // In the particular case of closing with a final add of an F# list + // we can simply stitch the list into the end of the resulting list + member this.AddManyAndClose (values: seq<'T>) = + match values with + | :? ('T list) as valuesAsList -> + let res = + match box this.Result with + | null -> + valuesAsList + | _ -> + RuntimeHelpers.SetFreshConsTail this.LastCons valuesAsList + this.Result + this.Result <- Unchecked.defaultof<_> + this.LastCons <- Unchecked.defaultof<_> + res + | _ -> + this.AddMany values + this.Close() - member this.AddMany (values: seq<'T>) = + member this.Close() = + match box this.Result with + | null -> [] + | _ -> + RuntimeHelpers.SetFreshConsTail this.LastCons [] + let res = this.Result + this.Result <- Unchecked.defaultof<_> + this.LastCons <- Unchecked.defaultof<_> + res + +// Optimized for 0, 1 and 2 sized arrays +[] +type ArrayCollector<'T> = + [] + val mutable ResizeArray: ResizeArray<'T> + + [] + val mutable First: 'T + + [] + val mutable Second: 'T + + [] + val mutable Count: int + + member this.Add (value: 'T) = + match this.Count with + | 0 -> + this.Count <- 1 + this.First <- value + | 1 -> + this.Count <- 2 + this.Second <- value + | 2 -> + let ra = ResizeArray<'T>() + ra.Add(this.First) + ra.Add(this.Second) + ra.Add(value) + this.Count <- 3 + this.ResizeArray <- ra + | _ -> + this.ResizeArray.Add(value) + + member this.AddMany (values: seq<'T>) = + if this.Count > 2 then + this.ResizeArray.AddRange(values) + else // cook a faster iterator for lists and arrays match values with | :? ('T[]) as valuesAsArray -> @@ -474,104 +553,26 @@ namespace Microsoft.FSharp.Core.CompilerServices for v in values do this.Add v - // In the particular case of closing with a final add of an F# list - // we can simply stitch the list into the end of the resulting list - member this.AddManyAndClose (values: seq<'T>) = - match values with - | :? ('T list) as valuesAsList -> - let res = - match box this.Result with - | null -> - valuesAsList - | _ -> - RuntimeHelpers.SetFreshConsTail this.LastCons valuesAsList - this.Result - this.Result <- Unchecked.defaultof<_> - this.LastCons <- Unchecked.defaultof<_> - res - | _ -> - this.AddMany values - this.Close() - - member this.Close() = - match box this.Result with - | null -> [] - | _ -> - RuntimeHelpers.SetFreshConsTail this.LastCons [] - let res = this.Result - this.Result <- Unchecked.defaultof<_> - this.LastCons <- Unchecked.defaultof<_> - res - - // Optimized for 0, 1 and 2 sized arrays - [] - type ArrayCollector<'T> = - [] - val mutable ResizeArray: ResizeArray<'T> - - [] - val mutable First: 'T - - [] - val mutable Second: 'T - - [] - val mutable Count: int - - member this.Add (value: 'T) = - match this.Count with - | 0 -> - this.Count <- 1 - this.First <- value - | 1 -> - this.Count <- 2 - this.Second <- value - | 2 -> - let ra = ResizeArray<'T>() - ra.Add(this.First) - ra.Add(this.Second) - ra.Add(value) - this.Count <- 3 - this.ResizeArray <- ra - | _ -> - this.ResizeArray.Add(value) - - member this.AddMany (values: seq<'T>) = - if this.Count > 2 then - this.ResizeArray.AddRange(values) - else - // cook a faster iterator for lists and arrays - match values with - | :? ('T[]) as valuesAsArray -> - for v in valuesAsArray do - this.Add v - | :? ('T list) as valuesAsList -> - for v in valuesAsList do - this.Add v - | _ -> - for v in values do - this.Add v - - member this.AddManyAndClose (values: seq<'T>) = - this.AddMany(values) - this.Close() - - member this.Close() = - match this.Count with - | 0 -> Array.Empty<'T>() - | 1 -> - let res = [| this.First |] - this.Count <- 0 - this.First <- Unchecked.defaultof<_> - res - | 2 -> - let res = [| this.First; this.Second |] - this.Count <- 0 - this.First <- Unchecked.defaultof<_> - this.Second <- Unchecked.defaultof<_> - res - | _ -> - let res = this.ResizeArray.ToArray() - this <- ArrayCollector<'T>() - res - + member this.AddManyAndClose (values: seq<'T>) = + this.AddMany(values) + this.Close() + + member this.Close() = + match this.Count with + | 0 -> Array.Empty<'T>() + | 1 -> + let res = [| this.First |] + this.Count <- 0 + this.First <- Unchecked.defaultof<_> + res + | 2 -> + let res = [| this.First; this.Second |] + this.Count <- 0 + this.First <- Unchecked.defaultof<_> + this.Second <- Unchecked.defaultof<_> + res + | _ -> + let res = this.ResizeArray.ToArray() + this <- ArrayCollector<'T>() + res + diff --git a/src/FSharp.Core/string.fs b/src/FSharp.Core/string.fs index a653cbf20b7eacd83b3a15cf2a22a66e0115d44c..f36e430e66c5270c09cda8518b3539d8d00302c4 100644 --- a/src/FSharp.Core/string.fs +++ b/src/FSharp.Core/string.fs @@ -2,181 +2,182 @@ namespace Microsoft.FSharp.Core - open System - open System.Text - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.Operators.Checked - open Microsoft.FSharp.Collections - open Microsoft.FSharp.Primitives.Basics - - [] - [] - module String = - /// LOH threshold is calculated from Internal.Utilities.Library.LOH_SIZE_THRESHOLD_BYTES, - /// and is equal to 80_000 / sizeof - [] - let LOH_CHAR_THRESHOLD = 40_000 - - [] - let length (str:string) = if isNull str then 0 else str.Length - - [] - let concat sep (strings : seq) = - - let concatArray sep (strings: string []) = - match length sep with - | 0 -> String.Concat strings - // following line should be used when this overload becomes part of .NET Standard (it's only in .NET Core) - //| 1 -> String.Join(sep.[0], strings, 0, strings.Length) - | _ -> String.Join(sep, strings, 0, strings.Length) - - match strings with - | :? (string[]) as arr -> - concatArray sep arr - - | :? (string list) as lst -> - lst - |> List.toArray - |> concatArray sep - - | _ -> - String.Join(sep, strings) - - [] - let iter (action : (char -> unit)) (str:string) = - if not (String.IsNullOrEmpty str) then - for i = 0 to str.Length - 1 do - action str.[i] - - [] - let iteri action (str:string) = - if not (String.IsNullOrEmpty str) then - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) - for i = 0 to str.Length - 1 do - f.Invoke(i, str.[i]) - - [] - let map (mapping: char -> char) (str:string) = - if String.IsNullOrEmpty str then - String.Empty - else - let result = str.ToCharArray() - let mutable i = 0 - for c in result do - result.[i] <- mapping c - i <- i + 1 - - new String(result) - - [] - let mapi (mapping: int -> char -> char) (str:string) = - let len = length str - if len = 0 then - String.Empty - else - let result = str.ToCharArray() - let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(mapping) +open System +open System.Text +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Core.Operators.Checked +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Primitives.Basics + +[] +[] +module String = + + /// LOH threshold is calculated from Internal.Utilities.Library.LOH_SIZE_THRESHOLD_BYTES, + /// and is equal to 80_000 / sizeof + [] + let LOH_CHAR_THRESHOLD = 40_000 + + [] + let length (str:string) = + if isNull str then 0 else str.Length + + [] + let concat sep (strings : seq) = + + let concatArray sep (strings: string []) = + match length sep with + | 0 -> String.Concat strings + // following line should be used when this overload becomes part of .NET Standard (it's only in .NET Core) + //| 1 -> String.Join(sep.[0], strings, 0, strings.Length) + | _ -> String.Join(sep, strings, 0, strings.Length) + + match strings with + | :? (string[]) as arr -> + concatArray sep arr + + | :? (string list) as lst -> + lst + |> List.toArray + |> concatArray sep + + | _ -> + String.Join(sep, strings) + + [] + let iter (action : (char -> unit)) (str:string) = + if not (String.IsNullOrEmpty str) then + for i = 0 to str.Length - 1 do + action str.[i] + + [] + let iteri action (str:string) = + if not (String.IsNullOrEmpty str) then + let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(action) + for i = 0 to str.Length - 1 do + f.Invoke(i, str.[i]) + + [] + let map (mapping: char -> char) (str:string) = + if String.IsNullOrEmpty str then + String.Empty + else + let result = str.ToCharArray() + let mutable i = 0 + for c in result do + result.[i] <- mapping c + i <- i + 1 + + new String(result) + + [] + let mapi (mapping: int -> char -> char) (str:string) = + let len = length str + if len = 0 then + String.Empty + else + let result = str.ToCharArray() + let f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(mapping) + + let mutable i = 0 + while i < len do + result.[i] <- f.Invoke(i, result.[i]) + i <- i + 1 + + new String(result) + + [] + let filter (predicate: char -> bool) (str:string) = + let len = length str + + if len = 0 then + String.Empty + + elif len > LOH_CHAR_THRESHOLD then + // By using SB here, which is twice slower than the optimized path, we prevent LOH allocations + // and 'stop the world' collections if the filtering results in smaller strings. + // We also don't pre-allocate SB here, to allow for less mem pressure when filter result is small. + let res = StringBuilder() + str |> iter (fun c -> if predicate c then res.Append c |> ignore) + res.ToString() - let mutable i = 0 - while i < len do - result.[i] <- f.Invoke(i, result.[i]) + else + // Must do it this way, since array.fs is not yet in scope, but this is safe + let target = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len + let mutable i = 0 + for c in str do + if predicate c then + target.[i] <- c i <- i + 1 - new String(result) - - [] - let filter (predicate: char -> bool) (str:string) = - let len = length str - - if len = 0 then - String.Empty - - elif len > LOH_CHAR_THRESHOLD then - // By using SB here, which is twice slower than the optimized path, we prevent LOH allocations - // and 'stop the world' collections if the filtering results in smaller strings. - // We also don't pre-allocate SB here, to allow for less mem pressure when filter result is small. - let res = StringBuilder() - str |> iter (fun c -> if predicate c then res.Append c |> ignore) - res.ToString() - - else - // Must do it this way, since array.fs is not yet in scope, but this is safe - let target = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked len - let mutable i = 0 - for c in str do - if predicate c then - target.[i] <- c - i <- i + 1 - - String(target, 0, i) - - [] - let collect (mapping: char -> string) (str:string) = - if String.IsNullOrEmpty str then - String.Empty - else - let res = StringBuilder str.Length - str |> iter (fun c -> res.Append(mapping c) |> ignore) - res.ToString() - - [] - let init (count:int) (initializer: int-> string) = - if count < 0 then invalidArgInputMustBeNonNegative "count" count - let res = StringBuilder count - for i = 0 to count - 1 do - res.Append(initializer i) |> ignore + String(target, 0, i) + + [] + let collect (mapping: char -> string) (str:string) = + if String.IsNullOrEmpty str then + String.Empty + else + let res = StringBuilder str.Length + str |> iter (fun c -> res.Append(mapping c) |> ignore) res.ToString() - [] - let replicate (count:int) (str:string) = - if count < 0 then invalidArgInputMustBeNonNegative "count" count - - let len = length str - if len = 0 || count = 0 then - String.Empty - - elif len = 1 then - new String(str.[0], count) - - elif count <= 4 then - match count with - | 1 -> str - | 2 -> String.Concat(str, str) - | 3 -> String.Concat(str, str, str) - | _ -> String.Concat(str, str, str, str) - - else - // Using the primitive, because array.fs is not yet in scope. It's safe: both len and count are positive. - let target = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len * count) - let source = str.ToCharArray() - - // O(log(n)) performance loop: - // Copy first string, then keep copying what we already copied - // (i.e., doubling it) until we reach or pass the halfway point - Array.Copy(source, 0, target, 0, len) - let mutable i = len - while i * 2 < target.Length do - Array.Copy(target, 0, target, i, i) - i <- i * 2 - - // finally, copy the remain half, or less-then half - Array.Copy(target, 0, target, i, target.Length - i) - new String(target) - - - [] - let forall predicate (str:string) = - if String.IsNullOrEmpty str then - true - else - let rec check i = (i >= str.Length) || (predicate str.[i] && check (i+1)) - check 0 - - [] - let exists predicate (str:string) = - if String.IsNullOrEmpty str then - false - else - let rec check i = (i < str.Length) && (predicate str.[i] || check (i+1)) - check 0 + [] + let init (count:int) (initializer: int-> string) = + if count < 0 then invalidArgInputMustBeNonNegative "count" count + let res = StringBuilder count + for i = 0 to count - 1 do + res.Append(initializer i) |> ignore + res.ToString() + + [] + let replicate (count:int) (str:string) = + if count < 0 then invalidArgInputMustBeNonNegative "count" count + + let len = length str + if len = 0 || count = 0 then + String.Empty + + elif len = 1 then + new String(str.[0], count) + + elif count <= 4 then + match count with + | 1 -> str + | 2 -> String.Concat(str, str) + | 3 -> String.Concat(str, str, str) + | _ -> String.Concat(str, str, str, str) + + else + // Using the primitive, because array.fs is not yet in scope. It's safe: both len and count are positive. + let target = Microsoft.FSharp.Primitives.Basics.Array.zeroCreateUnchecked (len * count) + let source = str.ToCharArray() + + // O(log(n)) performance loop: + // Copy first string, then keep copying what we already copied + // (i.e., doubling it) until we reach or pass the halfway point + Array.Copy(source, 0, target, 0, len) + let mutable i = len + while i * 2 < target.Length do + Array.Copy(target, 0, target, i, i) + i <- i * 2 + + // finally, copy the remain half, or less-then half + Array.Copy(target, 0, target, i, target.Length - i) + new String(target) + + [] + let forall predicate (str:string) = + if String.IsNullOrEmpty str then + true + else + let rec check i = (i >= str.Length) || (predicate str.[i] && check (i+1)) + check 0 + + [] + let exists predicate (str:string) = + if String.IsNullOrEmpty str then + false + else + let rec check i = (i < str.Length) && (predicate str.[i] || check (i+1)) + check 0 diff --git a/src/FSharp.Core/tasks.fs b/src/FSharp.Core/tasks.fs index 83acba93a5ebfa0d86d65599be9338ae9322ffea..4ec83a25be955072c89def17d645d79229994169 100644 --- a/src/FSharp.Core/tasks.fs +++ b/src/FSharp.Core/tasks.fs @@ -13,372 +13,372 @@ namespace Microsoft.FSharp.Control - #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE - open System - open System.Runtime.CompilerServices - open System.Threading - open System.Threading.Tasks - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.CompilerServices - open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open Microsoft.FSharp.Control - open Microsoft.FSharp.Collections - - /// The extra data stored in ResumableStateMachine for tasks - [] - type TaskStateMachineData<'T> = - - [] - val mutable Result : 'T - - [] - val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> - - and TaskStateMachine<'TOverall> = ResumableStateMachine> - and TaskResumptionFunc<'TOverall> = ResumptionFunc> - and TaskResumptionDynamicInfo<'TOverall> = ResumptionDynamicInfo> - and TaskCode<'TOverall, 'T> = ResumableCode, 'T> - - type TaskBuilderBase() = - - member inline _.Delay(generator : unit -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = - TaskCode<'TOverall, 'T>(fun sm -> (generator()).Invoke(&sm)) - - /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - [] - member inline _.Zero() : TaskCode<'TOverall, unit> = ResumableCode.Zero() - - member inline _.Return (value: 'T) : TaskCode<'T, 'T> = - TaskCode<'T, _>(fun sm -> - sm.Data.Result <- value - true) - - /// Chains together a step with its following step. - /// Note that this requires that the first step has no result. - /// This prevents constructs like `task { return 1; return 2; }`. - member inline _.Combine(task1: TaskCode<'TOverall, unit>, task2: TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = - ResumableCode.Combine(task1, task2) - - /// Builds a step that executes the body while the condition predicate is true. - member inline _.While ([] condition : unit -> bool, body : TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = - ResumableCode.While(condition, body) - - /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function - /// to retrieve the step, and in the continuation of the step (if any). - member inline _.TryWith (body: TaskCode<'TOverall, 'T>, catch: exn -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = - ResumableCode.TryWith(body, catch) - - /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function - /// to retrieve the step, and in the continuation of the step (if any). - member inline _.TryFinally (body: TaskCode<'TOverall, 'T>, [] compensation : unit -> unit) : TaskCode<'TOverall, 'T> = - ResumableCode.TryFinally(body, ResumableCode<_,_>(fun _sm -> compensation(); true)) - - member inline _.For (sequence : seq<'T>, body : 'T -> TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = - ResumableCode.For(sequence, body) - - #if NETSTANDARD2_1 - member inline internal this.TryFinallyAsync(body: TaskCode<'TOverall, 'T>, compensation : unit -> ValueTask) : TaskCode<'TOverall, 'T> = - ResumableCode.TryFinallyAsync(body, ResumableCode<_,_>(fun sm -> - if __useResumableCode then - let mutable __stack_condition_fin = true - let __stack_vtask = compensation() - if not __stack_vtask.IsCompleted then - let mutable awaiter = __stack_vtask.GetAwaiter() - let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) - __stack_condition_fin <- __stack_yield_fin +#if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE +open System +open System.Runtime.CompilerServices +open System.Threading +open System.Threading.Tasks +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections + +/// The extra data stored in ResumableStateMachine for tasks +[] +type TaskStateMachineData<'T> = + + [] + val mutable Result : 'T + + [] + val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> + +and TaskStateMachine<'TOverall> = ResumableStateMachine> +and TaskResumptionFunc<'TOverall> = ResumptionFunc> +and TaskResumptionDynamicInfo<'TOverall> = ResumptionDynamicInfo> +and TaskCode<'TOverall, 'T> = ResumableCode, 'T> + +type TaskBuilderBase() = + + member inline _.Delay(generator : unit -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + TaskCode<'TOverall, 'T>(fun sm -> (generator()).Invoke(&sm)) + + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + [] + member inline _.Zero() : TaskCode<'TOverall, unit> = ResumableCode.Zero() + + member inline _.Return (value: 'T) : TaskCode<'T, 'T> = + TaskCode<'T, _>(fun sm -> + sm.Data.Result <- value + true) + + /// Chains together a step with its following step. + /// Note that this requires that the first step has no result. + /// This prevents constructs like `task { return 1; return 2; }`. + member inline _.Combine(task1: TaskCode<'TOverall, unit>, task2: TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + ResumableCode.Combine(task1, task2) + + /// Builds a step that executes the body while the condition predicate is true. + member inline _.While ([] condition : unit -> bool, body : TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = + ResumableCode.While(condition, body) + + /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + member inline _.TryWith (body: TaskCode<'TOverall, 'T>, catch: exn -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + ResumableCode.TryWith(body, catch) + + /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + member inline _.TryFinally (body: TaskCode<'TOverall, 'T>, [] compensation : unit -> unit) : TaskCode<'TOverall, 'T> = + ResumableCode.TryFinally(body, ResumableCode<_,_>(fun _sm -> compensation(); true)) + + member inline _.For (sequence : seq<'T>, body : 'T -> TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = + ResumableCode.For(sequence, body) + +#if NETSTANDARD2_1 + member inline internal this.TryFinallyAsync(body: TaskCode<'TOverall, 'T>, compensation : unit -> ValueTask) : TaskCode<'TOverall, 'T> = + ResumableCode.TryFinallyAsync(body, ResumableCode<_,_>(fun sm -> + if __useResumableCode then + let mutable __stack_condition_fin = true + let __stack_vtask = compensation() + if not __stack_vtask.IsCompleted then + let mutable awaiter = __stack_vtask.GetAwaiter() + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_condition_fin <- __stack_yield_fin + + if not __stack_condition_fin then + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + + __stack_condition_fin + else + let vtask = compensation() + let mutable awaiter = vtask.GetAwaiter() - if not __stack_condition_fin then - sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + let cont = + TaskResumptionFunc<'TOverall>( fun sm -> + awaiter.GetResult() |> ignore + true) - __stack_condition_fin + // shortcut to continue immediately + if awaiter.IsCompleted then + true else - let vtask = compensation() - let mutable awaiter = vtask.GetAwaiter() + sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) + sm.ResumptionDynamicInfo.ResumptionFunc <- cont + false + )) + + member inline this.Using<'Resource, 'TOverall, 'T when 'Resource :> IAsyncDisposable> (resource: 'Resource, body: 'Resource -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = + this.TryFinallyAsync( + (fun sm -> (body resource).Invoke(&sm)), + (fun () -> + if not (isNull (box resource)) then + resource.DisposeAsync() + else + ValueTask())) +#endif - let cont = - TaskResumptionFunc<'TOverall>( fun sm -> - awaiter.GetResult() |> ignore - true) - // shortcut to continue immediately - if awaiter.IsCompleted then - true - else - sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) - sm.ResumptionDynamicInfo.ResumptionFunc <- cont - false - )) - - member inline this.Using<'Resource, 'TOverall, 'T when 'Resource :> IAsyncDisposable> (resource: 'Resource, body: 'Resource -> TaskCode<'TOverall, 'T>) : TaskCode<'TOverall, 'T> = - this.TryFinallyAsync( - (fun sm -> (body resource).Invoke(&sm)), - (fun () -> - if not (isNull (box resource)) then - resource.DisposeAsync() - else - ValueTask())) - #endif - - - type TaskBuilder() = - - inherit TaskBuilderBase() - - // This is the dynamic implementation - this is not used - // for statically compiled tasks. An executor (resumptionFuncExecutor) is - // registered with the state machine, plus the initial resumption. - // The executor stays constant throughout the execution, it wraps each step - // of the execution in a try/with. The resumption is changed at each step - // to represent the continuation of the computation. - static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = - let mutable sm = TaskStateMachine<'T>() - let initialResumptionFunc = TaskResumptionFunc<'T>(fun sm -> code.Invoke(&sm)) - let resumptionInfo = - { new TaskResumptionDynamicInfo<'T>(initialResumptionFunc) with - member info.MoveNext(sm) = - let mutable savedExn = null - try - sm.ResumptionDynamicInfo.ResumptionData <- null - let step = info.ResumptionFunc.Invoke(&sm) - if step then - sm.Data.MethodBuilder.SetResult(sm.Data.Result) - else - let mutable awaiter = sm.ResumptionDynamicInfo.ResumptionData :?> ICriticalNotifyCompletion - assert not (isNull awaiter) - sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) - - with exn -> - savedExn <- exn - // Run SetException outside the stack unwind, see https://github.com/dotnet/roslyn/issues/26567 - match savedExn with - | null -> () - | exn -> sm.Data.MethodBuilder.SetException exn - - member _.SetStateMachine(sm, state) = - sm.Data.MethodBuilder.SetStateMachine(state) - } - sm.ResumptionDynamicInfo <- resumptionInfo - sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() - sm.Data.MethodBuilder.Start(&sm) - sm.Data.MethodBuilder.Task - - member inline _.Run(code : TaskCode<'T, 'T>) : Task<'T> = - if __useResumableCode then - __stateMachine, Task<'T>> - (MoveNextMethodImpl<_>(fun sm -> - //-- RESUMABLE CODE START - __resumeAt sm.ResumptionPoint - let mutable __stack_exn : Exception = null - try - let __stack_code_fin = code.Invoke(&sm) - if __stack_code_fin then - sm.Data.MethodBuilder.SetResult(sm.Data.Result) - with exn -> - __stack_exn <- exn - // Run SetException outside the stack unwind, see https://github.com/dotnet/roslyn/issues/26567 - match __stack_exn with - | null -> () - | exn -> sm.Data.MethodBuilder.SetException exn - //-- RESUMABLE CODE END - )) - (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine(state))) - (AfterCode<_,_>(fun sm -> +type TaskBuilder() = + + inherit TaskBuilderBase() + + // This is the dynamic implementation - this is not used + // for statically compiled tasks. An executor (resumptionFuncExecutor) is + // registered with the state machine, plus the initial resumption. + // The executor stays constant throughout the execution, it wraps each step + // of the execution in a try/with. The resumption is changed at each step + // to represent the continuation of the computation. + static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = + let mutable sm = TaskStateMachine<'T>() + let initialResumptionFunc = TaskResumptionFunc<'T>(fun sm -> code.Invoke(&sm)) + let resumptionInfo = + { new TaskResumptionDynamicInfo<'T>(initialResumptionFunc) with + member info.MoveNext(sm) = + let mutable savedExn = null + try + sm.ResumptionDynamicInfo.ResumptionData <- null + let step = info.ResumptionFunc.Invoke(&sm) + if step then + sm.Data.MethodBuilder.SetResult(sm.Data.Result) + else + let mutable awaiter = sm.ResumptionDynamicInfo.ResumptionData :?> ICriticalNotifyCompletion + assert not (isNull awaiter) + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + + with exn -> + savedExn <- exn + // Run SetException outside the stack unwind, see https://github.com/dotnet/roslyn/issues/26567 + match savedExn with + | null -> () + | exn -> sm.Data.MethodBuilder.SetException exn + + member _.SetStateMachine(sm, state) = + sm.Data.MethodBuilder.SetStateMachine(state) + } + sm.ResumptionDynamicInfo <- resumptionInfo + sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + sm.Data.MethodBuilder.Start(&sm) + sm.Data.MethodBuilder.Task + + member inline _.Run(code : TaskCode<'T, 'T>) : Task<'T> = + if __useResumableCode then + __stateMachine, Task<'T>> + (MoveNextMethodImpl<_>(fun sm -> + //-- RESUMABLE CODE START + __resumeAt sm.ResumptionPoint + let mutable __stack_exn : Exception = null + try + let __stack_code_fin = code.Invoke(&sm) + if __stack_code_fin then + sm.Data.MethodBuilder.SetResult(sm.Data.Result) + with exn -> + __stack_exn <- exn + // Run SetException outside the stack unwind, see https://github.com/dotnet/roslyn/issues/26567 + match __stack_exn with + | null -> () + | exn -> sm.Data.MethodBuilder.SetException exn + //-- RESUMABLE CODE END + )) + (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine(state))) + (AfterCode<_,_>(fun sm -> + sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + sm.Data.MethodBuilder.Start(&sm) + sm.Data.MethodBuilder.Task)) + else + TaskBuilder.RunDynamic(code) + +type BackgroundTaskBuilder() = + + inherit TaskBuilderBase() + + static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = + // backgroundTask { .. } escapes to a background thread where necessary + // See spec of ConfigureAwait(false) at https://devblogs.microsoft.com/dotnet/configureawait-faq/ + if isNull SynchronizationContext.Current && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) then + TaskBuilder.RunDynamic(code) + else + Task.Run<'T>(fun () -> TaskBuilder.RunDynamic(code)) + + //// Same as TaskBuilder.Run except the start is inside Task.Run if necessary + member inline _.Run(code : TaskCode<'T, 'T>) : Task<'T> = + if __useResumableCode then + __stateMachine, Task<'T>> + (MoveNextMethodImpl<_>(fun sm -> + //-- RESUMABLE CODE START + __resumeAt sm.ResumptionPoint + try + let __stack_code_fin = code.Invoke(&sm) + if __stack_code_fin then + sm.Data.MethodBuilder.SetResult(sm.Data.Result) + with exn -> + sm.Data.MethodBuilder.SetException exn + //-- RESUMABLE CODE END + )) + (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine(state))) + (AfterCode<_,Task<'T>>(fun sm -> + // backgroundTask { .. } escapes to a background thread where necessary + // See spec of ConfigureAwait(false) at https://devblogs.microsoft.com/dotnet/configureawait-faq/ + if isNull SynchronizationContext.Current && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) then sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() sm.Data.MethodBuilder.Start(&sm) - sm.Data.MethodBuilder.Task)) - else - TaskBuilder.RunDynamic(code) - - type BackgroundTaskBuilder() = - - inherit TaskBuilderBase() - - static member RunDynamic(code: TaskCode<'T, 'T>) : Task<'T> = - // backgroundTask { .. } escapes to a background thread where necessary - // See spec of ConfigureAwait(false) at https://devblogs.microsoft.com/dotnet/configureawait-faq/ - if isNull SynchronizationContext.Current && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) then - TaskBuilder.RunDynamic(code) - else - Task.Run<'T>(fun () -> TaskBuilder.RunDynamic(code)) - - //// Same as TaskBuilder.Run except the start is inside Task.Run if necessary - member inline _.Run(code : TaskCode<'T, 'T>) : Task<'T> = - if __useResumableCode then - __stateMachine, Task<'T>> - (MoveNextMethodImpl<_>(fun sm -> - //-- RESUMABLE CODE START - __resumeAt sm.ResumptionPoint - try - let __stack_code_fin = code.Invoke(&sm) - if __stack_code_fin then - sm.Data.MethodBuilder.SetResult(sm.Data.Result) - with exn -> - sm.Data.MethodBuilder.SetException exn - //-- RESUMABLE CODE END - )) - (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine(state))) - (AfterCode<_,Task<'T>>(fun sm -> - // backgroundTask { .. } escapes to a background thread where necessary - // See spec of ConfigureAwait(false) at https://devblogs.microsoft.com/dotnet/configureawait-faq/ - if isNull SynchronizationContext.Current && obj.ReferenceEquals(TaskScheduler.Current, TaskScheduler.Default) then + sm.Data.MethodBuilder.Task + else + let sm = sm // copy contents of state machine so we can capture it + Task.Run<'T>(fun () -> + let mutable sm = sm // host local mutable copy of contents of state machine on this thread pool thread sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() sm.Data.MethodBuilder.Start(&sm) - sm.Data.MethodBuilder.Task - else - let sm = sm // copy contents of state machine so we can capture it - Task.Run<'T>(fun () -> - let mutable sm = sm // host local mutable copy of contents of state machine on this thread pool thread - sm.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() - sm.Data.MethodBuilder.Start(&sm) - sm.Data.MethodBuilder.Task))) - else - BackgroundTaskBuilder.RunDynamic(code) - - module TaskBuilder = - - let task = TaskBuilder() - let backgroundTask = BackgroundTaskBuilder() + sm.Data.MethodBuilder.Task))) + else + BackgroundTaskBuilder.RunDynamic(code) -namespace Microsoft.FSharp.Control.TaskBuilderExtensions - - open Microsoft.FSharp.Control - open System - open System.Runtime.CompilerServices - open System.Threading.Tasks - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.CompilerServices - open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - - module LowPriority = - // Low priority extensions - type TaskBuilderBase with - - [] - static member inline BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall - when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'TResult1)> - (sm: byref<_>, task: ^TaskLike, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : bool = +module TaskBuilder = - let mutable awaiter = (^TaskLike: (member GetAwaiter : unit -> ^Awaiter)(task)) + let task = TaskBuilder() + let backgroundTask = BackgroundTaskBuilder() - let cont = - (TaskResumptionFunc<'TOverall>( fun sm -> - let result = (^Awaiter : (member GetResult : unit -> 'TResult1)(awaiter)) - (continuation result).Invoke(&sm))) - - // shortcut to continue immediately - if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then - cont.Invoke(&sm) - else - sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) - sm.ResumptionDynamicInfo.ResumptionFunc <- cont - false - - [] - member inline _.Bind< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall - when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'TResult1)> - (task: ^TaskLike, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = - - TaskCode<'TOverall, _>(fun sm -> - if __useResumableCode then - //-- RESUMABLE CODE START - // Get an awaiter from the awaitable - let mutable awaiter = (^TaskLike: (member GetAwaiter : unit -> ^Awaiter)(task)) - - let mutable __stack_fin = true - if not (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then - // This will yield with __stack_yield_fin = false - // This will resume with __stack_yield_fin = true - let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) - __stack_fin <- __stack_yield_fin - - if __stack_fin then - let result = (^Awaiter : (member GetResult : unit -> 'TResult1)(awaiter)) - (continuation result).Invoke(&sm) - else - sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) - false - else - TaskBuilderBase.BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall>(&sm, task, continuation) - //-- RESUMABLE CODE END - ) - - [] - member inline this.ReturnFrom< ^TaskLike, ^Awaiter, 'T - when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'T)> - (task: ^TaskLike) : TaskCode< 'T, 'T> = - - this.Bind(task, (fun v -> this.Return v)) - - member inline _.Using<'Resource, 'TOverall, 'T when 'Resource :> IDisposable> (resource: 'Resource, body: 'Resource -> TaskCode<'TOverall, 'T>) = - ResumableCode.Using(resource, body) +namespace Microsoft.FSharp.Control.TaskBuilderExtensions - module HighPriority = - // High priority extensions - type TaskBuilderBase with - static member BindDynamic (sm: byref<_>, task: Task<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : bool = - let mutable awaiter = task.GetAwaiter() +open Microsoft.FSharp.Control +open System +open System.Runtime.CompilerServices +open System.Threading.Tasks +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Core.CompilerServices.StateMachineHelpers +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators + +module LowPriority = + // Low priority extensions + type TaskBuilderBase with + + [] + static member inline BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'TResult1)> + (sm: byref<_>, task: ^TaskLike, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : bool = + + let mutable awaiter = (^TaskLike: (member GetAwaiter : unit -> ^Awaiter)(task)) let cont = - (TaskResumptionFunc<'TOverall>(fun sm -> - let result = awaiter.GetResult() + (TaskResumptionFunc<'TOverall>( fun sm -> + let result = (^Awaiter : (member GetResult : unit -> 'TResult1)(awaiter)) (continuation result).Invoke(&sm))) // shortcut to continue immediately - if awaiter.IsCompleted then + if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then cont.Invoke(&sm) else sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) sm.ResumptionDynamicInfo.ResumptionFunc <- cont false - member inline _.Bind (task: Task<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = - - TaskCode<'TOverall, _>(fun sm -> - if __useResumableCode then - //-- RESUMABLE CODE START - // Get an awaiter from the task - let mutable awaiter = task.GetAwaiter() - - let mutable __stack_fin = true - if not awaiter.IsCompleted then - // This will yield with __stack_yield_fin = false - // This will resume with __stack_yield_fin = true - let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) - __stack_fin <- __stack_yield_fin - if __stack_fin then - let result = awaiter.GetResult() - (continuation result).Invoke(&sm) - else - sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) - false + [] + member inline _.Bind< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'TResult1)> + (task: ^TaskLike, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = + + TaskCode<'TOverall, _>(fun sm -> + if __useResumableCode then + //-- RESUMABLE CODE START + // Get an awaiter from the awaitable + let mutable awaiter = (^TaskLike: (member GetAwaiter : unit -> ^Awaiter)(task)) + + let mutable __stack_fin = true + if not (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then + // This will yield with __stack_yield_fin = false + // This will resume with __stack_yield_fin = true + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_fin <- __stack_yield_fin + + if __stack_fin then + let result = (^Awaiter : (member GetResult : unit -> 'TResult1)(awaiter)) + (continuation result).Invoke(&sm) else - TaskBuilderBase.BindDynamic(&sm, task, continuation) - //-- RESUMABLE CODE END - ) + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + false + else + TaskBuilderBase.BindDynamic< ^TaskLike, 'TResult1, 'TResult2, ^Awaiter , 'TOverall>(&sm, task, continuation) + //-- RESUMABLE CODE END + ) + + [] + member inline this.ReturnFrom< ^TaskLike, ^Awaiter, 'T + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T)> + (task: ^TaskLike) : TaskCode< 'T, 'T> = + + this.Bind(task, (fun v -> this.Return v)) + + member inline _.Using<'Resource, 'TOverall, 'T when 'Resource :> IDisposable> (resource: 'Resource, body: 'Resource -> TaskCode<'TOverall, 'T>) = + ResumableCode.Using(resource, body) + +module HighPriority = + // High priority extensions + type TaskBuilderBase with + static member BindDynamic (sm: byref<_>, task: Task<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : bool = + let mutable awaiter = task.GetAwaiter() + + let cont = + (TaskResumptionFunc<'TOverall>(fun sm -> + let result = awaiter.GetResult() + (continuation result).Invoke(&sm))) + + // shortcut to continue immediately + if awaiter.IsCompleted then + cont.Invoke(&sm) + else + sm.ResumptionDynamicInfo.ResumptionData <- (awaiter :> ICriticalNotifyCompletion) + sm.ResumptionDynamicInfo.ResumptionFunc <- cont + false + + member inline _.Bind (task: Task<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = + + TaskCode<'TOverall, _>(fun sm -> + if __useResumableCode then + //-- RESUMABLE CODE START + // Get an awaiter from the task + let mutable awaiter = task.GetAwaiter() + + let mutable __stack_fin = true + if not awaiter.IsCompleted then + // This will yield with __stack_yield_fin = false + // This will resume with __stack_yield_fin = true + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + __stack_fin <- __stack_yield_fin + if __stack_fin then + let result = awaiter.GetResult() + (continuation result).Invoke(&sm) + else + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + false + else + TaskBuilderBase.BindDynamic(&sm, task, continuation) + //-- RESUMABLE CODE END + ) - member inline this.ReturnFrom (task: Task<'T>) : TaskCode<'T, 'T> = - this.Bind(task, (fun v -> this.Return v)) + member inline this.ReturnFrom (task: Task<'T>) : TaskCode<'T, 'T> = + this.Bind(task, (fun v -> this.Return v)) - module MediumPriority = - open HighPriority +module MediumPriority = + open HighPriority - // Medium priority extensions - type TaskBuilderBase with - member inline this.Bind (computation: Async<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = - this.Bind (Async.StartAsTask computation, continuation) + // Medium priority extensions + type TaskBuilderBase with + member inline this.Bind (computation: Async<'TResult1>, continuation: ('TResult1 -> TaskCode<'TOverall, 'TResult2>)) : TaskCode<'TOverall, 'TResult2> = + this.Bind (Async.StartAsTask computation, continuation) - member inline this.ReturnFrom (computation: Async<'T>) : TaskCode<'T, 'T> = - this.ReturnFrom (Async.StartAsTask computation) + member inline this.ReturnFrom (computation: Async<'T>) : TaskCode<'T, 'T> = + this.ReturnFrom (Async.StartAsTask computation) #endif