diff --git a/src/fsharp/CheckComputationExpressions.fs b/src/fsharp/CheckComputationExpressions.fs index f9d051fdd7e..f43e3161ee1 100644 --- a/src/fsharp/CheckComputationExpressions.fs +++ b/src/fsharp/CheckComputationExpressions.fs @@ -1965,6 +1965,7 @@ let TcArrayOrListSequenceExpression (cenv: cenv) env overallTy tpenv (isArray, c let expr = if cenv.g.compilingFslib then + //warning(Error(FSComp.SR.fslibUsingComputedListOrArray(), expr.Range)) expr else // We add a call to 'seq ... ' to make sure sequence expression compilation gets applied to the contents of the diff --git a/src/fsharp/FSharp.Core/seqcore.fs b/src/fsharp/FSharp.Core/seqcore.fs index 7bcbb2ecaa5..c7ddba10ad0 100644 --- a/src/fsharp/FSharp.Core/seqcore.fs +++ b/src/fsharp/FSharp.Core/seqcore.fs @@ -347,6 +347,10 @@ namespace Microsoft.FSharp.Core.CompilerServices { 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>() = @@ -400,3 +404,110 @@ namespace Microsoft.FSharp.Core.CompilerServices 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 + + 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() + 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.Close() = + match this.Count with + | 0 -> Array.Empty<'T>() + | 1 -> + let res = [| this.First |] + this.First <- Unchecked.defaultof<_> + res + | 2 -> + let res = [| this.First; this.Second |] + this.First <- Unchecked.defaultof<_> + this.Second <- Unchecked.defaultof<_> + res + | _ -> + let res = this.ResizeArray.ToArray() + this <- ArrayCollector<'T>() + res + diff --git a/src/fsharp/FSharp.Core/seqcore.fsi b/src/fsharp/FSharp.Core/seqcore.fsi index d0eda5641fe..766a3026af4 100644 --- a/src/fsharp/FSharp.Core/seqcore.fsi +++ b/src/fsharp/FSharp.Core/seqcore.fsi @@ -149,3 +149,51 @@ namespace Microsoft.FSharp.Core.CompilerServices interface IEnumerator<'T> interface IEnumerator interface IDisposable + + [] + [] + [] + type ListCollector<'T> = + [] + val mutable internal Result: 'T list + + [] + val mutable internal LastCons: 'T list + + [] + [] + member Add: value: 'T -> unit + + [] + [] + member AddMany: values: seq<'T> -> unit + + [] + [] + member Close: unit -> 'T list + + [] + [] + [] + type ArrayCollector<'T> = + [] + val mutable internal ResizeArray: ResizeArray<'T> + [] + val mutable internal First: 'T + [] + val mutable internal Second: 'T + [] + val mutable internal Count: int + + [] + [] + member Add: value: 'T -> unit + + [] + [] + member AddMany: values: seq<'T> -> unit + + [] + [] + member Close: unit -> 'T[] + diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index ab3f72dfb15..c8d8b7d9422 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -2346,7 +2346,13 @@ and GenExprPreSteps (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = ProcessDebugPointForExpr cenv cgbuf sp expr - match (if compileSequenceExpressions then ConvertSequenceExprToObject g cenv.amap expr else None) with + match (if compileSequenceExpressions then LowerComputedListOrArrayExpr cenv.tcVal g cenv.amap expr else None) with + | Some altExpr -> + GenExpr cenv cgbuf eenv sp altExpr sequel + true + | None -> + + match (if compileSequenceExpressions && IsPossibleSequenceExpr g expr then ConvertSequenceExprToObject g cenv.amap expr else None) with | Some info -> GenSequenceExpr cenv cgbuf eenv info sequel true diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 15d75279006..9ef22d617f5 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -12,8 +12,11 @@ open FSharp.Compiler.ErrorLogger open FSharp.Compiler.InfoReader open FSharp.Compiler.Infos open FSharp.Compiler.MethodCalls +open FSharp.Compiler.NameResolution open FSharp.Compiler.Syntax +open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text +open FSharp.Compiler.TypeRelations open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps @@ -64,7 +67,7 @@ let LowerImplFile g assembly = let mkLambdaNoType g m uv e = mkLambda m uv (e, tyOfExpr g e) -let callNonOverloadedMethod g amap m methName ty args = +let callNonOverloadedILMethod g amap m methName ty args = match TryFindIntrinsicMethInfo (InfoReader(g, amap)) m AccessibleFromSomeFSharpCode methName ty with | [] -> error(InternalError("No method called '"+methName+"' was found", m)) | ILMeth(g, ilMethInfo, _) :: _ -> @@ -117,6 +120,74 @@ let (|Seq|_|) g expr = let IsPossibleSequenceExpr g overallExpr = match overallExpr with Seq g _ -> true | _ -> false +/// Detect a 'yield x' within a 'seq { ... }' +let (|SeqYield|_|) g expr = + match expr with + | ValApp g g.seq_singleton_vref (_, [arg], m) -> Some (arg, m) + | _ -> None + +/// Detect a 'expr; expr' within a 'seq { ... }' +let (|SeqAppend|_|) g expr = + match expr with + | ValApp g g.seq_append_vref (_, [arg1; arg2], m) -> Some (arg1, arg2, m) + | _ -> None + +/// Detect a 'while gd do expr' within a 'seq { ... }' +let (|SeqWhile|_|) g expr = + match expr with + | ValApp g g.seq_generated_vref (_, [Expr.Lambda (_, _, _, [dummyv], gd, _, _);arg2], m) + when not (isVarFreeInExpr dummyv gd) -> + Some (gd, arg2, m) + | _ -> + None + +let (|SeqTryFinally|_|) g expr = + match expr with + | ValApp g g.seq_finally_vref (_, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _)], m) + when not (isVarFreeInExpr dummyv compensation) -> + Some (arg1, compensation, m) + | _ -> + None + +let (|SeqUsing|_|) g expr = + match expr with + | ValApp g g.seq_using_vref ([_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, _, _)], m) -> + Some (resource, v, body, elemTy, m) + | _ -> + None + +let (|SeqFor|_|) g expr = + match expr with + // Nested for loops are represented by calls to Seq.collect + | ValApp g g.seq_collect_vref ([_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> + Some (inp, v, body, genElemTy, m) + // "for x in e -> e2" is converted to a call to Seq.map by the F# type checker. This could be removed, except it is also visible in F# quotations. + | ValApp g g.seq_map_vref ([_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> + Some (inp, v, mkCallSeqSingleton g body.Range genElemTy body, genElemTy, m) + | _ -> None + +let (|SeqDelay|_|) g expr = + match expr with + | ValApp g g.seq_delay_vref ([elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) + when not (isVarFreeInExpr v e) -> + Some (e, elemTy) + | _ -> None + +let (|SeqEmpty|_|) g expr = + match expr with + | ValApp g g.seq_empty_vref (_, [], m) -> Some (m) + | _ -> None + +let (|SeqToList|_|) g expr = + match expr with + | ValApp g g.seq_to_list_vref (_, [seqExpr], m) -> Some (seqExpr, m) + | _ -> None + +let (|SeqToArray|_|) g expr = + match expr with + | ValApp g g.seq_to_array_vref (_, [seqExpr], m) -> Some (seqExpr, m) + | _ -> None + /// Analyze a TAST expression to detect the elaborated form of a sequence expression. /// Then compile it to a state machine represented as a TAST containing goto, return and label nodes. /// The returned state machine will also contain references to state variables (from internal 'let' bindings), @@ -128,64 +199,6 @@ let IsPossibleSequenceExpr g overallExpr = /// We then allocate an integer pc for each state label and proceed with the second phase, which builds two related state machine /// expressions: one for 'MoveNext' and one for 'Dispose'. let ConvertSequenceExprToObject g amap overallExpr = - /// Detect a 'yield x' within a 'seq { ... }' - let (|SeqYield|_|) expr = - match expr with - | ValApp g g.seq_singleton_vref (_, [arg], m) -> Some (arg, m) - | _ -> None - - /// Detect a 'expr; expr' within a 'seq { ... }' - let (|SeqAppend|_|) expr = - match expr with - | ValApp g g.seq_append_vref (_, [arg1; arg2], m) -> Some (arg1, arg2, m) - | _ -> None - - /// Detect a 'while gd do expr' within a 'seq { ... }' - let (|SeqWhile|_|) expr = - match expr with - | ValApp g g.seq_generated_vref (_, [Expr.Lambda (_, _, _, [dummyv], gd, _, _);arg2], m) - when not (isVarFreeInExpr dummyv gd) -> - Some (gd, arg2, m) - | _ -> - None - - let (|SeqTryFinally|_|) expr = - match expr with - | ValApp g g.seq_finally_vref (_, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _)], m) - when not (isVarFreeInExpr dummyv compensation) -> - Some (arg1, compensation, m) - | _ -> - None - - let (|SeqUsing|_|) expr = - match expr with - | ValApp g g.seq_using_vref ([_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, _, _)], m) -> - Some (resource, v, body, elemTy, m) - | _ -> - None - - let (|SeqFor|_|) expr = - match expr with - // Nested for loops are represented by calls to Seq.collect - | ValApp g g.seq_collect_vref ([_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> - Some (inp, v, body, genElemTy, m) - // "for x in e -> e2" is converted to a call to Seq.map by the F# type checker. This could be removed, except it is also visible in F# quotations. - | ValApp g g.seq_map_vref ([_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> - Some (inp, v, mkCallSeqSingleton g body.Range genElemTy body, genElemTy, m) - | _ -> None - - let (|SeqDelay|_|) expr = - match expr with - | ValApp g g.seq_delay_vref ([elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) - when not (isVarFreeInExpr v e) -> - Some (e, elemTy) - | _ -> None - - let (|SeqEmpty|_|) expr = - match expr with - | ValApp g g.seq_empty_vref (_, [], m) -> Some (m) - | _ -> None - /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLocal (bind: Binding) res2 m = if verbose then @@ -246,7 +259,7 @@ let ConvertSequenceExprToObject g amap overallExpr = expr = match expr with - | SeqYield(e, m) -> + | SeqYield g (e, m) -> // printfn "found Seq.singleton" //this.pc <- NEXT //curr <- e @@ -275,12 +288,12 @@ let ConvertSequenceExprToObject g amap overallExpr = asyncVars = emptyFreeVars } - | SeqDelay(delayedExpr, _elemTy) -> + | SeqDelay g (delayedExpr, _elemTy) -> // printfn "found Seq.delay" // note, using 'isWholeExpr' here prevents 'seq { yield! e }' and 'seq { 0 .. 1000 }' from being compiled ConvertSeqExprCode isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr - | SeqAppend(e1, e2, m) -> + | SeqAppend g (e1, e2, m) -> // printfn "found Seq.append" let res1 = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 let res2 = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 @@ -310,7 +323,7 @@ let ConvertSequenceExprToObject g amap overallExpr = | _ -> None - | SeqWhile(guardExpr, bodyExpr, m) -> + | SeqWhile g (guardExpr, bodyExpr, m) -> // printfn "found Seq.while" let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr match resBody with @@ -334,7 +347,7 @@ let ConvertSequenceExprToObject g amap overallExpr = | _ -> None - | SeqUsing(resource, v, body, elemTy, m) -> + | SeqUsing g (resource, v, body, elemTy, m) -> // printfn "found Seq.using" let reduction = mkLet (DebugPointAtBinding.Yes body.Range) m v resource @@ -343,7 +356,7 @@ let ConvertSequenceExprToObject g amap overallExpr = (mkCallDispose g m v.Type (exprForVal m v)))) ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction - | SeqFor(inp, v, body, genElemTy, m) -> + | SeqFor g (inp, v, body, genElemTy, m) -> // printfn "found Seq.for" let inpElemTy = v.Type let inpEnumTy = mkIEnumeratorTy g inpElemTy @@ -353,14 +366,14 @@ let ConvertSequenceExprToObject g amap overallExpr = // let v = enum.Current // body ]] let reduction = - mkCallSeqUsing g m inpEnumTy genElemTy (callNonOverloadedMethod g amap m "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) + mkCallSeqUsing g m inpEnumTy genElemTy (callNonOverloadedILMethod g amap m "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) (mkLambdaNoType g m enumv - (mkCallSeqGenerated g m genElemTy (mkUnitDelayLambda g m (callNonOverloadedMethod g amap m "MoveNext" inpEnumTy [enume])) - (mkInvisibleLet m v (callNonOverloadedMethod g amap m "get_Current" inpEnumTy [enume]) + (mkCallSeqGenerated g m genElemTy (mkUnitDelayLambda g m (callNonOverloadedILMethod g amap m "MoveNext" inpEnumTy [enume])) + (mkInvisibleLet m v (callNonOverloadedILMethod g amap m "get_Current" inpEnumTy [enume]) (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) body)))) ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction - | SeqTryFinally(e1, compensation, m) -> + | SeqTryFinally g (e1, compensation, m) -> // printfn "found Seq.try/finally" let innerDisposeContinuationLabel = IL.generateCodeLabel() let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 @@ -407,7 +420,7 @@ let ConvertSequenceExprToObject g amap overallExpr = | _ -> None - | SeqEmpty m -> + | SeqEmpty g m -> // printfn "found Seq.empty" Some { phase2 = (fun _ -> let generate = mkUnit g m @@ -779,3 +792,204 @@ let ConvertSequenceExprToObject g amap overallExpr = | _ -> None +/// Build the 'test and dispose' part of a 'use' statement +let BuildDisposableCleanup tcVal (g: TcGlobals) infoReader m (v: Val) = + let disposeMethod = + match GetIntrinsicMethInfosOfType infoReader (Some "Dispose") AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m g.system_IDisposable_ty with + | [x] -> x + | _ -> error(InternalError(FSComp.SR.tcCouldNotFindIDisposable(), m)) + // For struct types the test is simpler + if isStructTy g v.Type then + assert (TypeFeasiblySubsumesType 0 g infoReader.amap m g.system_IDisposable_ty CanCoerce v.Type) + // We can use NeverMutates here because the variable is going out of scope, there is no need to take a defensive + // copy of it. + let disposeExpr, _ = BuildMethodCall tcVal g infoReader.amap NeverMutates m false disposeMethod NormalValUse [] [exprForVal v.Range v] [] + //callNonOverloadedILMethod g infoReader.amap m "Dispose" g.system_IDisposable_ty [exprForVal v.Range v] + + disposeExpr + else + let disposeObjVar, disposeObjExpr = mkCompGenLocal m "objectToDispose" g.system_IDisposable_ty + let disposeExpr, _ = BuildMethodCall tcVal g infoReader.amap PossiblyMutates m false disposeMethod NormalValUse [] [disposeObjExpr] [] + let inpe = mkCoerceExpr(exprForVal v.Range v, g.obj_ty, m, v.Type) + mkIsInstConditional g m g.system_IDisposable_ty inpe disposeObjVar disposeExpr (mkUnit g m) + +let mkCallCollectorMethod tcVal (g: TcGlobals) infoReader m name collExpr args = + let listCollectorTy = tyOfExpr g collExpr + let addMethod = + match GetIntrinsicMethInfosOfType infoReader (Some name) AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m listCollectorTy with + | [x] -> x + | _ -> error(InternalError("no " + name + " method found on Collector", m)) + let expr, _ = BuildMethodCall tcVal g infoReader.amap DefinitelyMutates m false addMethod NormalValUse [] [collExpr] args + expr + +let mkCallCollectorAdd tcVal (g: TcGlobals) infoReader m collExpr arg = + mkCallCollectorMethod tcVal g infoReader m "Add" collExpr [arg] + +let mkCallCollectorAddMany tcVal (g: TcGlobals) infoReader m collExpr arg = + mkCallCollectorMethod tcVal g infoReader m "AddMany" collExpr [arg] + +let mkCallCollectorClose tcVal (g: TcGlobals) infoReader m collExpr = + mkCallCollectorMethod tcVal g infoReader m "Close" collExpr [] + +let LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr = + let infoReader = InfoReader(g, amap) + let collVal, collExpr = mkMutableCompGenLocal m "@collector" collectorTy + //let collExpr = mkValAddr m false (mkLocalValRef collVal) + let rec ConvertSeqExprCode isWholeExpr expr = + match expr with + | SeqYield g (e, m) -> + mkCallCollectorAdd tcVal (g: TcGlobals) infoReader m collExpr e + |> Result.Ok + + | SeqDelay g (delayedExpr, _elemTy) -> + ConvertSeqExprCode isWholeExpr delayedExpr + + | SeqAppend g (e1, e2, m) -> + let res1 = ConvertSeqExprCode false e1 + let res2 = ConvertSeqExprCode false e2 + match res1, res2 with + | Result.Ok e1R, Result.Ok e2R -> + mkCompGenSequential m e1R e2R + |> Result.Ok + | Result.Error msg, _ | _, Result.Error msg -> Result.Error msg + + | SeqWhile g (guardExpr, bodyExpr, m) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + mkWhile g (DebugPointAtWhile.Yes guardExpr.Range, NoSpecialWhileLoopMarker, guardExpr, bodyExprR, m) + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | SeqUsing g (resource, v, bodyExpr, _elemTy, m) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + // printfn "found Seq.using" + let cleanupE = BuildDisposableCleanup tcVal g infoReader m v + mkLet (DebugPointAtBinding.Yes bodyExpr.Range) m v resource + (mkTryFinally g (bodyExprR, cleanupE, m, tyOfExpr g bodyExpr, DebugPointAtTry.Body, DebugPointAtFinally.No)) + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | SeqFor g (inp, v, bodyExpr, _genElemTy, m) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + // printfn "found Seq.for" + let inpElemTy = v.Type + let inpEnumTy = mkIEnumeratorTy g inpElemTy + let enumv, enumve = mkCompGenLocal m "enum" inpEnumTy + let guardExpr = callNonOverloadedILMethod g amap m "MoveNext" inpEnumTy [enumve] + let cleanupE = BuildDisposableCleanup tcVal g infoReader m enumv + mkInvisibleLet m enumv (callNonOverloadedILMethod g amap m "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) + (mkTryFinally g + (mkWhile g (DebugPointAtWhile.Yes guardExpr.Range, NoSpecialWhileLoopMarker, guardExpr, + (mkInvisibleLet m v + (callNonOverloadedILMethod g amap m "get_Current" inpEnumTy [enumve])) + bodyExprR, m), + cleanupE, m, tyOfExpr g bodyExpr, DebugPointAtTry.Body, DebugPointAtFinally.No)) + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | SeqTryFinally g (bodyExpr, compensation, m) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + mkTryFinally g (bodyExprR, compensation, m, tyOfExpr g bodyExpr, DebugPointAtTry.Body, DebugPointAtFinally.No) + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | SeqEmpty g m -> + mkUnit g m |> Result.Ok + + | Expr.Sequential (x1, bodyExpr, NormalSeq, ty, m) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + Expr.Sequential (x1, bodyExprR, NormalSeq, ty, m) + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | Expr.Let (bind, bodyExpr, m, _) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + mkLetBind m bind bodyExprR + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | Expr.LetRec (binds, bodyExpr, m, _) -> + let resBody = ConvertSeqExprCode false bodyExpr + match resBody with + | Result.Ok bodyExprR -> + mkLetRecBinds m binds bodyExprR + |> Result.Ok + | Result.Error msg -> Result.Error msg + + | Expr.Match (spBind, exprm, pt, targets, m, ty) -> + // lower all the targets. abandon if any fail to lower + let resTargets = + targets |> Array.map (fun (TTarget(vs, targetExpr, spTarget, m)) -> + match ConvertSeqExprCode false targetExpr with + | Result.Ok targetExprR -> + Result.Ok (TTarget(vs, targetExprR, spTarget, m)) + | Result.Error msg -> Result.Error msg ) + if resTargets |> Array.forall (function Result.Ok _ -> true | _ -> false) then + let tglArray = Array.map (function Result.Ok v -> v | _ -> failwith "unreachable") resTargets + + primMkMatch (spBind, exprm, pt, tglArray, m, ty) + |> Result.Ok + else + resTargets |> Array.pick (function Result.Error msg -> Some (Result.Error msg) | _ -> None) + + // yield! e ---> (for x in e -> x) + + | arbitrarySeqExpr -> + let m = arbitrarySeqExpr.Range + if isWholeExpr then + // printfn "FAILED - not worth compiling an unrecognized Seq.toList at %s " (stringOfRange m) + Result.Error () + else + mkCallCollectorAdd tcVal (g: TcGlobals) infoReader m collExpr arbitrarySeqExpr + |> Result.Ok + + // Perform conversion + match ConvertSeqExprCode true overallSeqExpr with + | Result.Ok overallSeqExprR -> + mkInvisibleLet m collVal (mkDefault (m, collectorTy)) + (mkCompGenSequential m + overallSeqExprR + (mkCallCollectorClose tcVal g infoReader m collExpr)) + |> Some + | Result.Error () -> + None + +let (|OptionalCoerce|) expr = + match expr with + | Expr.Op (TOp.Coerce, _, [arg], _) -> arg + | _ -> expr + +// Making 'seq' optional means this kicks in for FSharp.Core, see TcArrayOrListSequenceExpression +// which only adds a 'seq' call outside of FSharp.Core +let (|OptionalSeq|) g expr = + match expr with + // use 'seq { ... }' as an indicator + | Seq g (e, elemTy) -> e, elemTy + | _ -> expr, (argsOfAppTy g (tyOfExpr g expr)).[0] + +let LowerComputedListOrArrayExpr tcVal (g: TcGlobals) amap overallExpr = + // If ListCollector is in FSharp.Core then this optimization kicks in + if g.ListCollector_tcr.CanDeref then + + match overallExpr with + | SeqToList g (OptionalCoerce (OptionalSeq g (overallSeqExpr, overallElemTy)), m) -> + let collectorTy = g.mk_ListCollector_ty overallElemTy + LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr + + | SeqToArray g (OptionalCoerce (OptionalSeq g (overallSeqExpr, overallElemTy)), m) -> + let collectorTy = g.mk_ArrayCollector_ty overallElemTy + LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr + | _ -> None + else + None diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index c4443f34229..10a5e26550a 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -3,6 +3,7 @@ module internal FSharp.Compiler.LowerCallsAndSeqs open FSharp.Compiler.Import +open FSharp.Compiler.InfoReader open FSharp.Compiler.TcGlobals open FSharp.Compiler.TypedTree open FSharp.Compiler.Text @@ -22,3 +23,5 @@ val LowerImplFile: g: TcGlobals -> assembly: TypedImplFile -> TypedImplFile val ConvertSequenceExprToObject: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRef * ValRef * ValRef * ValRef list * Expr * Expr * Expr * TType * range) option val IsPossibleSequenceExpr: g: TcGlobals -> overallExpr: Expr -> bool + +val LowerComputedListOrArrayExpr: tcVal: ConstraintSolver.TcValF -> g: TcGlobals -> amap: ImportMap -> Expr -> Expr option diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index dd4bf222c0d..802d551fb85 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -996,6 +996,15 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d member _.fslib_IDelegateEvent_tcr = v_fslib_IDelegateEvent_tcr member _.seq_tcr = v_seq_tcr member val seq_base_tcr = mk_MFCompilerServices_tcref fslibCcu "GeneratedSequenceBase`1" + member val ListCollector_tcr = mk_MFCompilerServices_tcref fslibCcu "ListCollector`1" + member val ArrayCollector_tcr = mk_MFCompilerServices_tcref fslibCcu "ArrayCollector`1" + member g.mk_GeneratedSequenceBase_ty seqElemTy = TType_app(g.seq_base_tcr,[seqElemTy]) + member g.mk_ListCollector_ty seqElemTy = TType_app(g.ListCollector_tcr,[seqElemTy]) + member g.mk_ArrayCollector_ty seqElemTy = TType_app(g.ArrayCollector_tcr,[seqElemTy]) + member val ResumableStateMachine_tcr = mk_MFCompilerServices_tcref fslibCcu "ResumableStateMachine`1" + member g.mk_ResumableStateMachine_ty dataTy = TType_app(g.ResumableStateMachine_tcr,[dataTy]) + member val IResumableStateMachine_tcr = mk_MFCompilerServices_tcref fslibCcu "IResumableStateMachine`1" + member g.mk_IResumableStateMachine_ty dataTy = TType_app(g.IResumableStateMachine_tcr,[dataTy]) member val byrefkind_In_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "In" member val byrefkind_Out_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "Out" member val byrefkind_InOut_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "InOut" @@ -1418,6 +1427,8 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d member val query_select_vref = ValRefForIntrinsic v_query_select_value_info member val query_where_vref = ValRefForIntrinsic v_query_where_value_info member val query_zero_vref = ValRefForIntrinsic v_query_zero_value_info + member val seq_to_list_vref = ValRefForIntrinsic v_seq_to_list_info + member val seq_to_array_vref = ValRefForIntrinsic v_seq_to_array_info member _.seq_collect_info = v_seq_collect_info member _.seq_using_info = v_seq_using_info