diff --git a/docs/release-notes/.FSharp.Compiler.Service/10.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/10.0.100.md index ae61141b5a..7256a47504 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/10.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/10.0.100.md @@ -1,6 +1,7 @@ ### Added * Add opt-in warning attribute not valid for union case with fields [PR #18532](https://github.com/dotnet/fsharp/pull/18532)) * Add support for `when 'T : Enum` library-only static optimization constraint. ([PR #18546](https://github.com/dotnet/fsharp/pull/18546)) +* Add support for tail calls in computation expressions ([PR #18804](https://github.com/dotnet/fsharp/pull/18804)) * Add `--typecheck-only` flag support for F# Interactive (FSI) scripts to type-check without execution. ([Issue #18686](https://github.com/dotnet/fsharp/issues/18686)) ### Fixed diff --git a/docs/release-notes/.Language/preview.md b/docs/release-notes/.Language/preview.md index 7b9b498baa..b9afee7582 100644 --- a/docs/release-notes/.Language/preview.md +++ b/docs/release-notes/.Language/preview.md @@ -10,6 +10,7 @@ * Scoped Nowarn: added the #warnon compiler directive ([Language suggestion #278](https://github.com/fsharp/fslang-suggestions/issues/278), [RFC FS-1146 PR](https://github.com/fsharp/fslang-design/pull/782), [PR #18049](https://github.com/dotnet/fsharp/pull/18049)) * Allow `let!`, `use!`, `and!` type annotations without requiring parentheses (([PR #18508](https://github.com/dotnet/fsharp/pull/18508) and [PR #18682](https://github.com/dotnet/fsharp/pull/18682))) * Exception names are now validated for illegal characters using the same mechanism as types/modules/namespaces ([Issue #18763](https://github.com/dotnet/fsharp/issues/18763)) +* Support tail calls in computation expressions ([PR #18804](https://github.com/dotnet/fsharp/pull/18804)) ### Fixed diff --git a/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs b/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs index 7f1be3d7bc..799fef2a03 100644 --- a/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs @@ -56,12 +56,15 @@ type ComputationExpressionContext<'a> = ad: AccessorDomain builderTy: TType isQuery: bool + tailCall: bool enableImplicitYield: bool origComp: SynExpr mWhole: range emptyVarSpace: LazyWithContext * TcEnv, range> } +let inline noTailCall ceenv = { ceenv with tailCall = false } + let inline TryFindIntrinsicOrExtensionMethInfo collectionSettings (cenv: cenv) (env: TcEnv) m ad nm ty = AllMethInfosOfTypeInScope collectionSettings cenv.infoReader env.NameEnv (Some nm) ad IgnoreOverrides m ty @@ -939,9 +942,15 @@ let inline addVarsToVarSpace (varSpace: LazyWithContext id ) +let tryFindBuilderMethod (ceenv: ComputationExpressionContext<_>) (m: range) (methodName: string) = + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult ceenv.cenv ceenv.env m ceenv.ad methodName ceenv.builderTy + +let hasBuilderMethod ceenv m methodName = + tryFindBuilderMethod ceenv m methodName |> isNil |> not + /// Checks if a builder method exists and reports an error if it doesn't -let requireBuilderMethod methodName m1 cenv env ad builderTy m2 = - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m1 ad methodName builderTy) then +let requireBuilderMethod methodName ceenv m1 m2 = + if not (hasBuilderMethod ceenv m1 methodName) then error (Error(FSComp.SR.tcRequireBuilderMethod methodName, m2)) /// @@ -1245,7 +1254,7 @@ let rec TryTranslateComputationExpression let mPat = pat.Range - requireBuilderMethod "For" mFor cenv ceenv.env ceenv.ad ceenv.builderTy mFor + requireBuilderMethod "For" ceenv mFor mFor // Add the variables to the query variable space, on demand let varSpace = @@ -1306,7 +1315,7 @@ let rec TryTranslateComputationExpression let reduced = elimFastIntegerForLoop (spFor, spTo, id, start, dir, finish, innerComp, m) - Some(TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace reduced translatedCtxt) + Some(TranslateComputationExpression (noTailCall ceenv) CompExprTranslationPass.Initial q varSpace reduced translatedCtxt) | SynExpr.While(spWhile, guardExpr, innerComp, _) -> let mGuard = guardExpr.Range @@ -1318,8 +1327,8 @@ let rec TryTranslateComputationExpression if ceenv.isQuery then error (Error(FSComp.SR.tcNoWhileInQuery (), mWhile)) - requireBuilderMethod "While" mWhile cenv ceenv.env ceenv.ad ceenv.builderTy mWhile - requireBuilderMethod "Delay" mWhile cenv ceenv.env ceenv.ad ceenv.builderTy mWhile + requireBuilderMethod "While" ceenv mWhile mWhile + requireBuilderMethod "Delay" ceenv mWhile mWhile // 'while' is hit just before each time the guard is called let guardExpr = @@ -1328,7 +1337,7 @@ let rec TryTranslateComputationExpression | DebugPointAtWhile.No -> guardExpr Some( - TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> + TranslateComputationExpression (noTailCall ceenv) CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> translatedCtxt ( mkSynCall "While" @@ -1448,10 +1457,11 @@ let rec TryTranslateComputationExpression if ceenv.isQuery then error (Error(FSComp.SR.tcNoTryFinallyInQuery (), mTry)) - requireBuilderMethod "TryFinally" mTry cenv ceenv.env ceenv.ad ceenv.builderTy mTry - requireBuilderMethod "Delay" mTry cenv ceenv.env ceenv.ad ceenv.builderTy mTry + requireBuilderMethod "TryFinally" ceenv mTry mTry + requireBuilderMethod "Delay" ceenv mTry mTry - let innerExpr = TranslateComputationExpressionNoQueryOps ceenv innerComp + let innerExpr = + TranslateComputationExpressionNoQueryOps (noTailCall ceenv) innerComp let innerExpr = match spTry with @@ -1479,19 +1489,7 @@ let rec TryTranslateComputationExpression // will be checked/reported appropriately (though the error message won't mention computation expressions // like our other error messages for missing methods). | SynExpr.ImplicitZero m -> - if - (not ceenv.enableImplicitYield) - && isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - cenv - ceenv.env - m - ceenv.ad - "Zero" - ceenv.builderTy - ) - then + if (not ceenv.enableImplicitYield) && not (hasBuilderMethod ceenv m "Zero") then match ceenv.origComp with // builder { } // @@ -1573,7 +1571,7 @@ let rec TryTranslateComputationExpression match TryTranslateComputationExpression - ceenv + (noTailCall ceenv) CompExprTranslationPass.Initial CustomOperationsMode.Denied varSpace @@ -1590,8 +1588,8 @@ let rec TryTranslateComputationExpression | SynExpr.YieldOrReturnFrom(trivia = yieldOrReturnFrom) -> yieldOrReturnFrom.YieldOrReturnFromKeyword | expr -> expr.Range - requireBuilderMethod "Combine" m cenv ceenv.env ceenv.ad ceenv.builderTy combineDelayRange - requireBuilderMethod "Delay" m cenv ceenv.env ceenv.ad ceenv.builderTy combineDelayRange + requireBuilderMethod "Combine" ceenv m combineDelayRange + requireBuilderMethod "Delay" ceenv m combineDelayRange let combineCall = mkSynCall @@ -1694,7 +1692,7 @@ let rec TryTranslateComputationExpression ) | None -> let elseComp = - requireBuilderMethod "Zero" trivia.IfToThenRange cenv ceenv.env ceenv.ad ceenv.builderTy trivia.IfToThenRange + requireBuilderMethod "Zero" ceenv trivia.IfToThenRange trivia.IfToThenRange mkSynCall "Zero" trivia.IfToThenRange [] ceenv.builderValName @@ -1772,7 +1770,7 @@ let rec TryTranslateComputationExpression innerCompRange ) - requireBuilderMethod "Using" mBind cenv ceenv.env ceenv.ad ceenv.builderTy mBind + requireBuilderMethod "Using" ceenv mBind mBind Some( translatedCtxt (mkSynCall "Using" mBind [ rhsExpr; consumeExpr ] ceenv.builderValName) @@ -1787,8 +1785,8 @@ let rec TryTranslateComputationExpression match andBangs with | [] -> // Valid pattern case - handle with Using + Bind - requireBuilderMethod "Using" mBind cenv ceenv.env ceenv.ad ceenv.builderTy mBind - requireBuilderMethod "Bind" mBind cenv ceenv.env ceenv.ad ceenv.builderTy mBind + requireBuilderMethod "Using" ceenv mBind mBind + requireBuilderMethod "Bind" ceenv mBind mBind let supportsUseBangBindingValueDiscard = ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.UseBangBindingValueDiscard @@ -1933,19 +1931,7 @@ let rec TryTranslateComputationExpression let bindNName = "Bind" + string numSources // Check if this is a Bind2Return etc. - let hasBindReturnN = - not ( - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - cenv - ceenv.env - mBind - ceenv.ad - bindReturnNName - ceenv.builderTy - ) - ) + let hasBindReturnN = hasBuilderMethod ceenv mBind bindReturnNName if hasBindReturnN @@ -1979,19 +1965,7 @@ let rec TryTranslateComputationExpression ) else // Check if this is a Bind2 etc. - let hasBindN = - not ( - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - cenv - ceenv.env - mBind - ceenv.ad - bindNName - ceenv.builderTy - ) - ) + let hasBindN = hasBuilderMethod ceenv mBind bindNName if hasBindN then let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) @@ -2032,18 +2006,7 @@ let rec TryTranslateComputationExpression let rec loop (n: int) = let mergeSourcesName = mkMergeSourcesName n - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - cenv - ceenv.env - mBind - ceenv.ad - mergeSourcesName - ceenv.builderTy - ) - then + if not (hasBuilderMethod ceenv mBind mergeSourcesName) then (n - 1) else loop (n + 1) @@ -2065,7 +2028,7 @@ let rec TryTranslateComputationExpression // Call MergeSources2(e1, e2), MergeSources3(e1, e2, e3) etc let mergeSourcesName = mkMergeSourcesName numSourcesAndPats - requireBuilderMethod mergeSourcesName mBind cenv ceenv.env ceenv.ad ceenv.builderTy mBind + requireBuilderMethod mergeSourcesName ceenv mBind mBind let source = mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) ceenv.builderValName @@ -2081,7 +2044,7 @@ let rec TryTranslateComputationExpression let mergeSourcesName = mkMergeSourcesName maxMergeSources - requireBuilderMethod mergeSourcesName mBind cenv ceenv.env ceenv.ad ceenv.builderTy mBind + requireBuilderMethod mergeSourcesName ceenv mBind mBind let laterSource, laterPat = mergeSources laterSourcesAndPats @@ -2144,7 +2107,7 @@ let rec TryTranslateComputationExpression if ceenv.isQuery then error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchBangKeyword)) - requireBuilderMethod "Bind" trivia.MatchBangKeyword cenv ceenv.env ceenv.ad ceenv.builderTy trivia.MatchBangKeyword + requireBuilderMethod "Bind" ceenv trivia.MatchBangKeyword trivia.MatchBangKeyword let clauses = clauses @@ -2182,10 +2145,11 @@ let rec TryTranslateComputationExpression let consumeExpr = SynExpr.MatchLambda(true, mTryToLast, clauses, spWith2, mTryToLast) - requireBuilderMethod "TryWith" mTry cenv ceenv.env ceenv.ad ceenv.builderTy mTry - requireBuilderMethod "Delay" mTry cenv ceenv.env ceenv.ad ceenv.builderTy mTry + requireBuilderMethod "TryWith" ceenv mTry mTry + requireBuilderMethod "Delay" ceenv mTry mTry - let innerExpr = TranslateComputationExpressionNoQueryOps ceenv innerComp + let innerExpr = + TranslateComputationExpressionNoQueryOps (noTailCall ceenv) innerComp let innerExpr = match spTry with @@ -2208,10 +2172,19 @@ let rec TryTranslateComputationExpression let yieldFromExpr = mkSourceExpr synYieldExpr ceenv.sourceMethInfo ceenv.builderValName - requireBuilderMethod "YieldFrom" m cenv ceenv.env ceenv.ad ceenv.builderTy m + let yieldFromMethodName = + if + ceenv.tailCall + && ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.ReturnFromFinal + && hasBuilderMethod ceenv m "YieldFromFinal" + then + "YieldFromFinal" + else + requireBuilderMethod "YieldFrom" ceenv m m + "YieldFrom" let yieldFromCall = - mkSynCall "YieldFrom" synYieldExpr.Range [ yieldFromExpr ] ceenv.builderValName + mkSynCall yieldFromMethodName synYieldExpr.Range [ yieldFromExpr ] ceenv.builderValName let yieldFromCall = if IsControlFlowExpression synYieldExpr then @@ -2228,10 +2201,19 @@ let rec TryTranslateComputationExpression if ceenv.isQuery then error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) - requireBuilderMethod "ReturnFrom" m cenv ceenv.env ceenv.ad ceenv.builderTy m + let returnFromMethodName = + if + ceenv.tailCall + && ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.ReturnFromFinal + && hasBuilderMethod ceenv m "ReturnFromFinal" + then + "ReturnFromFinal" + else + requireBuilderMethod "ReturnFrom" ceenv m m + "ReturnFrom" let returnFromCall = - mkSynCall "ReturnFrom" synReturnExpr.Range [ returnFromExpr ] ceenv.builderValName + mkSynCall returnFromMethodName synReturnExpr.Range [ returnFromExpr ] ceenv.builderValName let returnFromCall = if IsControlFlowExpression synReturnExpr then @@ -2247,7 +2229,7 @@ let rec TryTranslateComputationExpression if ceenv.isQuery && not isYield then error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) - requireBuilderMethod methName m cenv ceenv.env ceenv.ad ceenv.builderTy m + requireBuilderMethod methName ceenv m m let yieldOrReturnCall = mkSynCall methName synYieldOrReturnExpr.Range [ synYieldOrReturnExpr ] ceenv.builderValName @@ -2475,23 +2457,7 @@ and TranslateComputationExpressionBind None match innerCompReturn with - | Some(innerExpr, customOpInfo) when - (let bindName = bindName + "Return" - - not ( - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - ceenv.cenv - ceenv.env - bindRange - ceenv.ad - bindName - ceenv.builderTy - ) - )) - -> - + | Some(innerExpr, customOpInfo) when hasBuilderMethod ceenv bindRange (bindName + "Return") -> let bindName = bindName + "Return" // Build the `BindReturn` call @@ -2517,7 +2483,7 @@ and TranslateComputationExpressionBind | _ -> - requireBuilderMethod bindName bindRange ceenv.cenv ceenv.env ceenv.ad ceenv.builderTy bindRange + requireBuilderMethod bindName ceenv bindRange bindRange // Build the `Bind` call TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> @@ -2649,6 +2615,22 @@ and TranslateComputationExpression (ceenv: ComputationExpressionContext<'a>) fir | None -> // This only occurs in final position in a sequence match comp with + // "do! expr;" in tail call position is treated as { return! expr } when ReturnFromFinal is provided + | SynExpr.DoBang(rhsExpr, m, _) when ceenv.tailCall && ((hasBuilderMethod ceenv m "ReturnFromFinal")) -> + let returnFrom = + // Flags indicate isTrueYield, isTrueReturn + SynExpr.YieldOrReturnFrom((false, true), rhsExpr, m, SynExprYieldOrReturnFromTrivia.Zero) + + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace returnFrom translatedCtxt + + // "do! expr;" in tail call position is treated as { yield! expr } when YieldFromFinal is provided + | SynExpr.DoBang(rhsExpr, m, _) when ceenv.tailCall && ((hasBuilderMethod ceenv m "YieldFromFinal")) -> + let returnFrom = + // Flags indicate isTrueYield, isTrueReturn + SynExpr.YieldOrReturnFrom((true, false), rhsExpr, m, SynExprYieldOrReturnFromTrivia.Zero) + + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace returnFrom translatedCtxt + // "do! expr;" in final position is treated as { let! () = expr in return () } when Return is provided (and no Zero with Default attribute is available) or as { let! () = expr in zero } otherwise | SynExpr.DoBang(expr = rhsExpr; trivia = { DoBangKeyword = m }) -> let mUnit = rhsExpr.Range @@ -2658,30 +2640,10 @@ and TranslateComputationExpression (ceenv: ComputationExpressionContext<'a>) fir error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), m)) let bodyExpr = - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - ceenv.cenv - ceenv.env - m - ceenv.ad - "Return" - ceenv.builderTy - ) - then + if not (hasBuilderMethod ceenv m "Return") then SynExpr.ImplicitZero m else - match - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - ceenv.cenv - ceenv.env - m - ceenv.ad - "Zero" - ceenv.builderTy - with + match tryFindBuilderMethod ceenv m "Zero" with | minfo :: _ when MethInfoHasAttribute ceenv.cenv.g m ceenv.cenv.g.attrib_DefaultValueAttribute minfo -> SynExpr.ImplicitZero m | _ -> SynExpr.YieldOrReturn((false, true), SynExpr.Const(SynConst.Unit, m), m, SynExprYieldOrReturnTrivia.Zero) @@ -2832,6 +2794,7 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv ad = ad builderTy = builderTy isQuery = isQuery + tailCall = not isQuery enableImplicitYield = enableImplicitYield origComp = origComp mWhole = mWhole @@ -2868,7 +2831,7 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv // Add a call to 'Delay' if the method is present let delayedExpr = - match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Delay" builderTy with + match tryFindBuilderMethod ceenv mBuilderVal "Delay" with | [] -> basicSynExpr | _ -> mkSynCall "Delay" mDelayOrQuoteOrRun [ (mkSynDelay2 basicSynExpr) ] builderValName @@ -2881,7 +2844,7 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv // Add a call to 'Run' if the method is present let runExpr = - match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Run" builderTy with + match tryFindBuilderMethod ceenv mBuilderVal "Run" with | [] -> quotedSynExpr | _ -> mkSynCall "Run" mDelayOrQuoteOrRun [ quotedSynExpr ] builderValName diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 6a24337352..1f2dc3cfb3 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1807,4 +1807,5 @@ featureAllowLetOrUseBangTypeAnnotationWithoutParens,"Allow let! and use! type an 3875,lexWarnDirectiveMustHaveArgs,"Warn directives must have warning number(s) as argument(s)" 3876,lexWarnDirectivesMustMatch,"There is another %s for this warning already in line %d." 3877,lexLineDirectiveMappingIsNotUnique,"The file '%s' was also pointed to in a line directive in '%s'. Proper warn directive application may not be possible." -3878,tcAttributeIsNotValidForUnionCaseWithFields,"This attribute is not valid for use on union cases with fields." \ No newline at end of file +3878,tcAttributeIsNotValidForUnionCaseWithFields,"This attribute is not valid for use on union cases with fields." +featureReturnFromFinal,"Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder." diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index a3a9a3855a..9e57e5b96a 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -103,6 +103,7 @@ type LanguageFeature = | BetterAnonymousRecordParsing | ScopedNowarn | AllowTypedLetUseAndBang + | ReturnFromFinal /// LanguageVersion management type LanguageVersion(versionText) = @@ -238,6 +239,7 @@ type LanguageVersion(versionText) = LanguageFeature.AllowTypedLetUseAndBang, languageVersion100 LanguageFeature.UnmanagedConstraintCsharpInterop, languageVersion100 LanguageFeature.AllowAccessModifiersToAutoPropertiesGettersAndSetters, languageVersion100 + LanguageFeature.ReturnFromFinal, languageVersion100 // F# preview (still preview in 10.0) LanguageFeature.FromEndSlicing, previewVersion // Unfinished features --- needs work @@ -409,6 +411,7 @@ type LanguageVersion(versionText) = | LanguageFeature.BetterAnonymousRecordParsing -> FSComp.SR.featureBetterAnonymousRecordParsing () | LanguageFeature.ScopedNowarn -> FSComp.SR.featureScopedNowarn () | LanguageFeature.AllowTypedLetUseAndBang -> FSComp.SR.featureAllowLetOrUseBangTypeAnnotationWithoutParens () + | LanguageFeature.ReturnFromFinal -> FSComp.SR.featureReturnFromFinal () /// Get a version string associated with the given feature. static member GetFeatureVersionString feature = diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi index f034979a6d..2e123eb159 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -94,6 +94,7 @@ type LanguageFeature = | BetterAnonymousRecordParsing | ScopedNowarn | AllowTypedLetUseAndBang + | ReturnFromFinal /// LanguageVersion management type LanguageVersion = diff --git a/src/Compiler/SyntaxTree/SyntaxTrivia.fsi b/src/Compiler/SyntaxTree/SyntaxTrivia.fsi index ee139be061..c690a6ac01 100644 --- a/src/Compiler/SyntaxTree/SyntaxTrivia.fsi +++ b/src/Compiler/SyntaxTree/SyntaxTrivia.fsi @@ -186,6 +186,8 @@ type SynExprYieldOrReturnFromTrivia = YieldOrReturnFromKeyword: range } + static member Zero: SynExprYieldOrReturnFromTrivia + /// Represents additional information for SynExpr.AnonRecd [] type SynExprAnonRecdTrivia = diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index 1b8318e124..7333400397 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -602,6 +602,11 @@ obnovitelné stavové stroje + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Sdílení podkladových polí v rozlišeném sjednocení [<Struct>] za předpokladu, že mají stejný název a typ diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index b1045b1882..ea6271cfbc 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -602,6 +602,11 @@ Fortsetzbarer Zustand-Maschinen + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Teilen sie zugrunde liegende Felder in einen [<Struct>]-diskriminierten Union, solange sie denselben Namen und Typ aufweisen. diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index c76e6d0bca..6abcce332e 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -602,6 +602,11 @@ máquinas de estado reanudables + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Compartir campos subyacentes en una unión discriminada [<Struct>] siempre y cuando tengan el mismo nombre y tipo diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index aa49f56b95..4eb06dccb1 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -602,6 +602,11 @@ ordinateurs d’état pouvant être repris + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Partager les champs sous-jacents dans une union discriminée [<Struct>] tant qu’ils ont le même nom et le même type diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 89dacdf42a..4e48e1db28 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -602,6 +602,11 @@ macchine a stati ripristinabili + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Condividi i campi sottostanti in un'unione discriminata di [<Struct>] purché abbiano lo stesso nome e tipo diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 42955cb462..295256c5cf 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -602,6 +602,11 @@ 再開可能なステート マシン + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type 名前と型が同じである限り、[<Struct>] 判別可能な共用体で基になるフィールドを共有する diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 56628072e0..7ab04d5a12 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -602,6 +602,11 @@ 다시 시작 가능한 상태 시스템 + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type 이름과 형식이 같으면 [<Struct>] 구분된 공용 구조체에서 기본 필드 공유 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 4cee71af6e..b31f408307 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -602,6 +602,11 @@ automaty stanów z możliwością wznowienia + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Udostępnij pola źródłowe w unii rozłącznej [<Struct>], o ile mają taką samą nazwę i ten sam typ diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 44685a5bf8..3e544e2f90 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -602,6 +602,11 @@ máquinas de estado retomável + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Compartilhar campos subjacentes em uma união discriminada [<Struct>], desde que tenham o mesmo nome e tipo diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index c9056c0105..75f9c8dadc 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -602,6 +602,11 @@ возобновляемые конечные автоматы + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Совместное использование базовых полей в дискриминируемом объединении [<Struct>], если они имеют одинаковое имя и тип. diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index e39ae57407..66166fd902 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -602,6 +602,11 @@ sürdürülebilir durum makineleri + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type Aynı ada ve türe sahip oldukları sürece temel alınan alanları [<Struct>] ayırt edici birleşim biçiminde paylaşın diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 08d5772f30..50981ab1e9 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -602,6 +602,11 @@ 可恢复状态机 + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type 只要它们具有相同的名称和类型，即可在 [<Struct>] 中共享基础字段 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 4e6690ce1f..aa2c95dbd4 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -602,6 +602,11 @@ 可繼續的狀態機器 + + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + Support for ReturnFromFinal/YieldFromFinal in computation expressions to enable tailcall optimization when available on the builder. + + Share underlying fields in a [<Struct>] discriminated union as long as they have same name and type 只要 [<Struct>] 具有相同名稱和類型，就以強制聯集共用基礎欄位 diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ComputationExpressionTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ComputationExpressionTests.fs index d7a6d34299..16403bda78 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ComputationExpressionTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ComputationExpressionTests.fs @@ -4,6 +4,7 @@ namespace Language open Xunit open FSharp.Test.Compiler +open FSharp.Test module ComputationExpressionTests = [] @@ -2028,4 +2029,20 @@ match test() with |> withLangVersionPreview |> asExe |> compileAndRun - |> shouldSucceed \ No newline at end of file + |> shouldSucceed + + [] + let ``tail call methods work`` compilation = + compilation + |> getCompilation + |> asFsx + |> runFsi + |> shouldSucceed + + [] + let ``YieldFromFinal works in coroutines`` compilation = + compilation + |> getCompilation + |> asFsx + |> runFsi + |> shouldSucceed \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/Language/coroutines.fsx b/tests/FSharp.Compiler.ComponentTests/Language/coroutines.fsx new file mode 100644 index 0000000000..d66b1699cb --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/coroutines.fsx @@ -0,0 +1,402 @@ + + +// This is a sample and test showing how to use resumable code to implement +// coroutines with tailcall support +// +// A coroutine is a value of type Coroutine normally constructed using this form: +// +// coroutine { +// printfn "in t1" +// yield () +// printfn "hey" +// } +// + +// Support for tailcalls is provided by the mechanism od detecting tail calls in computation expressions. +// in tail call positions, YieldFromFinal is generated for the yield! keyword. + +#nowarn 3513 +#nowarn 3514 + +open System +open System.Runtime.CompilerServices +open FSharp.Core.CompilerServices +open FSharp.Core.CompilerServices.StateMachineHelpers +open FSharp.Core.LanguagePrimitives.IntrinsicOperators +open FSharp.Collections + +let mutable yieldFromFinalCallCount = 0 +let mutable yieldFromCount = 0 + +let verbose = false + +/// Helpers to do zero-allocation call to interface methods on structs +[] +module internal Helpers = + let inline MoveNext(x: byref<'T> when 'T :> IAsyncStateMachine) = x.MoveNext() + let inline SetStateMachine(x: byref<'T> when 'T :> IAsyncStateMachine, state) = x.SetStateMachine(state) + let inline GetResumptionPoint(x: byref<'T> when 'T :> IResumableStateMachine<'Data>) = x.ResumptionPoint + +/// This is the type of coroutines +[] +type Coroutine() = + + /// Checks if the coroutine is completed + abstract IsCompleted: bool + + /// Executes the coroutine until the next 'yield' + abstract MoveNext: unit -> unit + + /// Gets the tailcall target if the coroutine has executed a `yield!` in tailcall position. + abstract TailcallTarget: Coroutine option + +/// This is the implementation of Coroutine with respect to a particular struct state machine type. +and [] + Coroutine<'Machine when 'Machine : struct + and 'Machine :> IAsyncStateMachine + and 'Machine :> ICoroutineStateMachine>() = + inherit Coroutine() + + // The state machine struct + [] + val mutable Machine: 'Machine + + override cr.IsCompleted = + match cr.TailcallTarget with + | None -> + GetResumptionPoint(&cr.Machine) = -1 + | Some tg -> + tg.IsCompleted + + override cr.TailcallTarget = + CoroutineStateMachineData.GetHijackTarget(&cr.Machine) + + override cr.MoveNext() = + match cr.TailcallTarget with + | None -> //if verbose then printfn $"[{cr.Id}] move" + MoveNext(&cr.Machine) + | Some tg -> + match tg.TailcallTarget with + | None -> tg.MoveNext() + | Some tg2 -> + // Cut out chains of tailcalls + CoroutineStateMachineData.SetHijackTarget(&cr.Machine, tg2) + tg2.MoveNext() +/// This extra data stored in ResumableStateMachine (and it's templated copies using __stateMachine) +/// It only contains one field, the hijack target for tailcalls. +and [] + CoroutineStateMachineData = + + /// This is used for tailcalls using 'yield!' + [] + val mutable TailcallTarget: Coroutine option + + static member GetHijackTarget(x: byref<'Machine> when 'Machine :> IResumableStateMachine) = + x.Data.TailcallTarget + + static member SetHijackTarget(x: byref<'Machine>, tg: Coroutine) : unit when 'Machine :> IResumableStateMachine = + let mutable newData = CoroutineStateMachineData() + newData.TailcallTarget <- Some tg + x.Data <- newData + +/// These are standard definitions filling in the 'Data' parameter of each +and ICoroutineStateMachine = IResumableStateMachine +and CoroutineStateMachine = ResumableStateMachine +and CoroutineResumptionFunc = ResumptionFunc +and CoroutineResumptionDynamicInfo = ResumptionDynamicInfo +and CoroutineCode = ResumableCode + + +/// The builder for tailcalls, defined using resumable code combinators +type CoroutineBuilder() = + + member inline _.Delay(f : unit -> CoroutineCode) : CoroutineCode = ResumableCode.Delay(f) + + /// Create the state machine and outer execution logic + member inline _.Run(code : CoroutineCode) : Coroutine = + if __useResumableCode then + __stateMachine + + // IAsyncStateMachine.MoveNext + (MoveNextMethodImpl<_>(fun sm -> + //-- RESUMABLE CODE START + __resumeAt sm.ResumptionPoint + let __stack_code_fin = code.Invoke(&sm) + if __stack_code_fin then + sm.ResumptionPoint <- -1 // indicates complete + else + // Goto request + match sm.Data.TailcallTarget with + | Some tg -> tg.MoveNext() // recurse + | None -> () + //-- RESUMABLE CODE END + )) + + // IAsyncStateMachine.SetStateMachine + (SetStateMachineMethodImpl<_>(fun sm state -> SetStateMachine(&sm, state))) + + // Box the coroutine. In this example we don't start execution of the coroutine. + (AfterCode<_,_>(fun sm -> + let mutable cr = Coroutine() + cr.Machine <- sm + cr :> Coroutine)) + else + // The dynamic implementation + let initialResumptionFunc = CoroutineResumptionFunc(fun sm -> code.Invoke(&sm)) + let resumptionInfo = + { new CoroutineResumptionDynamicInfo(initialResumptionFunc) with + member info.MoveNext(sm) = + if info.ResumptionFunc.Invoke(&sm) then + sm.ResumptionPoint <- -1 + member info.SetStateMachine(sm, state) = () + } + let mutable cr = Coroutine() + cr.Machine.ResumptionDynamicInfo <- resumptionInfo + cr :> Coroutine + + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + [] + member inline _.Zero() : CoroutineCode = ResumableCode.Zero() + + /// 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(code1: CoroutineCode, code2: CoroutineCode) : CoroutineCode = + ResumableCode.Combine(code1, code2) + + /// Builds a step that executes the body while the condition predicate is true. + member inline _.While ([] condition : unit -> bool, body : CoroutineCode) : CoroutineCode = + 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: CoroutineCode, catch: exn -> CoroutineCode) : CoroutineCode = + 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: CoroutineCode, [] compensation : unit -> unit) : CoroutineCode = + ResumableCode.TryFinally(body, ResumableCode<_,_>(fun _ -> compensation(); true)) + + member inline _.Using (resource : 'Resource, body : 'Resource -> CoroutineCode) : CoroutineCode when 'Resource :> IDisposable = + ResumableCode.Using(resource, body) + + member inline _.For (sequence : seq<'T>, body : 'T -> CoroutineCode) : CoroutineCode = + ResumableCode.For(sequence, body) + + member inline _.Yield (_dummy: unit) : CoroutineCode = + ResumableCode.Yield() + + // The implementation of `yield!` + member inline _.YieldFrom (other: Coroutine) : CoroutineCode = + ResumableCode.While((fun () -> not other.IsCompleted), CoroutineCode(fun sm -> + other.MoveNext() + let __stack_other_fin = other.IsCompleted + if not __stack_other_fin 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_yield_fin + else + yieldFromCount <- yieldFromCount + 1 + true)) + + // The implementation of `return!`, non-standard for tailcalls + member inline _.YieldFromFinal (other: Coroutine) : CoroutineCode = + ResumableCode<_,_>(fun sm -> + yieldFromFinalCallCount <- yieldFromFinalCallCount + 1 + sm.Data.TailcallTarget <- Some other + // For tailcalls we return 'false' and re-run from the entry (trampoline) + false + // We could do this immediately with future cut-out, though this will stack-dive on sync code. + // We could also trampoline less frequently via a counter + // b.YieldFrom(other).Invoke(&sm) + ) + +let coroutine = CoroutineBuilder() + +let dumpCoroutine (t: Coroutine) = + yieldFromFinalCallCount <- 0 + yieldFromCount <- 0 + printfn "-----" + while ( //if verbose then printfn $"[{t.Id}] calling t.MoveNext, will resume at {t.ResumptionPoint}"; + t.MoveNext() + not t.IsCompleted) do + () // printfn "yield" + printfn $"YieldFromFinal called {yieldFromFinalCallCount} times, YieldFrom called {yieldFromCount} times" + +let expect final standard t = + dumpCoroutine t + if yieldFromFinalCallCount <> final then failwithf "Expected yieldFromFinalCallCount = %d, got %d" final yieldFromFinalCallCount + if yieldFromCount <> standard then failwithf "Expected yieldFromCount = %d, got %d" standard yieldFromCount + +let t0 () = coroutine { printfn "in t0" } + +let t1 () = + coroutine { + printfn "in t1" + yield () + printfn "hey ho" + yield () + printfn "This should YieldFromFinal because of final position" + yield! + coroutine{ + printfn "hey yo" + yield () + printfn "hey go" + } + } + +t1() |> expect 1 0 + +let testNonTailcall () = + coroutine { + try + printfn "this should not be tailcall because of try/finally" + yield! t1() + finally () + } + +testNonTailcall() |> expect 1 1 + +let testTailcallTiny () = + coroutine { + printfn "in testTailcallTiny" + yield! t1() + } + +testTailcallTiny() |> expect 2 0 + +let testTailcallTinyDoBang () = + coroutine { + printfn "in testTailcallTinyDoBang, desugaring do!" + do! t1() // this should desugr to YieldFromFinal, because ReturnFromFinal is not provided. + } + +testTailcallTinyDoBang() |> expect 2 0 + +let rec testTailcall (n: int) = + coroutine { + if n % 10_000 = 0 then printfn $"in testTailcall, n = {n}" + yield () + if n > 0 then + yield! testTailcall(n-1) + } + + +// Large number of recursive calls does not blow up the stack +testTailcall(1000000) |> expect 1000000 0 + +let t2 () = + coroutine { + printfn "in t2" + yield () + printfn "in t2 b" + yield! t1() + printfn "This should YieldFrom because of non final position" + yield! + coroutine { + printfn "hey yo" + } + yield () + } + +t2() |> expect 1 2 + +let t3 () = + coroutine { + printfn "in t3" + try + printfn "in t3 b" + yield! t1() + for x in 1 .. 3 do + printfn "t2 - got %A" x + yield () + yield! + coroutine { + printfn "hey yo" + } + yield () + printfn "This should YieldFrom because of try/with" + yield! + coroutine { + printfn "in t3 inner" + printfn "hey yo" + } + with _ -> () + } + +t3() |> expect 1 5 + +let negativeTest () = + coroutine { + printfn "in negativeTest" + try + yield! t0() + finally () + + try + yield! t0 () + failwith "crash" + with + | _ -> + yield! t0 () + printfn "in handler" + + let mutable x = 0 + + while (x <- x + 1; x < 5) do + yield! t0 () + + for x in 1 .. 5 do + yield! t0 () + + yield! t0 () + + printfn "done!" + } + +negativeTest () |> expect 0 13 + + +// Test also translation of return! + +type CorutineBuilderWithReturnFrom() = + inherit CoroutineBuilder() + + member inline this.ReturnFrom (value: 'T) : CoroutineCode = + this.YieldFrom(value) + + member inline this.ReturnFromFinal (value: 'T) : CoroutineCode = + this.YieldFromFinal(value) + +let coroutineWithReturnFrom = CorutineBuilderWithReturnFrom() + +let mostlyNegativeTestReturnFrom () = + coroutineWithReturnFrom { + printfn "in mostlyNegativeTestReturnFrom" + try + return! t0() + finally () + + try + return! t0 () + failwith "crash" + with + | _ -> + return! t0 () + + let mutable x = 0 + + while (x <- x + 1; x < 5) do + return! t0 () + + for x in 1 .. 5 do + return! t0 () + + return! t0 () // this one is ReturnFromFinal + } + +mostlyNegativeTestReturnFrom () |> expect 1 12 + + diff --git a/tests/FSharp.Compiler.ComponentTests/Language/tailcalls.fsx b/tests/FSharp.Compiler.ComponentTests/Language/tailcalls.fsx new file mode 100644 index 0000000000..b1c37e9557 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/tailcalls.fsx @@ -0,0 +1,85 @@ +type Method = ReturnFrom | ReturnFromFinal | YieldFrom | YieldFromFinal + +type Sync<'a> = (unit -> 'a) +type SyncBuilder<'a>(signal) = + member b.Bind(x,f) = f (x()) + member b.Using(x,f) = (fun () -> use r = x in f r ()) + member b.TryFinally(x,f) = (fun () -> try x() finally f()) + member b.TryWith(x, f) = (fun () -> try x() with e -> f e) + member b.Combine(f1,g) = (fun () -> f1(); g()()) + member b.Delay(f) = (fun () -> f()()) + member b.Zero() = (fun () -> ()) + member b.Return (x: 'a) = (fun () -> x) + member b.ReturnFrom (x: Sync<_>) = signal ReturnFrom; x + member b.ReturnFromFinal x = signal ReturnFromFinal; x + member b.YieldFrom x = (fun () -> signal YieldFrom; x) + member b.YieldFromFinal x = (fun () -> signal YieldFromFinal; x) + member b.For(e,f) = (fun () -> for x in e do f x ()) + member b.While(gd,x) = (fun () -> while gd() do x()) + +let shouldEqual x y = + printfn "%A" x + if x <> y then failwithf "Expected %A but got %A" y x + +let expect = shouldEqual + +let expectNone _ = failwith "Should not be called" + +let run f = f () |> ignore + +do + let sync = SyncBuilder (expect ReturnFromFinal) + + sync { + printf "expect ReturnFromFinal: " + return! sync { return 1 } + } |> run + + +do + let sync = SyncBuilder (expect ReturnFromFinal) + + sync { + printf "expect ReturnFromFinal: " + do! sync { printfn "inner" } + } |> run + +do + let sync = SyncBuilder (expect ReturnFrom) + + sync { return 1 } |> run + + sync { + printf "expect ReturnFrom: " + try + return! sync { return 1 } + finally () + } |> run + +do + let sync = SyncBuilder (expect YieldFromFinal) + + sync { + printf "expect YieldFromFinal: " + yield! sync { return 1 } + } |> run + +do + let sync = SyncBuilder (expect YieldFrom) + + sync { + printf "expect YieldFrom: " + try + yield! sync { return 1 } + with _ -> return 0 + } |> run + +do + let sync = SyncBuilder expectNone + + sync { + printf "expectNone: " + let! a = sync { return 1 } + let! b = sync { return 2 } + return a + b + } |> run diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl index 79894ad0cc..09f0f67af9 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl @@ -10353,6 +10353,8 @@ FSharp.Compiler.SyntaxTrivia.SynExprTryWithTrivia: FSharp.Compiler.Text.Range ge FSharp.Compiler.SyntaxTrivia.SynExprTryWithTrivia: FSharp.Compiler.Text.Range get_WithToEndRange() FSharp.Compiler.SyntaxTrivia.SynExprTryWithTrivia: System.String ToString() FSharp.Compiler.SyntaxTrivia.SynExprTryWithTrivia: Void .ctor(FSharp.Compiler.Text.Range, FSharp.Compiler.Text.Range, FSharp.Compiler.Text.Range, FSharp.Compiler.Text.Range) +FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia: FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia Zero +FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia: FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia get_Zero() FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia: FSharp.Compiler.Text.Range YieldOrReturnFromKeyword FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia: FSharp.Compiler.Text.Range get_YieldOrReturnFromKeyword() FSharp.Compiler.SyntaxTrivia.SynExprYieldOrReturnFromTrivia: System.String ToString()