From 19c75fabd9ca800ac9c3d48b9bb0dd9944366946 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 25 May 2023 11:28:56 +0200 Subject: [PATCH 01/31] Add TailCall attribute Move work of Avi Avni to current sources but use a field in cenv instead of a function parameter to pass around --- src/Compiler/Checking/PostInferenceChecks.fs | 150 ++++++++++++++---- src/Compiler/FSComp.txt | 1 + src/Compiler/TypedTree/TcGlobals.fs | 1 + src/Compiler/xlf/FSComp.txt.cs.xlf | 5 + src/Compiler/xlf/FSComp.txt.de.xlf | 5 + src/Compiler/xlf/FSComp.txt.es.xlf | 5 + src/Compiler/xlf/FSComp.txt.fr.xlf | 5 + src/Compiler/xlf/FSComp.txt.it.xlf | 5 + src/Compiler/xlf/FSComp.txt.ja.xlf | 5 + src/Compiler/xlf/FSComp.txt.ko.xlf | 5 + src/Compiler/xlf/FSComp.txt.pl.xlf | 5 + src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 5 + src/Compiler/xlf/FSComp.txt.ru.xlf | 5 + src/Compiler/xlf/FSComp.txt.tr.xlf | 5 + src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 5 + src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 5 + src/FSharp.Core/prim-types.fs | 5 + src/FSharp.Core/prim-types.fsi | 6 + .../ErrorMessages/TailCallAttribute.fs | 147 +++++++++++++++++ .../FSharp.Compiler.ComponentTests.fsproj | 1 + 20 files changed, 348 insertions(+), 28 deletions(-) create mode 100644 tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 145c7e0799c..7dfa7440133 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -85,6 +85,9 @@ type env = /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature sigToImplRemapInfo: (Remap * SignatureHidingInfo) list + /// Values in this recursive scope that have been marked [] + mustTailCall: Zset; + /// Are we in a quotation? quote : bool @@ -190,6 +193,27 @@ let CombineLimits limits = (NoLimit, limits) ||> List.fold CombineTwoLimits +type IsTailCall = + | Yes of bool // true indicates "has unit return type and must return void" + | No + + static member AtMethodOrFunction isVoidRet = + IsTailCall.Yes isVoidRet + + member x.AtExprLambda = + match x with + // Inside a lambda that is considered an expression, we must always return "unit" not "void" + | IsTailCall.Yes _ -> IsTailCall.Yes false + | IsTailCall.No -> IsTailCall.No + +let IsValRefIsDllImport g (vref:ValRef) = + vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute + +let (|ValUseAtApp|_|) e = + match e with + | InnerExprPat(Expr.App(InnerExprPat(Expr.Val(vref,valUseFlags,_)),_,_,[],_) | Expr.Val(vref,valUseFlags,_)) -> Some (vref, valUseFlags) + | _ -> None + type cenv = { boundVals: Dictionary // really a hash set @@ -226,7 +250,9 @@ type cenv = mutable entryPointGiven: bool /// Callback required for quotation generation - tcVal: ConstraintSolver.TcValF } + tcVal: ConstraintSolver.TcValF + + isTailCall: IsTailCall } override x.ToString() = "" @@ -331,6 +357,10 @@ let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo) +let ComputeMustTailCallForRecVals cenv env (binds: Bindings) = + let mustTailCall = [ for b in binds do if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute b.Var.Attribs then yield b.Var ] + { env with mustTailCall = Zset.addList mustTailCall env.mustTailCall } + //-------------------------------------------------------------------------- // approx walk of type //-------------------------------------------------------------------------- @@ -791,6 +821,9 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) + if env.mustTailCall.Contains v.Deref && cenv.isTailCall = IsTailCall.No then + warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) + if env.isInAppExpr then CheckTypePermitAllByrefs cenv env m v.Type // we do checks for byrefs elsewhere else @@ -847,7 +880,7 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB limit /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -886,6 +919,48 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = | None -> () | _ -> () | _ -> () + + match f with + | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> + + let canTailCall = + match cenv.isTailCall with + | IsTailCall.No -> false + | IsTailCall.Yes isVoidRet -> + if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then + + let topValInfo = vref.ValReprInfo.Value + let (nowArgs, laterArgs), returnTy = + let _tps, tau = destTopForallTy g topValInfo _fty + let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m + (List.splitAfter curriedArgInfos.Length argsl), returnTy + let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) + let isCCall = + match valUseFlags with + | PossibleConstrainedCall _ -> true + | _ -> false + + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) + let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + + else + true + + if not canTailCall then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)); + + CheckExprNoByrefs { cenv with isTailCall = (IsTailCall.Yes true) } env f + + | _ -> + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env f | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = @@ -1124,7 +1199,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv origExpr + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr @@ -1146,8 +1221,8 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = CheckExprLinear cenv env expr ctxt id | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs cenv env e1 - CheckExprNoByrefs cenv env e2 + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e1 + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 NoLimit | Expr.Const (_, m, ty) -> @@ -1164,7 +1239,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = CheckStructStateMachineExpr cenv env expr info | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) + CheckObjectExpr { cenv with isTailCall = IsTailCall.No } env (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) @@ -1326,7 +1401,7 @@ and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyarg and CheckSpliceApplication cenv env (tinst, arg, m) = CheckTypeInstNoInnerByrefs cenv env m tinst // it's the splice operator, a byref instantiation is allowed - CheckExprNoByrefs cenv env arg + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env arg NoLimit and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = @@ -1361,12 +1436,12 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = and CheckLambda cenv env expr (argvs, m, bodyTy) = let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in - CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes + CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes and CheckTyLambda cenv env expr (tps, m, bodyTy) = let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) let ty = mkForallTyIfNeeded tps bodyTy in - CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes + CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes and CheckMatch cenv env ctxt (dtree, targets, m, ty) = CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch @@ -1380,8 +1455,8 @@ and CheckLetRec cenv env (binds, bodyExpr) = NoLimit and CheckStaticOptimization cenv env (constraints, e2, e3, m) = - CheckExprNoByrefs cenv env e2 - CheckExprNoByrefs cenv env e3 + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e3 constraints |> List.iter (function | TTyconEqualsTycon(ty1, ty2) -> CheckTypeNoByrefs cenv env m ty1 @@ -1445,8 +1520,8 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/finally can be a byref - let limit = CheckExpr cenv env e1 ctxt // result of a try/finally can be a byref if in a position where the overall expression is can be a byref - CheckExprNoByrefs cenv env e2 + let limit = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/finally can be a byref if in a position where the overall expression is can be a byref + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 limit | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> @@ -1455,9 +1530,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/catch can be a byref - let limit1 = CheckExpr cenv env e1 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit1 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref // [(* e2; -- don't check filter body - duplicates logic in 'catch' body *) e3] - let limit2 = CheckExpr cenv env e3 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit2 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e3 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref CombineTwoLimits limit1 limit2 | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), _, _ -> @@ -1579,10 +1654,10 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.Coerce, [tgtTy;srcTy], [x] -> if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt + CheckExpr { cenv with isTailCall = IsTailCall.No } env x ctxt else - CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env x + CheckTypeInstNoByrefs { cenv with isTailCall = IsTailCall.No } env m tyargs + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -1646,6 +1721,10 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = match instrs, args with // Write a .NET instance field | [ I_stfld (_alignment, _vol, _fspec) ], _ -> + match args with + | [ _; rhs ] -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env rhs + | _ -> () + // permit byref for lhs lvalue // permit byref for rhs lvalue (field would have to have ByRefLike type, i.e. be a field in another ByRefLike type) CheckExprsPermitByRefLike cenv env args @@ -1813,12 +1892,12 @@ and CheckExprs cenv env exprs ctxts : Limit = let ctxts = Array.ofList ctxts let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No exprs - |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i)) + |> List.mapi (fun i exp -> CheckExpr { cenv with isTailCall = IsTailCall.No } env exp (argArity i)) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do - CheckExprNoByrefs cenv env expr + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr NoLimit and CheckExprsPermitByRefLike cenv env exprs : Limit = @@ -1827,10 +1906,10 @@ and CheckExprsPermitByRefLike cenv env exprs : Limit = |> CombineLimits and CheckExprPermitByRefLike cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.Yes + CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.Yes and CheckExprPermitReturnableByRef cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.YesReturnable + CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.YesReturnable and CheckDecisionTreeTargets cenv env targets ctxt = targets @@ -1868,7 +1947,7 @@ and CheckDecisionTreeTest cenv env m discrim = | DecisionTreeTest.Const _ -> () | DecisionTreeTest.IsNull -> () | DecisionTreeTest.IsInst (srcTy, tgtTy) -> CheckTypeNoInnerByrefs cenv env m srcTy; CheckTypeNoInnerByrefs cenv env m tgtTy - | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env exp | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = @@ -1878,8 +1957,8 @@ and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = args |> List.iter (CheckAttribExpr cenv env) and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = - CheckExprNoByrefs cenv env expr - CheckExprNoByrefs cenv env vexpr + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env vexpr CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr @@ -2065,6 +2144,17 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () | _ -> () + + let _topValInfo, isVoidRet = + match bind.Var.ValReprInfo with + | Some info -> + let _tps, tau = destTopForallTy g info v.Type + let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range + info, isUnitTy g returnTy + | None -> + ValReprInfo.emptyValData, false + + let isTailCall = IsTailCall.AtMethodOrFunction isVoidRet let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData @@ -2084,14 +2174,16 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin else env - CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) {cenv with isTailCall = isTailCall } env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = + let env = ComputeMustTailCallForRecVals cenv env binds for bind in binds do CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore // Top binds introduce expression, check they are reraise free. let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = + let env = ComputeMustTailCallForRecVals cenv env [bind] let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then @@ -2579,7 +2671,7 @@ and CheckDefnInModule cenv env mdef = | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs cenv env e + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env mbind = @@ -2616,7 +2708,8 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v isLastCompiland = isLastCompiland isInternalTestSpanStackReferring = isInternalTestSpanStackReferring tcVal = tcValF - entryPointGiven = false} + entryPointGiven = false + isTailCall = IsTailCall.No } // Certain type equality checks go faster if these TyconRefs are pre-resolved. // This is because pre-resolving allows tycon equality to be determined by pointer equality on the entities. @@ -2634,6 +2727,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v quote=false boundTyparNames=[] argVals = ValMap.Empty + mustTailCall = Zset.empty valOrder boundTypars= TyparMap.Empty reflect=false external=false diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 0da140f884d..bbecbb399c9 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1692,3 +1692,4 @@ featureEscapeBracesInFormattableString,"Escapes curly braces before calling Form 3563,lexInvalidIdentifier,"This is not a valid identifier" 3564,parsMissingUnionCaseName,"Missing union case name" 3565,parsExpectingType,"Expecting type" +3566,chkNotTailRecursive,"The member or function '%s' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 4174d567a6e..9404de96eff 100755 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -1522,6 +1522,7 @@ type TcGlobals( member val attrib_CompilerFeatureRequiredAttribute = findSysAttrib "System.Runtime.CompilerServices.CompilerFeatureRequiredAttribute" member val attrib_SetsRequiredMembersAttribute = findSysAttrib "System.Diagnostics.CodeAnalysis.SetsRequiredMembersAttribute" member val attrib_RequiredMemberAttribute = findSysAttrib "System.Runtime.CompilerServices.RequiredMemberAttribute" + member val attrib_TailCallAttribute = mk_MFCore_attrib "TailCallAttribute" member g.improveType tcref tinst = improveTy tcref tinst diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index 68d321a7cdf..18902680cb7 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -102,6 +102,11 @@ Pokud typ používá atribut [<Sealed>] i [<AbstractClass>], znamená to, že je statický. Členové instance nejsou povoleni. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. Atribut AssemblyKeyNameAttribute je zastaralý. Použijte místo něj AssemblyKeyFileAttribute. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index ee52b662d1d..6fdb18809f1 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -102,6 +102,11 @@ Wenn ein Typ sowohl das Attribute [<Sealed>] wie auch [<AbstractClass>] verwendet, bedeutet dies, dass er statisch ist. Members in Instanzen sind nicht zulässig. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. "AssemblyKeyNameAttribute" gilt als veraltet. Verwenden Sie stattdessen "AssemblyKeyFileAttribute". diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 9748064eb19..4a7d7257c50 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -102,6 +102,11 @@ Si un tipo usa los atributos [<Sealed>] y [<AbstractClass>], significa que es estático. No se permiten miembros de instancia. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. El elemento "AssemblyKeyNameAttribute" está en desuso. Use "AssemblyKeyFileAttribute" en su lugar. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index d0eb8a412f3..3b4592a6859 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -102,6 +102,11 @@ Si un type utilise les attributs [<Sealed>] et [<AbstractClass>], cela signifie qu’il est statique. Les membres de l’instance ne sont pas autorisés. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' a été déprécié. Utilisez 'AssemblyKeyFileAttribute' à la place. diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index a1c4c79cf5a..d09cc76cffd 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -102,6 +102,11 @@ Se un tipo usa entrambi gli attributi [<Sealed>] e [<AbstractClass>], significa che è statico. Membri dell'istanza non consentiti. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. L'attributo 'AssemblyKeyNameAttribute' è deprecato. In alternativa, usare 'AssemblyKeyFileAttribute'. diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index a1e4157a4de..083c60ebf2b 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -102,6 +102,11 @@ 型が [<Sealed>] と [<AbstractClass>] の両方の属性を使用する場合、それは静的であることを意味します。インスタンス メンバーは許可されません。 + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' は非推奨になりました。代わりに 'AssemblyKeyFileAttribute' を使用してください。 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 7c4f481d2a2..c4c69bea1bb 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -102,6 +102,11 @@ 형식이 [<Sealed>] 및 [<AbstractClass>] 특성을 모두 사용하는 경우 정적임을 의미합니다. 인스턴스 멤버는 허용되지 않습니다. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute'는 사용되지 않습니다. 대신 'AssemblyKeyFileAttribute'를 사용하세요. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index cea66cde2e9..66aecd949ce 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -102,6 +102,11 @@ Jeśli typ używa obu [<Sealed>] i [< AbstractClass>] atrybutów, oznacza to, że jest statyczny. Elementy członkowskie wystąpienia są niedozwolone. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. Element „AssemblyKeyNameAttribute” jest przestarzały. Zamiast niego użyj elementu „AssemblyKeyFileAttribute”. diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 79c864480fd..0d69a84c8ff 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -102,6 +102,11 @@ Se um tipo usa os atributos [<Sealed>] e [<AbstractClass>], significa que é estático. Membros da instância não são permitidos. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. O 'AssemblyKeyNameAttribute' foi preterido. Use o 'AssemblyKeyFileAttribute'. diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 831c7891388..6b2f62af619 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -102,6 +102,11 @@ Если тип использует атрибуты [<Sealed>] и [<AbstractClass>], это означает, что он статический. Элементы экземпляра не разрешены. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. Атрибут "AssemblyKeyNameAttribute" является устаревшим. Используйте вместо него атрибут "AssemblyKeyFileAttribute". diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 9e455903428..30fb655186d 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -102,6 +102,11 @@ Bir tür, hem [<Sealed>] hem de [< AbstractClass>] özniteliklerini kullanıyorsa bu statik olduğu anlamına gelir. Örnek üyelerine izin verilmez. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' kullanım dışı bırakıldı. Bunun yerine 'AssemblyKeyFileAttribute' kullanın. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 8338b0da896..6a3e72ea47f 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -102,6 +102,11 @@ 如果类型同时使用 [<Sealed>] 和 [<AbstractClass>] 属性，则表示它是静态的。不允许使用实例成员。 + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. "AssemblyKeyNameAttribute" 已被弃用。请改为使用 "AssemblyKeyFileAttribute"。 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 5fbdf0f332c..479fe84d704 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -102,6 +102,11 @@ 如果類型同時使用 [<Sealed>] 和 [<AbstractClass>] 屬性，表示其為靜態。不允許執行個體成員。 + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' 已淘汰。請改用 'AssemblyKeyFileAttribute'。 diff --git a/src/FSharp.Core/prim-types.fs b/src/FSharp.Core/prim-types.fs index e05a55fa47b..7693d7e6441 100644 --- a/src/FSharp.Core/prim-types.fs +++ b/src/FSharp.Core/prim-types.fs @@ -374,6 +374,11 @@ namespace Microsoft.FSharp.Core type NoCompilerInliningAttribute() = inherit Attribute() + [] + [] + type TailCallAttribute() = + inherit System.Attribute() + #if !NET5_0_OR_GREATER namespace System.Diagnostics.CodeAnalysis diff --git a/src/FSharp.Core/prim-types.fsi b/src/FSharp.Core/prim-types.fsi index bcbfa77e320..bb29b51ed55 100644 --- a/src/FSharp.Core/prim-types.fsi +++ b/src/FSharp.Core/prim-types.fsi @@ -950,6 +950,12 @@ namespace Microsoft.FSharp.Core /// NoCompilerInliningAttribute new: unit -> NoCompilerInliningAttribute + [] + [] + type TailCallAttribute = + inherit System.Attribute + new : unit -> TailCallAttribute + namespace System.Diagnostics.CodeAnalysis open System diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs new file mode 100644 index 00000000000..bebf8e286d6 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -0,0 +1,147 @@ +namespace FSharp.Compiler.ComponentTests.ErrorMessages + +open FSharp.Test.Compiler +open FSharp.Test.Compiler.Assertions.StructuredResultsAsserts +open Xunit + +module ``TailCall Attribute`` = + + [] + let ``Warn successfully in if-else`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + if n = 0 + then acc + else (fact (n-1) (mul n acc)) + 23 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 11 + EndLine = 8 + EndColumn = 33 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 11 + EndLine = 8 + EndColumn = 15 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn successfully in match clause`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + match n with + | 0 -> acc + | _ -> (fact (n-1) (mul n acc)) + 23 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 35 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 17 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn successfully for rec call in binding`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + match n with + | 0 -> acc + | _ -> + let r = (fact (n-1) (mul n acc)) + r + 23 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 35 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 17 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcall`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + if n = 0 + then acc + else (fact (n-1) (mul n acc)) + """ + |> FSharp + |> typecheck + |> shouldSucceed + + [] + let ``Warn successfully for mutually recursive functions`` () = + """ +let foo x = + printfn "Foo: %x" x + +[] +let rec bar x = + match x with + | 0 -> + foo x // OK: non-tail-recursive call to a function which doesn't share the current stack frame (i.e., 'bar' or 'baz'). + printfn "Zero" + + | 1 -> + bar (x - 1) // Warning: this call is not tail-recursive + printfn "Uno" + baz x // OK: tail-recursive call. + + | x -> + printfn "0x%08x" x + bar (x - 1) // OK: tail-recursive call. + +and [] baz x = + printfn "Baz!" + bar (x - 1) // OK: tail-recursive call. + """ + |> FSharp + |> typecheck + |> shouldFail diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index a83d57f55a5..746078af12c 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -142,6 +142,7 @@ + From d879525eb65e901b5bc05ae57d841279dc80b001 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 30 May 2023 14:50:15 +0200 Subject: [PATCH 02/31] Adjust error number after merge --- .../ErrorMessages/TailCallAttribute.fs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index bebf8e286d6..9e92c7acefa 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -21,14 +21,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 33 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 @@ -52,14 +52,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 @@ -85,14 +85,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 From 8d037454a4d97e74cbf419b126f991cdfd608bdd Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 30 May 2023 18:59:31 +0200 Subject: [PATCH 03/31] add two test cases for type members --- .../ErrorMessages/TailCallAttribute.fs | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 9e92c7acefa..f072809873d 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -145,3 +145,34 @@ and [] baz x = |> FSharp |> typecheck |> shouldFail + + [] + let ``Warn successfully for invalid tailcall in type method`` () = + """ +type C () = + [] + member this.M1() = this.M1() + 1 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 24 + EndLine = 4 + EndColumn = 33 } + Message = + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcall in type method`` () = + """ +type C () = + [] + member this.M1() = this.M1() + """ + |> FSharp + |> typecheck + |> shouldSucceed From 77f6b17974107da97c279826180d7f228587debc Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 30 May 2023 19:10:40 +0200 Subject: [PATCH 04/31] Don't try to split empty CurriedArgInfos --- src/Compiler/Checking/PostInferenceChecks.fs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 7dfa7440133..a2bef406e7b 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -933,7 +933,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m - (List.splitAfter curriedArgInfos.Length argsl), returnTy + if argsl.Length >= curriedArgInfos.Length then + (List.splitAfter curriedArgInfos.Length argsl), returnTy + else + ([], argsl), returnTy let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) let isCCall = match valUseFlags with From 4422b72f36ec5f32237421a5092fafa8e9ff7384 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 31 May 2023 14:39:20 +0200 Subject: [PATCH 05/31] Add more member tests --- .../ErrorMessages/TailCallAttribute.fs | 48 +++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index f072809873d..5c9cfbde3a9 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -176,3 +176,51 @@ type C () = |> FSharp |> typecheck |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in type methods`` () = + """ +type C () = + [] + member this.M1() = + this.M2() // ok + + [] + member this.M2() = + this.M1() // ok + """ + |> FSharp + |> typecheck + |> shouldSucceed + + [] + let ``Warn successfully for invalid tailcalls in type methods`` () = + """ +type F () = + [] + member this.M1() = + this.M2() + 1 // should warn + + [] + member this.M2() = + this.M1() + 2 // should warn + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 9 + EndLine = 5 + EndColumn = 18 } + Message = + "The member or function 'M2' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 9 + StartColumn = 9 + EndLine = 9 + EndColumn = 18 } + Message = + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] From 7acc83b2538cecf5fc9e8e4f628cbf512d13aad7 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 31 May 2023 14:49:02 +0200 Subject: [PATCH 06/31] seems like we need to build up the env.mustTailCall set earlier in the traversal to have the content ready when checking members which call each other --- src/Compiler/Checking/PostInferenceChecks.fs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index a2bef406e7b..c52ac150cfe 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -86,7 +86,7 @@ type env = sigToImplRemapInfo: (Remap * SignatureHidingInfo) list /// Values in this recursive scope that have been marked [] - mustTailCall: Zset; + mutable mustTailCall: Zset /// Are we in a quotation? quote : bool @@ -326,6 +326,9 @@ let BindVal cenv env (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 + + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + env.mustTailCall <- Zset.add v env.mustTailCall let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = @@ -357,10 +360,6 @@ let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo) -let ComputeMustTailCallForRecVals cenv env (binds: Bindings) = - let mustTailCall = [ for b in binds do if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute b.Var.Attribs then yield b.Var ] - { env with mustTailCall = Zset.addList mustTailCall env.mustTailCall } - //-------------------------------------------------------------------------- // approx walk of type //-------------------------------------------------------------------------- @@ -2180,13 +2179,11 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin CheckLambdas isTop (Some v) {cenv with isTailCall = isTailCall } env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = - let env = ComputeMustTailCallForRecVals cenv env binds for bind in binds do CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore // Top binds introduce expression, check they are reraise free. let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = - let env = ComputeMustTailCallForRecVals cenv env [bind] let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then From 245c11fa4a31f6b5b1d6765aae75473cd3231f6d Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 31 May 2023 19:40:40 +0200 Subject: [PATCH 07/31] Fix an error from migrating the old PR to current sources. --- src/Compiler/Checking/PostInferenceChecks.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index c52ac150cfe..552a935072f 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -959,10 +959,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = if not canTailCall then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)); - CheckExprNoByrefs { cenv with isTailCall = (IsTailCall.Yes true) } env f + () | _ -> - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env f + () | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = From a4e5eaaf6507f8a9871f72460cdb56792787a771 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 2 Jun 2023 00:49:11 +0200 Subject: [PATCH 08/31] As cenv is mutated in loops, doing "with" copies isn't that great as the failing CI shows. Making isTailCall also mutable is error prone as one has to switch back to orig values in many places. So refactor to use a flag like Avi did. This should fix the side effects (shown by the failing CI) and more tailrec specific tests --- src/Compiler/Checking/PostInferenceChecks.fs | 234 +++++++++--------- .../ErrorMessages/TailCallAttribute.fs | 16 ++ 2 files changed, 129 insertions(+), 121 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 552a935072f..f221326febe 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -250,9 +250,7 @@ type cenv = mutable entryPointGiven: bool /// Callback required for quotation generation - tcVal: ConstraintSolver.TcValF - - isTailCall: IsTailCall } + tcVal: ConstraintSolver.TcValF } override x.ToString() = "" @@ -798,11 +796,11 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | Some e -> errorR(e) /// Check an expression, where the expression is in a position where byrefs can be generated -let rec CheckExprNoByrefs cenv env expr = - CheckExpr cenv env expr PermitByRefExpr.No |> ignore +let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = + CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore /// Check a value -and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = +and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = if cenv.reportErrors then if isSpliceOperator cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)) @@ -820,7 +818,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) - if env.mustTailCall.Contains v.Deref && cenv.isTailCall = IsTailCall.No then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then @@ -829,7 +827,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = CheckTypeNoInnerByrefs cenv env m v.Type /// Check a use of a value -and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) = +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = let g = cenv.g @@ -874,12 +872,12 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB if isReturnOfStructThis then errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) - CheckValRef cenv env vref m ctxt + CheckValRef cenv env vref m ctxt isTailCall limit /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -923,11 +921,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> let canTailCall = - match cenv.isTailCall with + match isTailCall with | IsTailCall.No -> false | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then - let topValInfo = vref.ValReprInfo.Value let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty @@ -941,9 +938,9 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = match valUseFlags with | PossibleConstrainedCall _ -> true | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + not isNewObj && not isSuperInit && not isSelfInit && @@ -951,18 +948,14 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = isNil laterArgs && not (IsValRefIsDllImport cenv.g vref) && not isCCall && - not hasByrefArg - + not hasByrefArg else true if not canTailCall then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)); - - () - - | _ -> + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) () + | _ -> () | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = @@ -1041,7 +1034,7 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = | [] -> PermitByRefExpr.No, [] | ctxt :: ctxts -> ctxt, ctxts - let receiverLimit = CheckExpr cenv env receiverArg receiverContext + let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No let limitArgs = let limitArgs = CheckExprs cenv env args ctxts // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. @@ -1052,12 +1045,12 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = limitArgs CheckCallLimitArgs cenv env m returnTy limitArgs ctxt -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) (isTailCall: IsTailCall) = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> - CheckExprNoByrefs cenv env e1 + CheckExprNoByrefs cenv env IsTailCall.No e1 // tailcall - CheckExprLinear cenv env e2 ctxt contf + CheckExprLinear cenv env e2 ctxt contf isTailCall | Expr.Let (TBind(v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type @@ -1072,31 +1065,31 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf BindVal cenv env v LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall - CheckExprLinear cenv env body ctxt contf + CheckExprLinear cenv env body ctxt contf isTailCall | LinearOpExpr (_op, tyargs, argsHead, argLast, m) -> CheckTypeInstNoByrefs cenv env m tyargs - argsHead |> List.iter (CheckExprNoByrefs cenv env) + argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) // tailcall - CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) + CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) isTailCall | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, m, ty) -> CheckTypeNoInnerByrefs cenv env m ty CheckDecisionTree cenv env dtree - let lim1 = CheckDecisionTreeTarget cenv env ctxt tg1 + let lim1 = CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) + CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) isTailCall | Expr.DebugPoint (_, innerExpr) -> - CheckExprLinear cenv env innerExpr ctxt contf + CheckExprLinear cenv env innerExpr ctxt contf isTailCall | _ -> // not a linear expression - contf (CheckExpr cenv env expr ctxt) + contf (CheckExpr cenv env expr ctxt isTailCall) /// Check a resumable code expression (the body of a ResumableCode delegate or /// the body of the MoveNextMethod for a state machine) -and TryCheckResumableCodeConstructs cenv env expr : bool = +and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : bool = let g = cenv.g match env.resumableCode with @@ -1106,63 +1099,63 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = | Resumable.ResumableExpr allowed -> match expr with | IfUseResumableStateMachinesExpr g (thenExpr, elseExpr) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } thenExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } elseExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } isTailCall thenExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall elseExpr true | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, _rebuild) -> if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) - CheckExprNoByrefs cenv env noneBranchExpr + CheckExprNoByrefs cenv env isTailCall noneBranchExpr BindVal cenv env someVar - CheckExprNoByrefs cenv env someBranchExpr + CheckExprNoByrefs cenv env isTailCall someBranchExpr true | ResumeAtExpr g pcExpr -> if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumeAt"), expr.Range)) - CheckExprNoByrefs cenv env pcExpr + CheckExprNoByrefs cenv env isTailCall pcExpr true | ResumableCodeInvoke g (_, f, args, _, _) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } f + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall f for arg in args do CheckExprPermitByRefLike cenv { env with resumableCode = Resumable.None } arg |> ignore true | SequentialResumableCode g (e1, e2, _m, _recreate) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr allowed }e1 - CheckExprNoByrefs cenv env e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr allowed } isTailCall e1 + CheckExprNoByrefs cenv env isTailCall e2 true | WhileExpr (_sp1, _sp2, guardExpr, bodyExpr, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } guardExpr - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall guardExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr true // Integer for-loops are allowed but their bodies are not currently resumable | IntegerForLoopExpr (_sp1, _sp2, _style, e1, e2, v, e3, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 BindVal cenv env v - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e3 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 true | TryWithExpr (_spTry, _spWith, _resTy, bodyExpr, _filterVar, filterExpr, _handlerVar, handlerExpr, _m) -> - CheckExprNoByrefs cenv env bodyExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } handlerExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } filterExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall handlerExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall filterExpr true | TryFinallyExpr (_sp1, _sp2, _ty, e1, e2, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 true | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> BindVals cenv env vs - CheckExprNoByrefs cenv env targetExpr) + CheckExprNoByrefs cenv env isTailCall targetExpr) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree true @@ -1171,13 +1164,13 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore BindVal cenv env bind.Var - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr true // LetRec bindings may not appear as part of resumable code (more careful work is needed to make them compilable) | Expr.LetRec(_bindings, bodyExpr, _range, _frees) when allowed -> errorR(Error(FSComp.SR.tcResumableCodeContainsLetRec(), expr.Range)) - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr true // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match @@ -1185,13 +1178,13 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = true | Expr.DebugPoint (_, innerExpr) -> - TryCheckResumableCodeConstructs cenv env innerExpr + TryCheckResumableCodeConstructs cenv env innerExpr isTailCall | _ -> false /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = +and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : Limit = // Guard the stack for deeply nested expressions cenv.stackGuard.Guard <| fun () -> @@ -1201,11 +1194,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr - match TryCheckResumableCodeConstructs cenv env expr with + match TryCheckResumableCodeConstructs cenv env expr isTailCall with | true -> // we've handled the special cases of resumable code and don't do other checks. NoLimit @@ -1220,11 +1213,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) | Expr.DebugPoint _ -> - CheckExprLinear cenv env expr ctxt id + CheckExprLinear cenv env expr ctxt id isTailCall | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e1 - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 + CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env IsTailCall.No e2 NoLimit | Expr.Const (_, m, ty) -> @@ -1232,7 +1225,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = NoLimit | Expr.Val (vref, vFlags, m) -> - CheckValUse cenv env (vref, vFlags, m) ctxt + CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> CheckQuoteExpr cenv env (ast, savedConv, m, ty) @@ -1241,7 +1234,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = CheckStructStateMachineExpr cenv env expr info | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr { cenv with isTailCall = IsTailCall.No } env (ty, basev, superInitCall, overrides, iimpls, m) + CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) @@ -1273,24 +1266,24 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = // Check an application | Expr.App (f, _fty, tyargs, argsl, m) -> - CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt + CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> - CheckLambda cenv env expr (argvs, m, bodyTy) + CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall | Expr.TyLambda (_, tps, _, m, bodyTy) -> - CheckTyLambda cenv env expr (tps, m, bodyTy) + CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall | Expr.TyChoose (tps, e1, _) -> let env = BindTypars g env tps - CheckExprNoByrefs cenv env e1 + CheckExprNoByrefs cenv env isTailCall e1 NoLimit | Expr.Match (_, _, dtree, targets, m, ty) -> - CheckMatch cenv env ctxt (dtree, targets, m, ty) + CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall | Expr.LetRec (binds, bodyExpr, _, _) -> - CheckLetRec cenv env (binds, bodyExpr) + CheckLetRec cenv env (binds, bodyExpr) isTailCall | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) @@ -1303,7 +1296,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = and CheckQuoteExpr cenv env (ast, savedConv, m, ty) = let g = cenv.g - CheckExprNoByrefs cenv {env with quote=true} ast + CheckExprNoByrefs cenv {env with quote=true} IsTailCall.No ast if cenv.reportErrors then cenv.usesQuotations <- true @@ -1340,14 +1333,14 @@ and CheckStructStateMachineExpr cenv env expr info = error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } moveNextExpr - CheckExprNoByrefs cenv env setStateMachineBody - CheckExprNoByrefs cenv env afterCodeBody + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr + CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody + CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody NoLimit and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) = let g = cenv.g - CheckExprNoByrefs cenv env superInitCall + CheckExprNoByrefs cenv env IsTailCall.No superInitCall CheckMethods cenv env basev (ty, overrides) CheckInterfaceImpls cenv env basev iimpls CheckTypeNoByrefs cenv env m ty @@ -1372,8 +1365,8 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = let env = { env with isInAppExpr = true } let returnTy = tyOfExpr g expr - CheckValRef cenv env v m PermitByRefExpr.No - CheckValRef cenv env baseVal m PermitByRefExpr.No + CheckValRef cenv env v m PermitByRefExpr.No IsTailCall.No + CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckTypeInstNoByrefs cenv env m tyargs CheckTypeNoInnerByrefs cenv env m returnTy CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) @@ -1398,15 +1391,15 @@ and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyarg CheckTypeInstNoByrefs cenv env m enclTypeInst CheckTypeInstNoByrefs cenv env m methInst CheckTypeInstNoByrefs cenv env m retTypes - CheckValRef cenv env baseVal m PermitByRefExpr.No + CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprsPermitByRefLike cenv env rest and CheckSpliceApplication cenv env (tinst, arg, m) = CheckTypeInstNoInnerByrefs cenv env m tinst // it's the splice operator, a byref instantiation is allowed - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env arg + CheckExprNoByrefs cenv env IsTailCall.No arg NoLimit -and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = +and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt (isTailCall: IsTailCall) = let g = cenv.g match expr with | ResumableCodeInvoke g _ -> @@ -1422,7 +1415,7 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = let env = { env with isInAppExpr = true } CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env f + CheckExprNoByrefs cenv env isTailCall f let hasReceiver = match f with @@ -1435,30 +1428,30 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = else CheckCall cenv env m returnTy argsl ctxts ctxt -and CheckLambda cenv env expr (argvs, m, bodyTy) = +and CheckLambda cenv env expr (argvs, m, bodyTy) (isTailCall: IsTailCall) = let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in - CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) = +and CheckTyLambda cenv env expr (tps, m, bodyTy) (isTailCall: IsTailCall) = let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) let ty = mkForallTyIfNeeded tps bodyTy in - CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, m, ty) = +and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch CheckDecisionTree cenv env dtree - CheckDecisionTreeTargets cenv env targets ctxt + CheckDecisionTreeTargets cenv env targets ctxt isTailCall -and CheckLetRec cenv env (binds, bodyExpr) = +and CheckLetRec cenv env (binds, bodyExpr) isTailCall = BindVals cenv env (valsOfBinds binds) CheckBindings cenv env binds - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr NoLimit and CheckStaticOptimization cenv env (constraints, e2, e3, m) = - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e3 + CheckExprNoByrefs cenv env IsTailCall.No e2 + CheckExprNoByrefs cenv env IsTailCall.No e3 constraints |> List.iter (function | TTyconEqualsTycon(ty1, ty2) -> CheckTypeNoByrefs cenv env m ty1 @@ -1485,7 +1478,7 @@ and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, body CheckAttribs cenv env attribs CheckNoReraise cenv None body CheckEscapes cenv true m (match baseValOpt with Some x -> x :: vs | None -> vs) body |> ignore - CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal |> ignore + CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -1522,8 +1515,8 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/finally can be a byref - let limit = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/finally can be a byref if in a position where the overall expression is can be a byref - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 + let limit = CheckExpr cenv env e1 ctxt IsTailCall.No // result of a try/finally can be a byref if in a position where the overall expression is can be a byref + CheckExprNoByrefs cenv env IsTailCall.No e2 limit | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> @@ -1532,9 +1525,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/catch can be a byref - let limit1 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit1 = CheckExpr cenv env e1 ctxt IsTailCall.No // result of a try/catch can be a byref if in a position where the overall expression is can be a byref // [(* e2; -- don't check filter body - duplicates logic in 'catch' body *) e3] - let limit2 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e3 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit2 = CheckExpr cenv env e3 ctxt IsTailCall.No // result of a try/catch can be a byref if in a position where the overall expression is can be a byref CombineTwoLimits limit1 limit2 | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), _, _ -> @@ -1656,10 +1649,10 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.Coerce, [tgtTy;srcTy], [x] -> if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr { cenv with isTailCall = IsTailCall.No } env x ctxt + CheckExpr cenv env x ctxt IsTailCall.No else - CheckTypeInstNoByrefs { cenv with isTailCall = IsTailCall.No } env m tyargs - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env x + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprNoByrefs cenv env IsTailCall.No x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -1694,7 +1687,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckTypeInstNoByrefs cenv env m tyargs // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt + CheckExpr cenv env obj ctxt IsTailCall.No | TOp.UnionCaseFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs @@ -1715,7 +1708,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckTypeInstNoByrefs cenv env m tyargs // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt + CheckExpr cenv env obj ctxt IsTailCall.No | TOp.ILAsm (instrs, retTypes), _, _ -> CheckTypeInstNoInnerByrefs cenv env m retTypes @@ -1724,7 +1717,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // Write a .NET instance field | [ I_stfld (_alignment, _vol, _fspec) ], _ -> match args with - | [ _; rhs ] -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env rhs + | [ _; rhs ] -> CheckExprNoByrefs cenv env IsTailCall.No rhs | _ -> () // permit byref for lhs lvalue @@ -1752,7 +1745,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(fspec.Name), m)) // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt + CheckExpr cenv env obj ctxt IsTailCall.No | [ I_ldelema (_, isNativePtr, _, _) ], lhsArray :: indices -> if ctxt.Disallow && cenv.reportErrors && not isNativePtr && isByrefLikeTy g m (tyOfExpr g expr) then @@ -1782,7 +1775,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckTypeInstNoByrefs cenv env m tyargs CheckExprsNoByRefLike cenv env args -and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwaysCheckNoReraise expr mOrig ety ctxt = +and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) @@ -1791,7 +1784,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa match stripDebugPoints expr with | Expr.TyChoose (tps, e1, m) -> let env = BindTypars g env tps - CheckLambdas isTop memberVal cenv env inlined valReprInfo alwaysCheckNoReraise e1 m ety ctxt + CheckLambdas isTop memberVal cenv env inlined valReprInfo isTailCall alwaysCheckNoReraise e1 m ety ctxt | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> @@ -1853,7 +1846,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa // allow byref to occur as return position for byref-typed top level function or method CheckExprPermitReturnableByRef cenv env body |> ignore else - CheckExprNoByrefs cenv env body + CheckExprNoByrefs cenv env isTailCall body // Check byref return types if cenv.reportErrors then @@ -1881,9 +1874,9 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa let limit = if not inlined && (isByrefLikeTy g m ety || isNativePtrTy g ety) then // allow byref to occur as RHS of byref binding. - CheckExpr cenv env expr ctxt + CheckExpr cenv env expr ctxt isTailCall else - CheckExprNoByrefs cenv env expr + CheckExprNoByrefs cenv env isTailCall expr NoLimit if alwaysCheckNoReraise then @@ -1894,12 +1887,12 @@ and CheckExprs cenv env exprs ctxts : Limit = let ctxts = Array.ofList ctxts let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No exprs - |> List.mapi (fun i exp -> CheckExpr { cenv with isTailCall = IsTailCall.No } env exp (argArity i)) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) IsTailCall.No) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr + CheckExprNoByrefs cenv env IsTailCall.No expr NoLimit and CheckExprsPermitByRefLike cenv env exprs : Limit = @@ -1908,22 +1901,22 @@ and CheckExprsPermitByRefLike cenv env exprs : Limit = |> CombineLimits and CheckExprPermitByRefLike cenv env expr : Limit = - CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.Yes + CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No and CheckExprPermitReturnableByRef cenv env expr : Limit = - CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.YesReturnable + CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No -and CheckDecisionTreeTargets cenv env targets ctxt = +and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = targets - |> Array.map (CheckDecisionTreeTarget cenv env ctxt) + |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) |> List.ofArray |> CombineLimits -and CheckDecisionTreeTarget cenv env ctxt (TTarget(vs, targetExpr, _)) = +and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = BindVals cenv env vs for v in vs do CheckValSpec PermitByRefType.All cenv env v - CheckExpr cenv env targetExpr ctxt + CheckExpr cenv env targetExpr ctxt isTailCall and CheckDecisionTree cenv env dtree = match dtree with @@ -1949,7 +1942,7 @@ and CheckDecisionTreeTest cenv env m discrim = | DecisionTreeTest.Const _ -> () | DecisionTreeTest.IsNull -> () | DecisionTreeTest.IsInst (srcTy, tgtTy) -> CheckTypeNoInnerByrefs cenv env m srcTy; CheckTypeNoInnerByrefs cenv env m tgtTy - | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env IsTailCall.No exp | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = @@ -1959,8 +1952,8 @@ and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = args |> List.iter (CheckAttribExpr cenv env) and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env vexpr + CheckExprNoByrefs cenv env IsTailCall.No expr + CheckExprNoByrefs cenv env IsTailCall.No vexpr CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr @@ -2176,7 +2169,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin else env - CheckLambdas isTop (Some v) {cenv with isTailCall = isTailCall } env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = for bind in binds do @@ -2671,7 +2664,7 @@ and CheckDefnInModule cenv env mdef = | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e + CheckExprNoByrefs cenv env IsTailCall.No e | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env mbind = @@ -2708,8 +2701,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v isLastCompiland = isLastCompiland isInternalTestSpanStackReferring = isInternalTestSpanStackReferring tcVal = tcValF - entryPointGiven = false - isTailCall = IsTailCall.No } + entryPointGiven = false } // Certain type equality checks go faster if these TyconRefs are pre-resolved. // This is because pre-resolving allows tycon equality to be determined by pointer equality on the entities. diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 5c9cfbde3a9..c75e7d7e151 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -145,6 +145,22 @@ and [] baz x = |> FSharp |> typecheck |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 13 + StartColumn = 9 + EndLine = 13 + EndColumn = 20 } + Message = + "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 13 + StartColumn = 9 + EndLine = 13 + EndColumn = 12 } + Message = + "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] [] let ``Warn successfully for invalid tailcall in type method`` () = From 239ab871656f9995c331810f1d631a1d916e16e7 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 2 Jun 2023 12:38:30 +0200 Subject: [PATCH 09/31] update baselines for FSharp.Core to include TailCallAttribute --- .../FSharp.Core.SurfaceArea.netstandard20.debug.bsl | 1 + .../FSharp.Core.SurfaceArea.netstandard20.release.bsl | 1 + .../FSharp.Core.SurfaceArea.netstandard21.debug.bsl | 1 + .../FSharp.Core.SurfaceArea.netstandard21.release.bsl | 1 + 4 files changed, 4 insertions(+) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index e373ae3440b..e677bf9a8c7 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -2042,6 +2042,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index e314c7263a2..0e8c47b4a88 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -2041,6 +2041,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index 29f826a24ba..20941451236 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -2043,6 +2043,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index 5114bd40b1d..36284cfb987 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -2042,6 +2042,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() From 29e175396e39bb917ea9975332181df65ae8ddde Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 5 Jun 2023 12:17:14 +0200 Subject: [PATCH 10/31] warn for rec call in binding, still very WIP --- src/Compiler/Checking/PostInferenceChecks.fs | 34 +++++++++++++------ .../ErrorMessages/TailCallAttribute.fs | 24 ++++++------- 2 files changed, 34 insertions(+), 24 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index f221326febe..e4070a64482 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2140,16 +2140,30 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () - let _topValInfo, isVoidRet = - match bind.Var.ValReprInfo with - | Some info -> - let _tps, tau = destTopForallTy g info v.Type - let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range - info, isUnitTy g returnTy - | None -> - ValReprInfo.emptyValData, false - - let isTailCall = IsTailCall.AtMethodOrFunction isVoidRet + let isTailCall = + let isVoidRet = + match bind.Var.ValReprInfo with + | Some info -> + let _tps, tau = destTopForallTy g info v.Type + let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range + isUnitTy g returnTy + | None -> false + IsTailCall.AtMethodOrFunction isVoidRet + + match bindRhs with + | Expr.App(_funcExpr, _formalType, _typeArgs, _exprs, _range) -> + let rec checkTailCall expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if not isTop && env.mustTailCall.Contains valRef.Deref then // ToDo: tighter check needed for bindings inside of functions + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall funcExpr + exprs |> List.iter checkTailCall + | Expr.Link exprRef -> checkTailCall exprRef.Value + | _ -> () + checkTailCall _funcExpr + | _ -> () let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index c75e7d7e151..264c078b652 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -78,7 +78,7 @@ let rec fact n acc = match n with | 0 -> acc | _ -> - let r = (fact (n-1) (mul n acc)) + let r = fact (n-1) (mul n acc) r + 23 """ |> FSharp @@ -86,23 +86,16 @@ let rec fact n acc = |> shouldFail |> withResults [ { Error = Warning 3567 - Range = { StartLine = 8 - StartColumn = 13 - EndLine = 8 - EndColumn = 35 } - Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 - Range = { StartLine = 8 - StartColumn = 13 - EndLine = 8 - EndColumn = 17 } + Range = { StartLine = 9 + StartColumn = 17 + EndLine = 9 + EndColumn = 21 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] - let ``Don't warn for valid tailcall`` () = + let ``Don't warn for valid tailcall and bind from toplevel`` () = """ let mul x y = x * y @@ -110,7 +103,10 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else (fact (n-1) (mul n acc)) + else fact (n-1) (mul n acc) + +let r = fact 100000 1 +r |> ignore """ |> FSharp |> typecheck From 8d1d045b662ce90bdf8f54c62441b6779dbdf1c5 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 6 Jun 2023 09:38:36 +0200 Subject: [PATCH 11/31] - improve check for problematic bindings to tailcall attributed functions - add tests --- src/Compiler/Checking/PostInferenceChecks.fs | 48 +++++++++++-------- .../ErrorMessages/TailCallAttribute.fs | 43 +++++++++++++++++ 2 files changed, 71 insertions(+), 20 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index e4070a64482..d5d32197534 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2150,21 +2150,6 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | None -> false IsTailCall.AtMethodOrFunction isVoidRet - match bindRhs with - | Expr.App(_funcExpr, _formalType, _typeArgs, _exprs, _range) -> - let rec checkTailCall expr = - match expr with - | Expr.Val(valRef, _valUseFlag, m) -> - if not isTop && env.mustTailCall.Contains valRef.Deref then // ToDo: tighter check needed for bindings inside of functions - warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - checkTailCall funcExpr - exprs |> List.iter checkTailCall - | Expr.Link exprRef -> checkTailCall exprRef.Value - | _ -> () - checkTailCall _funcExpr - | _ -> () - let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline @@ -2190,7 +2175,7 @@ and CheckBindings cenv env binds = CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore // Top binds introduce expression, check they are reraise free. -let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = +let CheckModuleBinding cenv env (isRec: bool) (TBind(v, e, _) as bind) = let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then @@ -2199,6 +2184,29 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) + match bind.Expr with + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + let rec checkTailCall (insideSubBinding: bool) expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall insideSubBinding funcExpr + exprs |> List.iter (checkTailCall insideSubBinding) + | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + checkTailCall insideSubBinding bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let(binding, bodyExpr, _range, _frees) -> + checkTailCall true binding.Expr + checkTailCall insideSubBinding bodyExpr + | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | _ -> () + checkTailCall false bodyExpr + | _ -> () + // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields not v.IsMutable && @@ -2668,10 +2676,10 @@ and CheckDefnInModule cenv env mdef = CheckNothingAfterEntryPoint cenv m if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) CheckEntityDefns cenv env tycons - List.iter (CheckModuleSpec cenv env) mspecs + List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m - CheckModuleBinding cenv env bind + CheckModuleBinding cenv env false bind BindVal cenv env bind.Var | TMDefOpens _ -> () @@ -2681,11 +2689,11 @@ and CheckDefnInModule cenv env mdef = CheckExprNoByrefs cenv env IsTailCall.No e | TMDefs defs -> CheckDefnsInModule cenv env defs -and CheckModuleSpec cenv env mbind = +and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> BindVals cenv env (valsOfBinds [bind]) - CheckModuleBinding cenv env bind + CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 264c078b652..016c435b8a0 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -236,3 +236,46 @@ type F () = Message = "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for valid tailcall and bind from nested bind`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + if n = 0 + then acc + else fact (n-1) (mul n acc) + +let f () = + let r = fact 100000 1 + r |> ignore + """ + |> FSharp + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in seq expression`` () = + """ +[] +let rec f x : seq = + seq { + let r = f (x-1) // Warning: this call is not tail-recursive + let r2 = Seq.map (fun x -> x + 1) r + yield! r2 +} + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 17 + EndLine = 5 + EndColumn = 18 } + Message = + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] From 60592823797bef66bfa99d6efe004cbc4276b0af Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 6 Jun 2023 16:02:26 +0200 Subject: [PATCH 12/31] improve seq support --- src/Compiler/Checking/PostInferenceChecks.fs | 32 ++++++++------- .../ErrorMessages/TailCallAttribute.fs | 41 ++++++++++++++++++- 2 files changed, 58 insertions(+), 15 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index d5d32197534..68e0080dccc 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -197,8 +197,20 @@ type IsTailCall = | Yes of bool // true indicates "has unit return type and must return void" | No - static member AtMethodOrFunction isVoidRet = - IsTailCall.Yes isVoidRet + static member private IsVoidRet (g: TcGlobals) (v: Val) = + match v.ValReprInfo with + | Some info -> + let _tps, tau = destTopForallTy g info v.Type + let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm g info.ArgInfos tau v.Range + isUnitTy g returnTy + | None -> false + + static member fromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) + + static member fromExpr (g: TcGlobals) (expr: Expr) = + match expr with + | Expr.Val(valRef, _valUseFlag, _range) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) + | _ -> IsTailCall.Yes false member x.AtExprLambda = match x with @@ -1648,11 +1660,12 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = NoLimit | TOp.Coerce, [tgtTy;srcTy], [x] -> + let isTailCall = IsTailCall.fromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt IsTailCall.No + CheckExpr cenv env x ctxt isTailCall else CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env IsTailCall.No x + CheckExprNoByrefs cenv env isTailCall x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -2140,16 +2153,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () - let isTailCall = - let isVoidRet = - match bind.Var.ValReprInfo with - | Some info -> - let _tps, tau = destTopForallTy g info v.Type - let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range - isUnitTy g returnTy - | None -> false - IsTailCall.AtMethodOrFunction isVoidRet - + let isTailCall = IsTailCall.fromVal g bind.Var let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 016c435b8a0..48c5a39590c 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -257,7 +257,7 @@ let f () = |> shouldSucceed [] - let ``Warn for invalid tailcalls in seq expression`` () = + let ``Warn for invalid tailcalls in seq expression because of bind`` () = """ [] let rec f x : seq = @@ -279,3 +279,42 @@ let rec f x : seq = Message = "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Warn for invalid tailcalls in seq expression because of pipe`` () = + """ +[] +let rec f x : seq = + seq { + yield! f (x-1) |> Seq.map (fun x -> x + 1) +} + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 16 + EndLine = 5 + EndColumn = 23 } + Message = + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 16 + EndLine = 5 + EndColumn = 17 } + Message = + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcalls in seq expression`` () = + """ +[] +let rec f x = seq { yield! f (x-1) } + """ + |> FSharp + |> typecheck + |> shouldSucceed From d0733542dcd64ec5fd0ad2705c77ff18912f310a Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 6 Jun 2023 17:09:35 +0200 Subject: [PATCH 13/31] add language version flag --- src/Compiler/Checking/PostInferenceChecks.fs | 131 +++++++++--------- src/Compiler/FSComp.txt | 3 +- src/Compiler/Facilities/LanguageFeatures.fs | 3 + src/Compiler/Facilities/LanguageFeatures.fsi | 1 + src/Compiler/xlf/FSComp.txt.cs.xlf | 9 +- src/Compiler/xlf/FSComp.txt.de.xlf | 9 +- src/Compiler/xlf/FSComp.txt.es.xlf | 9 +- src/Compiler/xlf/FSComp.txt.fr.xlf | 9 +- src/Compiler/xlf/FSComp.txt.it.xlf | 9 +- src/Compiler/xlf/FSComp.txt.ja.xlf | 9 +- src/Compiler/xlf/FSComp.txt.ko.xlf | 9 +- src/Compiler/xlf/FSComp.txt.pl.xlf | 9 +- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 9 +- src/Compiler/xlf/FSComp.txt.ru.xlf | 9 +- src/Compiler/xlf/FSComp.txt.tr.xlf | 9 +- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 9 +- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 9 +- .../ErrorMessages/TailCallAttribute.fs | 40 ++++-- 18 files changed, 190 insertions(+), 105 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 68e0080dccc..6969e94442f 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -830,8 +830,9 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then - warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then + warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then CheckTypePermitAllByrefs cenv env m v.Type // we do checks for byrefs elsewhere @@ -929,46 +930,47 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i | _ -> () | _ -> () - match f with - | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - - let canTailCall = - match isTailCall with - | IsTailCall.No -> false - | IsTailCall.Yes isVoidRet -> - if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then - let topValInfo = vref.ValReprInfo.Value - let (nowArgs, laterArgs), returnTy = - let _tps, tau = destTopForallTy g topValInfo _fty - let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m - if argsl.Length >= curriedArgInfos.Length then - (List.splitAfter curriedArgInfos.Length argsl), returnTy - else - ([], argsl), returnTy - let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) - let isCCall = - match valUseFlags with - | PossibleConstrainedCall _ -> true - | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) - let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) - - not isNewObj && - not isSuperInit && - not isSelfInit && - not mustGenerateUnitAfterCall && - isNil laterArgs && - not (IsValRefIsDllImport cenv.g vref) && - not isCCall && - not hasByrefArg - else - true - - if not canTailCall then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - () - | _ -> () - | _ -> () + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match f with + | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> + + let canTailCall = + match isTailCall with + | IsTailCall.No -> false + | IsTailCall.Yes isVoidRet -> + if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then + let topValInfo = vref.ValReprInfo.Value + let (nowArgs, laterArgs), returnTy = + let _tps, tau = destTopForallTy g topValInfo _fty + let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m + if argsl.Length >= curriedArgInfos.Length then + (List.splitAfter curriedArgInfos.Length argsl), returnTy + else + ([], argsl), returnTy + let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) + let isCCall = + match valUseFlags with + | PossibleConstrainedCall _ -> true + | _ -> false + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) + let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + else + true + + if not canTailCall then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + () + | _ -> () + | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = let isReturnByref = isByrefTy cenv.g returnTy @@ -2188,28 +2190,29 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(v, e, _) as bind) = if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) - match bind.Expr with - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - let rec checkTailCall (insideSubBinding: bool) expr = - match expr with - | Expr.Val(valRef, _valUseFlag, m) -> - if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then - warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - checkTailCall insideSubBinding funcExpr - exprs |> List.iter (checkTailCall insideSubBinding) - | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - checkTailCall insideSubBinding bodyExpr - | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr - | Expr.Let(binding, bodyExpr, _range, _frees) -> - checkTailCall true binding.Expr - checkTailCall insideSubBinding bodyExpr - | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> - decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) - | _ -> () - checkTailCall false bodyExpr - | _ -> () + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match bind.Expr with + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + let rec checkTailCall (insideSubBinding: bool) expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall insideSubBinding funcExpr + exprs |> List.iter (checkTailCall insideSubBinding) + | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + checkTailCall insideSubBinding bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let(binding, bodyExpr, _range, _frees) -> + checkTailCall true binding.Expr + checkTailCall insideSubBinding bodyExpr + | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | _ -> () + checkTailCall false bodyExpr + | _ -> () // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 3be231e8e12..6cc93812342 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1573,6 +1573,7 @@ featureNonInlineLiteralsAsPrintfFormat,"String values marked as literals and IL featureNestedCopyAndUpdate,"Nested record field copy-and-update" featureExtendedStringInterpolation,"Extended string interpolation similar to C# raw string literals." featureWarningWhenMultipleRecdTypeChoice,"Raises warnings when multiple record type matches were found during name resolution because of overlapping field names." +featureChkNotTailRecursive,"Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way." 3353,fsiInvalidDirective,"Invalid directive '#%s %s'" 3354,tcNotAFunctionButIndexerNamedIndexingNotYetEnabled,"This value supports indexing, e.g. '%s.[index]'. The syntax '%s[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." 3354,tcNotAFunctionButIndexerIndexingNotYetEnabled,"This expression supports indexing, e.g. 'expr.[index]'. The syntax 'expr[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." @@ -1694,4 +1695,4 @@ featureEscapeBracesInFormattableString,"Escapes curly braces before calling Form 3564,parsMissingUnionCaseName,"Missing union case name" 3565,parsExpectingType,"Expecting type" 3566,tcMultipleRecdTypeChoice,"Multiple type matches were found:\n%s\nThe type '%s' was used. Due to the overlapping field names\n%s\nconsider using type annotations or change the order of open statements." -3567,chkNotTailRecursive,"The member or function '%s' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." +3567,chkNotTailRecursive,"The member or function '%s' has the 'TailCall' attribute, but is not being used in a tail recursive way." diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 996b63760e8..cab5a1354a4 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -68,6 +68,7 @@ type LanguageFeature = | NestedCopyAndUpdate | ExtendedStringInterpolation | WarningWhenMultipleRecdTypeChoice + | WarningWhenTailRecAttributeButNonTailRecUsage /// LanguageVersion management type LanguageVersion(versionText) = @@ -159,6 +160,7 @@ type LanguageVersion(versionText) = LanguageFeature.NestedCopyAndUpdate, previewVersion LanguageFeature.ExtendedStringInterpolation, previewVersion LanguageFeature.WarningWhenMultipleRecdTypeChoice, previewVersion + LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage, previewVersion ] @@ -282,6 +284,7 @@ type LanguageVersion(versionText) = | LanguageFeature.NestedCopyAndUpdate -> FSComp.SR.featureNestedCopyAndUpdate () | LanguageFeature.ExtendedStringInterpolation -> FSComp.SR.featureExtendedStringInterpolation () | LanguageFeature.WarningWhenMultipleRecdTypeChoice -> FSComp.SR.featureWarningWhenMultipleRecdTypeChoice () + | LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage -> FSComp.SR.featureChkNotTailRecursive () /// 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 ab85fdc4aae..4dbcea6d061 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -58,6 +58,7 @@ type LanguageFeature = | NestedCopyAndUpdate | ExtendedStringInterpolation | WarningWhenMultipleRecdTypeChoice + | WarningWhenTailRecAttributeButNonTailRecUsage /// LanguageVersion management type LanguageVersion = diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index d307f04255c..ef72d45e8e9 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Povolit implicitní atribut Extension pro deklarující typy, moduly + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption využití člena výchozího rozhraní diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 72613b5cc13..18088d3c46d 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Implizites Erweiterungsattribut für deklarierende Typen und Module zulassen + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption standardmäßige Schnittstellenmembernutzung diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 092b9fcf4b9..15746afcdad 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Permitir atributo Extension implícito en tipos declarativo, módulos + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption consumo de miembros de interfaz predeterminados diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 57cd560efc8..fc8e0da1057 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Autoriser l’attribut implicite Extension lors de la déclaration des types, modules + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption consommation par défaut des membres d'interface diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index f09cca01cc0..b73ca2b27b7 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Consentire l'attributo estensione implicito per i tipi dichiarabili, i moduli + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption utilizzo predefinito dei membri di interfaccia diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index e6ab7968460..6ffd9ecbf35 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 型、モジュールの宣言で暗黙的な拡張属性を許可する + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 既定のインターフェイス メンバーの消費 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 49a5f99af79..ca752184731 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 유형, 모듈 선언에 암시적 확장 속성 허용 + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 기본 인터페이스 멤버 사용 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index e7b7c62e149..65f6cbe7c3a 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Zezwalaj na niejawny atrybut Rozszerzenie dla deklarujących typów, modułów + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption domyślne użycie składowej interfejsu diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 1f7e8682757..e20f70c1012 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Permitir atributo de Extensão implícito em tipos declarativos, módulos + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption consumo de membro da interface padrão diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 158196512f4..89e9bb0b369 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Разрешить атрибут неявного расширения для объявляющих типов, модулей + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption использование элемента интерфейса по умолчанию diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 8a104142eae..0be3824a4c2 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Türler, modüller bildirirken örtük Extension özniteliğine izin ver + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption varsayılan arabirim üyesi tüketimi diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 79c2293129c..54ac5bde6a6 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 允许对声明类型、模块使用隐式扩展属性 + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 默认接口成员消耗 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 13012ef998d..1441c041f02 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 允許宣告類型、模組上的隱含擴充屬性 + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 預設介面成員使用 diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 48c5a39590c..7b4e90e52ad 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -2,7 +2,6 @@ namespace FSharp.Compiler.ComponentTests.ErrorMessages open FSharp.Test.Compiler open FSharp.Test.Compiler.Assertions.StructuredResultsAsserts -open Xunit module ``TailCall Attribute`` = @@ -18,6 +17,7 @@ let rec fact n acc = else (fact (n-1) (mul n acc)) + 23 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -27,14 +27,14 @@ let rec fact n acc = EndLine = 8 EndColumn = 33 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 15 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -49,6 +49,7 @@ let rec fact n acc = | _ -> (fact (n-1) (mul n acc)) + 23 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -58,14 +59,14 @@ let rec fact n acc = EndLine = 8 EndColumn = 35 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 17 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -82,6 +83,7 @@ let rec fact n acc = r + 23 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -91,7 +93,7 @@ let rec fact n acc = EndLine = 9 EndColumn = 21 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -109,6 +111,7 @@ let r = fact 100000 1 r |> ignore """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -139,6 +142,7 @@ and [] baz x = bar (x - 1) // OK: tail-recursive call. """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -148,14 +152,14 @@ and [] baz x = EndLine = 13 EndColumn = 20 } Message = - "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 EndColumn = 12 } Message = - "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -166,6 +170,7 @@ type C () = member this.M1() = this.M1() + 1 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -175,7 +180,7 @@ type C () = EndLine = 4 EndColumn = 33 } Message = - "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -186,6 +191,7 @@ type C () = member this.M1() = this.M1() """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -202,6 +208,7 @@ type C () = this.M1() // ok """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -218,6 +225,7 @@ type F () = this.M1() + 2 // should warn """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -227,14 +235,14 @@ type F () = EndLine = 5 EndColumn = 18 } Message = - "The member or function 'M2' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 9 StartColumn = 9 EndLine = 9 EndColumn = 18 } Message = - "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -253,6 +261,7 @@ let f () = r |> ignore """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -268,6 +277,7 @@ let rec f x : seq = } """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -277,7 +287,7 @@ let rec f x : seq = EndLine = 5 EndColumn = 18 } Message = - "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -290,6 +300,7 @@ let rec f x : seq = } """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -299,14 +310,14 @@ let rec f x : seq = EndLine = 5 EndColumn = 23 } Message = - "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 EndColumn = 17 } Message = - "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -316,5 +327,6 @@ let rec f x : seq = let rec f x = seq { yield! f (x-1) } """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed From 190bda525c5003ce25d437946a7b1848f47d80fa Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 7 Jun 2023 09:30:09 +0200 Subject: [PATCH 14/31] improve tests a bit --- .../ErrorMessages/TailCallAttribute.fs | 46 ++++++++++++------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 7b4e90e52ad..4b4fec43620 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -14,7 +14,7 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else (fact (n-1) (mul n acc)) + 23 + else (fact (n - 1) (mul n acc)) + 23 """ |> FSharp |> withLangVersionPreview @@ -25,7 +25,7 @@ let rec fact n acc = Range = { StartLine = 8 StartColumn = 11 EndLine = 8 - EndColumn = 33 } + EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 @@ -46,7 +46,7 @@ let mul x y = x * y let rec fact n acc = match n with | 0 -> acc - | _ -> (fact (n-1) (mul n acc)) + 23 + | _ -> (fact (n - 1) (mul n acc)) + 23 """ |> FSharp |> withLangVersionPreview @@ -57,7 +57,7 @@ let rec fact n acc = Range = { StartLine = 8 StartColumn = 13 EndLine = 8 - EndColumn = 35 } + EndColumn = 37 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 @@ -79,7 +79,7 @@ let rec fact n acc = match n with | 0 -> acc | _ -> - let r = fact (n-1) (mul n acc) + let r = fact (n - 1) (mul n acc) r + 23 """ |> FSharp @@ -105,7 +105,9 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else fact (n-1) (mul n acc) + else + printfn "%A" n + fact (n - 1) (mul n acc) let r = fact 100000 1 r |> ignore @@ -188,7 +190,9 @@ type C () = """ type C () = [] - member this.M1() = this.M1() + member this.M1() = + printfn "M1 called" + this.M1() """ |> FSharp |> withLangVersionPreview @@ -201,10 +205,12 @@ type C () = type C () = [] member this.M1() = + printfn "M1 called" this.M2() // ok [] member this.M2() = + printfn "M2 called" this.M1() // ok """ |> FSharp @@ -218,10 +224,12 @@ type C () = type F () = [] member this.M1() = + printfn "M1 called" this.M2() + 1 // should warn [] member this.M2() = + printfn "M2 called" this.M1() + 2 // should warn """ |> FSharp @@ -230,16 +238,16 @@ type F () = |> shouldFail |> withResults [ { Error = Warning 3567 - Range = { StartLine = 5 + Range = { StartLine = 6 StartColumn = 9 - EndLine = 5 + EndLine = 6 EndColumn = 18 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 - Range = { StartLine = 9 + Range = { StartLine = 11 StartColumn = 9 - EndLine = 9 + EndLine = 11 EndColumn = 18 } Message = "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } @@ -254,7 +262,9 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else fact (n-1) (mul n acc) + else + printfn "%A" n + fact (n - 1) (mul n acc) let f () = let r = fact 100000 1 @@ -271,7 +281,7 @@ let f () = [] let rec f x : seq = seq { - let r = f (x-1) // Warning: this call is not tail-recursive + let r = f (x - 1) let r2 = Seq.map (fun x -> x + 1) r yield! r2 } @@ -296,7 +306,7 @@ let rec f x : seq = [] let rec f x : seq = seq { - yield! f (x-1) |> Seq.map (fun x -> x + 1) + yield! f (x - 1) |> Seq.map (fun x -> x + 1) } """ |> FSharp @@ -308,7 +318,7 @@ let rec f x : seq = Range = { StartLine = 5 StartColumn = 16 EndLine = 5 - EndColumn = 23 } + EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 @@ -324,7 +334,11 @@ let rec f x : seq = let ``Don't warn for valid tailcalls in seq expression`` () = """ [] -let rec f x = seq { yield! f (x-1) } +let rec f x = seq { + let y = x - 1 + let z = y - 1 + yield! f (z - 1) +} """ |> FSharp |> withLangVersionPreview From 42f876e7bc90d28819d9216d00fc510db1b848c0 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 7 Jun 2023 12:36:24 +0200 Subject: [PATCH 15/31] add tests for async expressions --- src/Compiler/Checking/PostInferenceChecks.fs | 18 ++++---- .../ErrorMessages/TailCallAttribute.fs | 41 +++++++++++++++++++ 2 files changed, 50 insertions(+), 9 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 6969e94442f..e0f9f1872b4 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -205,9 +205,9 @@ type IsTailCall = isUnitTy g returnTy | None -> false - static member fromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) + static member YesFromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) - static member fromExpr (g: TcGlobals) (expr: Expr) = + static member YesFromExpr (g: TcGlobals) (expr: Expr) = match expr with | Expr.Val(valRef, _valUseFlag, _range) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) | _ -> IsTailCall.Yes false @@ -1034,7 +1034,7 @@ and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = /// Check call arguments, including the return argument. and CheckCall cenv env m returnTy args ctxts ctxt = - let limitArgs = CheckExprs cenv env args ctxts + let limitArgs = CheckExprs cenv env args ctxts IsTailCall.No CheckCallLimitArgs cenv env m returnTy limitArgs ctxt /// Check call arguments, including the return argument. The receiver argument is handled differently. @@ -1050,7 +1050,7 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No let limitArgs = - let limitArgs = CheckExprs cenv env args ctxts + let limitArgs = CheckExprs cenv env args ctxts (IsTailCall.Yes false) // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike receiverLimit then // Scope is 1 to ensure any by-refs returned can only be prevented for out of scope of the function/method, not visibility. @@ -1383,7 +1383,7 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckTypeInstNoByrefs cenv env m tyargs CheckTypeNoInnerByrefs cenv env m returnTy - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = let g = cenv.g @@ -1662,7 +1662,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = NoLimit | TOp.Coerce, [tgtTy;srcTy], [x] -> - let isTailCall = IsTailCall.fromExpr cenv.g x + let isTailCall = IsTailCall.YesFromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then CheckExpr cenv env x ctxt isTailCall else @@ -1898,11 +1898,11 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT CheckNoReraise cenv None expr limit -and CheckExprs cenv env exprs ctxts : Limit = +and CheckExprs cenv env exprs ctxts isTailCall : Limit = let ctxts = Array.ofList ctxts let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No exprs - |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) IsTailCall.No) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) isTailCall) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = @@ -2155,7 +2155,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () - let isTailCall = IsTailCall.fromVal g bind.Var + let isTailCall = IsTailCall.YesFromVal g bind.Var let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 4b4fec43620..b0de56353e7 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -344,3 +344,44 @@ let rec f x = seq { |> withLangVersionPreview |> typecheck |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in async expression`` () = + """ +[] +let rec f x = async { return! f (x-1) } + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in async expression`` () = + """ +[] +let rec f x = async { + let! r = f (x - 1) + return r +} + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 14 + EndLine = 4 + EndColumn = 23 } + Message = + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 14 + EndLine = 4 + EndColumn = 15 } + Message = + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From 4ce98501c5ed5f22193722a9cded477aab3a48f9 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 8 Jun 2023 18:42:17 +0200 Subject: [PATCH 16/31] add tests for module rec --- .../ErrorMessages/TailCallAttribute.fs | 72 ++++++++++++++++++- 1 file changed, 71 insertions(+), 1 deletion(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index b0de56353e7..b0173bd7837 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -349,7 +349,11 @@ let rec f x = seq { let ``Don't warn for valid tailcalls in async expression`` () = """ [] -let rec f x = async { return! f (x-1) } +let rec f x = async { + let y = x - 1 + let z = y - 1 + return! f (z - 1) +} """ |> FSharp |> withLangVersionPreview @@ -385,3 +389,69 @@ let rec f x = async { Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for valid tailcalls in rec module`` () = + """ +module rec M = + + module M1 = + [] + let m1func() = M2.m2func() + + module M2 = + [] + let m2func() = M1.m1func() + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in rec module`` () = + """ +module rec M = + + module M1 = + [] + let m1func() = 1 + M2.m2func() + + module M2 = + [] + let m2func() = 2 + M1.m1func() + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 6 + StartColumn = 28 + EndLine = 6 + EndColumn = 39 } + Message = + "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 6 + StartColumn = 28 + EndLine = 6 + EndColumn = 37 } + Message = + "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 10 + StartColumn = 28 + EndLine = 10 + EndColumn = 39 } + Message = + "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 10 + StartColumn = 28 + EndLine = 10 + EndColumn = 37 } + Message = + "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From 6aa48487c8ec50dd27c5a9d042a08a1e01cea13c Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 12 Jun 2023 15:07:45 +0200 Subject: [PATCH 17/31] Improve handling of ModuleOrNamespaceContents.TMDefDo and extend testing --- src/Compiler/Checking/PostInferenceChecks.fs | 26 ++++++++++----- .../ErrorMessages/TailCallAttribute.fs | 33 +++++++++++++++++++ 2 files changed, 51 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index e0f9f1872b4..866f9ca9c25 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -193,6 +193,14 @@ let CombineLimits limits = (NoLimit, limits) ||> List.fold CombineTwoLimits +let (|ValUseAtApp|_|) e = + match e with + | InnerExprPat( + Expr.App( + InnerExprPat(Expr.Val(valRef = vref; flags = valUseFlags)),_,_,[],_) + | Expr.Val(valRef = vref; flags = valUseFlags)) -> Some (vref, valUseFlags) + | _ -> None + type IsTailCall = | Yes of bool // true indicates "has unit return type and must return void" | No @@ -209,7 +217,7 @@ type IsTailCall = static member YesFromExpr (g: TcGlobals) (expr: Expr) = match expr with - | Expr.Val(valRef, _valUseFlag, _range) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) + | ValUseAtApp(valRef, _) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) | _ -> IsTailCall.Yes false member x.AtExprLambda = @@ -221,11 +229,6 @@ type IsTailCall = let IsValRefIsDllImport g (vref:ValRef) = vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute -let (|ValUseAtApp|_|) e = - match e with - | InnerExprPat(Expr.App(InnerExprPat(Expr.Val(vref,valUseFlags,_)),_,_,[],_) | Expr.Val(vref,valUseFlags,_)) -> Some (vref, valUseFlags) - | _ -> None - type cenv = { boundVals: Dictionary // really a hash set @@ -952,7 +955,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i match valUseFlags with | PossibleConstrainedCall _ -> true | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) // Todo: discuss if this is really enough to render a tail call invalid let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) not isNewObj && @@ -2693,7 +2696,14 @@ and CheckDefnInModule cenv env mdef = | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs cenv env IsTailCall.No e + let isTailCall = + match stripDebugPoints e with + | Expr.App(funcExpr = funcExpr) -> + match funcExpr with + | ValUseAtApp (vref, _valUseFlags) -> IsTailCall.YesFromVal cenv.g vref.Deref + | _ -> IsTailCall.No + | _ -> IsTailCall.No + CheckExprNoByrefs cenv env isTailCall e | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env isRec mbind = diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index b0173bd7837..f5c3953905a 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -193,6 +193,9 @@ type C () = member this.M1() = printfn "M1 called" this.M1() + +let c = C() +c.M1() """ |> FSharp |> withLangVersionPreview @@ -402,6 +405,8 @@ module rec M = module M2 = [] let m2func() = M1.m1func() + +M.M1.m1func() """ |> FSharp |> withLangVersionPreview @@ -455,3 +460,31 @@ module rec M = Message = "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Warn for byref parameters`` () = + """ +[] +let rec foo(x: int byref) = foo(&x) +let run() = let mutable x = 0 in foo(&x) + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 3 + StartColumn = 29 + EndLine = 3 + EndColumn = 36 } + Message = + "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 34 + EndLine = 4 + EndColumn = 41 } + Message = + "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From 78839a2d0547b28c1cdb1958567a1ea270768df0 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 13 Jun 2023 17:11:32 +0200 Subject: [PATCH 18/31] suppress some invalid warnings by keeping track of ranges that are annotated with [] --- src/Compiler/Checking/PostInferenceChecks.fs | 110 +++++++++++++----- .../ErrorMessages/TailCallAttribute.fs | 26 ++--- 2 files changed, 90 insertions(+), 46 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 866f9ca9c25..79c274e1b69 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -87,6 +87,8 @@ type env = /// Values in this recursive scope that have been marked [] mutable mustTailCall: Zset + + mutable mustTailCallRanges: Map /// Are we in a quotation? quote : bool @@ -335,13 +337,17 @@ let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit -let BindVal cenv env (v: Val) = +let BindVal cenv env (exprRange: Range option) (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then env.mustTailCall <- Zset.add v env.mustTailCall + match exprRange with + | Some r when not (env.mustTailCallRanges.ContainsKey v.LogicalName) -> + env.mustTailCallRanges <- Map.add v.LogicalName r env.mustTailCallRanges + | _ -> () let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = @@ -367,7 +373,10 @@ let BindVal cenv env (v: Val) = else warning (Error(FSComp.SR.chkUnusedValue v.DisplayName, v.Range)) -let BindVals cenv env vs = List.iter (BindVal cenv env) vs +let BindVals cenv env (exprRanges: Range option list) vs = + let zipped = List.zip exprRanges vs + zipped + |> List.iter (fun (exprRange, v) -> BindVal cenv env exprRange v) let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then @@ -810,6 +819,32 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | None -> () | Some e -> errorR(e) +let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = + env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) + +let rec allRangesOfModDef mdef = + seq { match mdef with + | TMDefRec(bindings = mbinds) -> + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + let r = + match (stripExpr bind.Expr) with + | Expr.Lambda _ -> bind.Expr.Range + | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range + | e -> e.Range + yield r + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allRangesOfModDef def + | TMDefLet(binding = bind) -> + let e = stripExpr bind.Expr + yield e.Range + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allRangesOfModDef def + } + /// Check an expression, where the expression is in a position where byrefs can be generated let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore @@ -834,7 +869,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then @@ -937,9 +972,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i match f with | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - let canTailCall = + let canTailCall, noTailCallBlockers = match isTailCall with - | IsTailCall.No -> false + | IsTailCall.No -> + false, true | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value @@ -958,20 +994,24 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) // Todo: discuss if this is really enough to render a tail call invalid let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) - not isNewObj && - not isSuperInit && - not isSelfInit && - not mustGenerateUnitAfterCall && - isNil laterArgs && - not (IsValRefIsDllImport cenv.g vref) && - not isCCall && - not hasByrefArg + let noTailCallBlockers = + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + noTailCallBlockers, noTailCallBlockers else - true + true, true - if not canTailCall then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - () + if not canTailCall then + if not noTailCallBlockers then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + elif (env.mustTailCallRanges.Item vref.LogicalName |> fun recRange -> rangeContainsRange recRange _m) then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) | _ -> () | _ -> () @@ -1079,7 +1119,7 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf PermitByRefExpr.Yes let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind - BindVal cenv env v + BindVal cenv env None v LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall CheckExprLinear cenv env body ctxt contf isTailCall @@ -1124,7 +1164,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) CheckExprNoByrefs cenv env isTailCall noneBranchExpr - BindVal cenv env someVar + BindVal cenv env None someVar CheckExprNoByrefs cenv env isTailCall someBranchExpr true @@ -1154,7 +1194,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo | IntegerForLoopExpr (_sp1, _sp2, _style, e1, e2, v, e3, _m) -> CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 - BindVal cenv env v + BindVal cenv env None v CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 true @@ -1170,8 +1210,9 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo true | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> - targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> - BindVals cenv env vs + targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> + let exprRanges = List.replicate vs.Length None + BindVals cenv env exprRanges vs CheckExprNoByrefs cenv env isTailCall targetExpr) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree true @@ -1180,7 +1221,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo // Restriction: resumable code can't contain local constrained generic functions when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore - BindVal cenv env bind.Var + BindVal cenv env None bind.Var CheckExprNoByrefs cenv env isTailCall bodyExpr true @@ -1349,7 +1390,8 @@ and CheckStructStateMachineExpr cenv env expr info = if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) - BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] + let exprRanges = [None; None; None; None] + BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody @@ -1460,8 +1502,10 @@ and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = CheckDecisionTree cenv env dtree CheckDecisionTreeTargets cenv env targets ctxt isTailCall -and CheckLetRec cenv env (binds, bodyExpr) isTailCall = - BindVals cenv env (valsOfBinds binds) +and CheckLetRec cenv env (binds, bodyExpr) isTailCall = + let vals = valsOfBinds binds + let exprRanges = List.replicate (List.length binds) None + BindVals cenv env exprRanges vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr NoLimit @@ -1851,7 +1895,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT ) for arg in syntacticArgs do - BindVal cenv env arg + BindVal cenv env None arg // Check escapes in the body. Allow access to protected things within members. let freesOpt = CheckEscapes cenv memInfo.IsSome m syntacticArgs body @@ -1931,7 +1975,8 @@ and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = |> CombineLimits and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = - BindVals cenv env vs + let exprRanges = List.replicate vs.Length None + BindVals cenv env exprRanges vs for v in vs do CheckValSpec PermitByRefType.All cenv env v CheckExpr cenv env targetExpr ctxt isTailCall @@ -2684,13 +2729,15 @@ and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, tycons, mspecs, m) -> CheckNothingAfterEntryPoint cenv m - if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) + if isRec then + let ranges = allRangesOfModDef mdef |> Seq.toList |> List.map Some + BindVals cenv env ranges (allValsOfModDef mdef |> Seq.toList) CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m CheckModuleBinding cenv env false bind - BindVal cenv env bind.Var + BindVal cenv env (Some bind.Expr.Range) bind.Var | TMDefOpens _ -> () | TMDefDo(e, m) -> @@ -2709,7 +2756,7 @@ and CheckDefnInModule cenv env mdef = and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - BindVals cenv env (valsOfBinds [bind]) + BindVals cenv env [None] (valsOfBinds [bind]) CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec @@ -2759,6 +2806,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v boundTyparNames=[] argVals = ValMap.Empty mustTailCall = Zset.empty valOrder + mustTailCallRanges = Map.Empty boundTypars= TyparMap.Empty reflect=false external=false diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index f5c3953905a..d2e1cba418f 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -272,6 +272,8 @@ let rec fact n acc = let f () = let r = fact 100000 1 r |> ignore + +fact 100000 1 |> ignore """ |> FSharp |> withLangVersionPreview @@ -342,6 +344,8 @@ let rec f x = seq { let z = y - 1 yield! f (z - 1) } + +let a: seq = f 10 """ |> FSharp |> withLangVersionPreview @@ -357,6 +361,8 @@ let rec f x = async { let z = y - 1 return! f (z - 1) } + +let a: Async = f 10 """ |> FSharp |> withLangVersionPreview @@ -406,7 +412,11 @@ module rec M = [] let m2func() = M1.m1func() -M.M1.m1func() + let f () = + M1.m1func() |> ignore + +M.M1.m1func() |> ignore +M.M2.m2func() """ |> FSharp |> withLangVersionPreview @@ -431,13 +441,6 @@ module rec M = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 - Range = { StartLine = 6 - StartColumn = 28 - EndLine = 6 - EndColumn = 39 } - Message = - "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 6 StartColumn = 28 @@ -445,13 +448,6 @@ module rec M = EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 - Range = { StartLine = 10 - StartColumn = 28 - EndLine = 10 - EndColumn = 39 } - Message = - "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 10 StartColumn = 28 From 0e3db93a3c3a9db28c9558aff21421ba3ade759b Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 13 Jun 2023 17:41:21 +0200 Subject: [PATCH 19/31] fix build --- src/Compiler/Checking/PostInferenceChecks.fs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 79c274e1b69..928e46f65f3 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -822,9 +822,14 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) -let rec allRangesOfModDef mdef = +let rec allRangesOfModDef mdef = + let abstractSlotRangesOfTycons (tycons: Tycon list) = + abstractSlotValRefsOfTycons tycons + |> List.map (fun v -> v.Deref.Range) + seq { match mdef with - | TMDefRec(bindings = mbinds) -> + | TMDefRec(tycons = tycons; bindings = mbinds) -> + yield! abstractSlotRangesOfTycons tycons for mbind in mbinds do match mbind with | ModuleOrNamespaceBinding.Binding bind -> @@ -1504,7 +1509,7 @@ and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = and CheckLetRec cenv env (binds, bodyExpr) isTailCall = let vals = valsOfBinds binds - let exprRanges = List.replicate (List.length binds) None + let exprRanges = List.replicate vals.Length None BindVals cenv env exprRanges vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr From 61cf291db8a4fbd63658a7b2c40efbe55bd72f6c Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 14 Jun 2023 08:35:07 +0200 Subject: [PATCH 20/31] use Stamp instead of LogicalName as the Map key --- src/Compiler/Checking/PostInferenceChecks.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 928e46f65f3..898bc4f3429 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -88,7 +88,7 @@ type env = /// Values in this recursive scope that have been marked [] mutable mustTailCall: Zset - mutable mustTailCallRanges: Map + mutable mustTailCallRanges: Map /// Are we in a quotation? quote : bool @@ -345,8 +345,8 @@ let BindVal cenv env (exprRange: Range option) (v: Val) = if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then env.mustTailCall <- Zset.add v env.mustTailCall match exprRange with - | Some r when not (env.mustTailCallRanges.ContainsKey v.LogicalName) -> - env.mustTailCallRanges <- Map.add v.LogicalName r env.mustTailCallRanges + | Some r when not (env.mustTailCallRanges.ContainsKey v.Stamp) -> + env.mustTailCallRanges <- Map.add v.Stamp r env.mustTailCallRanges | _ -> () let topLevelBindingHiddenBySignatureFile () = @@ -1015,7 +1015,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i if not canTailCall then if not noTailCallBlockers then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - elif (env.mustTailCallRanges.Item vref.LogicalName |> fun recRange -> rangeContainsRange recRange _m) then + elif (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange _m) then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) | _ -> () | _ -> () From 1d9bf6b29ee91271f25c9752f70969797ceb4565 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 15 Jun 2023 14:32:28 +0200 Subject: [PATCH 21/31] fix error number after merge --- src/Compiler/FSComp.txt | 2 +- .../ErrorMessages/TailCallAttribute.fs | 38 +++++++++---------- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 1933fef71cc..ce86abdd538 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1699,4 +1699,4 @@ featureEscapeBracesInFormattableString,"Escapes curly braces before calling Form featureInformationalObjInferenceDiagnostic,"Diagnostic 3559 (warn when obj inferred) at informational level, off by default" 3566,tcMultipleRecdTypeChoice,"Multiple type matches were found:\n%s\nThe type '%s' was used. Due to the overlapping field names\n%s\nconsider using type annotations or change the order of open statements." 3567,parsMissingMemberBody,"Expecting member body" -3567,chkNotTailRecursive,"The member or function '%s' has the 'TailCall' attribute, but is not being used in a tail recursive way." +3568,chkNotTailRecursive,"The member or function '%s' has the 'TailCall' attribute, but is not being used in a tail recursive way." diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index d2e1cba418f..3d556c9ab46 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -21,14 +21,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 @@ -53,14 +53,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 37 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 @@ -87,7 +87,7 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 9 StartColumn = 17 EndLine = 9 @@ -148,14 +148,14 @@ and [] baz x = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 EndColumn = 20 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 @@ -176,7 +176,7 @@ type C () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 24 EndLine = 4 @@ -240,14 +240,14 @@ type F () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 6 StartColumn = 9 EndLine = 6 EndColumn = 18 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 11 StartColumn = 9 EndLine = 11 @@ -296,7 +296,7 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 5 StartColumn = 17 EndLine = 5 @@ -319,14 +319,14 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 @@ -383,14 +383,14 @@ let rec f x = async { |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 EndColumn = 23 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 @@ -441,14 +441,14 @@ module rec M = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 6 StartColumn = 28 EndLine = 6 EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 10 StartColumn = 28 EndLine = 10 @@ -469,14 +469,14 @@ let run() = let mutable x = 0 in foo(&x) |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 3 StartColumn = 29 EndLine = 3 EndColumn = 36 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 34 EndLine = 4 From d61e04de9f89022bdb8aec9c871860031987b0b3 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 09:47:43 +0200 Subject: [PATCH 22/31] small optimization --- src/Compiler/Checking/PostInferenceChecks.fs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 898bc4f3429..231627ce3a5 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -822,14 +822,14 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) -let rec allRangesOfModDef mdef = - let abstractSlotRangesOfTycons (tycons: Tycon list) = +let rec allValsAndRangesOfModDef mdef = + let abstractSlotValsAndRangesOfTycons (tycons: Tycon list) = abstractSlotValRefsOfTycons tycons - |> List.map (fun v -> v.Deref.Range) + |> List.map (fun v -> v.Deref, v.Deref.Range) seq { match mdef with | TMDefRec(tycons = tycons; bindings = mbinds) -> - yield! abstractSlotRangesOfTycons tycons + yield! abstractSlotValsAndRangesOfTycons tycons for mbind in mbinds do match mbind with | ModuleOrNamespaceBinding.Binding bind -> @@ -838,16 +838,16 @@ let rec allRangesOfModDef mdef = | Expr.Lambda _ -> bind.Expr.Range | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range | e -> e.Range - yield r - | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allRangesOfModDef def + yield bind.Var, r + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndRangesOfModDef def | TMDefLet(binding = bind) -> let e = stripExpr bind.Expr - yield e.Range + yield bind.Var, e.Range | TMDefDo _ -> () | TMDefOpens _ -> () | TMDefs defs -> for def in defs do - yield! allRangesOfModDef def + yield! allValsAndRangesOfModDef def } /// Check an expression, where the expression is in a position where byrefs can be generated @@ -2735,8 +2735,8 @@ and CheckDefnInModule cenv env mdef = | TMDefRec(isRec, _opens, tycons, mspecs, m) -> CheckNothingAfterEntryPoint cenv m if isRec then - let ranges = allRangesOfModDef mdef |> Seq.toList |> List.map Some - BindVals cenv env ranges (allValsOfModDef mdef |> Seq.toList) + let valls, ranges = allValsAndRangesOfModDef mdef |> Seq.toList |> List.unzip + BindVals cenv env (ranges |> List.map Some) valls CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> From ccdc8730a5e2bb376e0fe171eeb756d5d1a21191 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 10:16:53 +0200 Subject: [PATCH 23/31] merge fix --- src/Compiler/FSComp.txt | 1 + src/Compiler/xlf/FSComp.txt.cs.xlf | 2 +- src/Compiler/xlf/FSComp.txt.de.xlf | 2 +- src/Compiler/xlf/FSComp.txt.es.xlf | 2 +- src/Compiler/xlf/FSComp.txt.fr.xlf | 2 +- src/Compiler/xlf/FSComp.txt.it.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ja.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ko.xlf | 2 +- src/Compiler/xlf/FSComp.txt.pl.xlf | 2 +- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ru.xlf | 2 +- src/Compiler/xlf/FSComp.txt.tr.xlf | 2 +- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 2 +- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 2 +- 14 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 4b8c492139c..3c313fdf4ba 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1575,6 +1575,7 @@ featureExtendedStringInterpolation,"Extended string interpolation similar to C# featureWarningWhenMultipleRecdTypeChoice,"Raises warnings when multiple record type matches were found during name resolution because of overlapping field names." featureImprovedImpliedArgumentNames,"Improved implied argument names" featureStrictIndentation,"Raises errors on incorrect indentation, allows better recovery and analysis during editing" +featureChkNotTailRecursive,"Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way." 3353,fsiInvalidDirective,"Invalid directive '#%s %s'" 3354,tcNotAFunctionButIndexerNamedIndexingNotYetEnabled,"This value supports indexing, e.g. '%s.[index]'. The syntax '%s[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." 3354,tcNotAFunctionButIndexerIndexingNotYetEnabled,"This expression supports indexing, e.g. 'expr.[index]'. The syntax 'expr[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index 2678da79d15..f97ce9f0e77 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods Konstrukt let! ... and! ... se dá použít jen v případě, že tvůrce výpočetních výrazů definuje buď metodu {0}, nebo vhodné metody MergeSource a Bind. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 73f20d8b210..af0937c7a79 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods Das Konstrukt "let! ... and! ..." kann nur verwendet werden, wenn der Berechnungsausdrucks-Generator entweder eine {0}-Methode oder geeignete MergeSource- und Bind-Methoden definiert. diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 2afe4ff2f77..bf71867b916 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods La construcción "let! ... and! ..." solo se puede usar si el generador de expresiones de cálculo define un método "{0}" o bien los métodos "MergeSource" y "Bind" adecuados. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index c173918b90d..7b9c7880534 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods La construction 'let! ... and! ...' peut uniquement être utilisée si le générateur d'expressions de calcul définit une méthode '{0}' ou les méthodes 'MergeSource' et 'Bind' appropriées diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 4b780707a89..a92e361b278 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods È possibile usare il costrutto 'let! ... and! ...' solo se il generatore di espressioni di calcolo definisce un metodo '{0}' o metodi 'MergeSource' e 'Bind' appropriati diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 9a1806ff632..1dbd8e20a2f 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods 'let! ... and! ...' コンストラクトは、コンピュテーション式ビルダーが '{0}' メソッドまたは適切な 'MergeSource' および 'Bind' メソッドのいずれかを定義している場合にのみ使用できます diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 6c03b3f3ea1..4445d1f6370 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods 'let! ... and! ...' 구문은 계산 식 작성기에서 '{0}' 메서드 또는 적절한 'MergeSource' 및 'Bind' 메서드를 정의한 경우에만 사용할 수 있습니다. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 435ad8d30a4..eafdb361fea 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods Konstrukcji „let! ... and! ...” można użyć tylko wtedy, gdy konstruktor wyrażeń obliczeniowych definiuje metodę „{0}” lub odpowiednie metody „MergeSource” i „Bind” diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index f76e9f12e58..af19a611910 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods O constructo 'let! ... and! ...' só pode ser usado se o construtor de expressões de computação definir um método '{0}' ou um método 'MergeSource' ou 'Bind' apropriado diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index a83e3215725..f4995376031 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods Конструкцию "let! ... and! ..." можно использовать только в том случае, если построитель выражений с вычислениями определяет либо метод "{0}", либо соответствующие методы "MergeSource" и "Bind" diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 9e8eb13bc4a..67e4359633e 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods 'let! ... and! ...' yapısı, yalnızca hesaplama ifadesi oluşturucu bir '{0}' metodunu ya da uygun 'MergeSource' ve 'Bind' metotlarını tanımlarsa kullanılabilir diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 1c25540c18d..0a1e5bef2e5 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods 仅当计算表达式生成器定义了 "{0}" 方法或适当的 "MergeSource" 和 "Bind" 方法时，才可以使用 "let! ... and! ..." 构造 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index ed2e85df141..ca031b4785d 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods 只有在計算運算式產生器定義 '{0}' 方法或正確的 'MergeSource' 和 'Bind' 方法時，才可使用 'let! ... and! ...' 建構 From a938ee9d9ce60524d928c536f18d01bcce2960d6 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 11:13:14 +0200 Subject: [PATCH 24/31] adjust error number --- .../ErrorMessages/TailCallAttribute.fs | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 3d556c9ab46..3b978cbc387 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -21,14 +21,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 @@ -53,14 +53,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 37 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 @@ -87,7 +87,7 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 9 StartColumn = 17 EndLine = 9 @@ -148,14 +148,14 @@ and [] baz x = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 EndColumn = 20 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 @@ -176,7 +176,7 @@ type C () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 24 EndLine = 4 @@ -240,14 +240,14 @@ type F () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 6 StartColumn = 9 EndLine = 6 EndColumn = 18 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 11 StartColumn = 9 EndLine = 11 @@ -296,7 +296,7 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 5 StartColumn = 17 EndLine = 5 @@ -319,14 +319,14 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 @@ -383,14 +383,14 @@ let rec f x = async { |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 EndColumn = 23 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 @@ -441,14 +441,14 @@ module rec M = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 6 StartColumn = 28 EndLine = 6 EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 10 StartColumn = 28 EndLine = 10 @@ -469,14 +469,14 @@ let run() = let mutable x = 0 in foo(&x) |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 3 StartColumn = 29 EndLine = 3 EndColumn = 36 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 34 EndLine = 4 From 2e68157ebf834d62dcaa3b6b05abcefbc97664c0 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 12:11:45 +0200 Subject: [PATCH 25/31] another merge fix :( --- src/Compiler/FSComp.txt | 2 +- src/Compiler/xlf/FSComp.txt.cs.xlf | 2 +- src/Compiler/xlf/FSComp.txt.de.xlf | 2 +- src/Compiler/xlf/FSComp.txt.es.xlf | 2 +- src/Compiler/xlf/FSComp.txt.fr.xlf | 2 +- src/Compiler/xlf/FSComp.txt.it.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ja.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ko.xlf | 2 +- src/Compiler/xlf/FSComp.txt.pl.xlf | 2 +- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ru.xlf | 2 +- src/Compiler/xlf/FSComp.txt.tr.xlf | 2 +- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 2 +- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 2 +- 14 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 3c313fdf4ba..44dbfea3501 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1519,7 +1519,7 @@ notAFunctionButMaybeDeclaration,"This value is not a function and cannot be appl 3302,packageManagementRequiresVFive,"The 'package management' feature requires language version 5.0 or above" 3303,fromEndSlicingRequiresVFive,"The 'from the end slicing' feature requires language version 'preview'." 3304,poundiNotSupportedByRegisteredDependencyManagers,"#i is not supported by the registered PackageManagers" -3343,tcRequireMergeSourcesOrBindN,"The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '%s' method or appropriate 'MergeSource' and 'Bind' methods" +3343,tcRequireMergeSourcesOrBindN,"The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '%s' method or appropriate 'MergeSources' and 'Bind' methods" 3344,tcAndBangNotSupported,"This feature is not supported in this version of F#. You may need to add /langversion:preview to use this feature." 3345,tcInvalidUseBangBindingNoAndBangs,"use! may not be combined with and!" 3350,chkFeatureNotLanguageSupported,"Feature '%s' is not available in F# %s. Please use language version %s or greater." diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index f97ce9f0e77..2678da79d15 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods Konstrukt let! ... and! ... se dá použít jen v případě, že tvůrce výpočetních výrazů definuje buď metodu {0}, nebo vhodné metody MergeSource a Bind. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index af0937c7a79..73f20d8b210 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods Das Konstrukt "let! ... and! ..." kann nur verwendet werden, wenn der Berechnungsausdrucks-Generator entweder eine {0}-Methode oder geeignete MergeSource- und Bind-Methoden definiert. diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index bf71867b916..2afe4ff2f77 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods La construcción "let! ... and! ..." solo se puede usar si el generador de expresiones de cálculo define un método "{0}" o bien los métodos "MergeSource" y "Bind" adecuados. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 7b9c7880534..c173918b90d 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods La construction 'let! ... and! ...' peut uniquement être utilisée si le générateur d'expressions de calcul définit une méthode '{0}' ou les méthodes 'MergeSource' et 'Bind' appropriées diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index a92e361b278..4b780707a89 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods È possibile usare il costrutto 'let! ... and! ...' solo se il generatore di espressioni di calcolo definisce un metodo '{0}' o metodi 'MergeSource' e 'Bind' appropriati diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 1dbd8e20a2f..9a1806ff632 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods 'let! ... and! ...' コンストラクトは、コンピュテーション式ビルダーが '{0}' メソッドまたは適切な 'MergeSource' および 'Bind' メソッドのいずれかを定義している場合にのみ使用できます diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 4445d1f6370..6c03b3f3ea1 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods 'let! ... and! ...' 구문은 계산 식 작성기에서 '{0}' 메서드 또는 적절한 'MergeSource' 및 'Bind' 메서드를 정의한 경우에만 사용할 수 있습니다. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index eafdb361fea..435ad8d30a4 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods Konstrukcji „let! ... and! ...” można użyć tylko wtedy, gdy konstruktor wyrażeń obliczeniowych definiuje metodę „{0}” lub odpowiednie metody „MergeSource” i „Bind” diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index af19a611910..f76e9f12e58 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods O constructo 'let! ... and! ...' só pode ser usado se o construtor de expressões de computação definir um método '{0}' ou um método 'MergeSource' ou 'Bind' apropriado diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index f4995376031..a83e3215725 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods Конструкцию "let! ... and! ..." можно использовать только в том случае, если построитель выражений с вычислениями определяет либо метод "{0}", либо соответствующие методы "MergeSource" и "Bind" diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 67e4359633e..9e8eb13bc4a 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods 'let! ... and! ...' yapısı, yalnızca hesaplama ifadesi oluşturucu bir '{0}' metodunu ya da uygun 'MergeSource' ve 'Bind' metotlarını tanımlarsa kullanılabilir diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 0a1e5bef2e5..1c25540c18d 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods 仅当计算表达式生成器定义了 "{0}" 方法或适当的 "MergeSource" 和 "Bind" 方法时，才可以使用 "let! ... and! ..." 构造 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index ca031b4785d..ed2e85df141 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -1173,7 +1173,7 @@ - The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSource' and 'Bind' methods + The 'let! ... and! ...' construct may only be used if the computation expression builder defines either a '{0}' method or appropriate 'MergeSources' and 'Bind' methods 只有在計算運算式產生器定義 '{0}' 方法或正確的 'MergeSource' 和 'Bind' 方法時，才可使用 'let! ... and! ...' 建構 From 5a3e569002b8982c25d144049751d6cc93b0c9ae Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 18:02:19 +0200 Subject: [PATCH 26/31] simplify --- src/Compiler/Checking/PostInferenceChecks.fs | 21 ++++++++----------- .../ErrorMessages/TailCallAttribute.fs | 7 ------- 2 files changed, 9 insertions(+), 19 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 231627ce3a5..c0101b69b97 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -940,7 +940,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i // Some things are more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs match expr with - | Expr.App (f, _fty, _tyargs, argsl, _m) -> + | Expr.App (f, _fty, _tyargs, argsl, m) -> if cenv.reportErrors then @@ -977,16 +977,16 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i match f with | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - let canTailCall, noTailCallBlockers = + let canTailCall = match isTailCall with | IsTailCall.No -> - false, true + false | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty - let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m + let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau m if argsl.Length >= curriedArgInfos.Length then (List.splitAfter curriedArgInfos.Length argsl), returnTy else @@ -996,7 +996,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i match valUseFlags with | PossibleConstrainedCall _ -> true | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) // Todo: discuss if this is really enough to render a tail call invalid + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) let noTailCallBlockers = @@ -1008,15 +1008,12 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i not (IsValRefIsDllImport cenv.g vref) && not isCCall && not hasByrefArg - noTailCallBlockers, noTailCallBlockers + noTailCallBlockers else - true, true + true - if not canTailCall then - if not noTailCallBlockers then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - elif (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange _m) then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + if not canTailCall && (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange m) then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), m)) | _ -> () | _ -> () diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 3b978cbc387..d6868feb2ac 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -476,11 +476,4 @@ let run() = let mutable x = 0 in foo(&x) EndColumn = 36 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3569 - Range = { StartLine = 4 - StartColumn = 34 - EndLine = 4 - EndColumn = 41 } - Message = - "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] From b94f8ea9a0a459bb51a18f1d5c26323422a33481 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 30 Jun 2023 09:56:02 +0200 Subject: [PATCH 27/31] get rid of range-based approach, collect TailRec-attributed bindings upfront and just traverse these --- src/Compiler/Checking/PostInferenceChecks.fs | 137 +++++++++++++----- .../ErrorMessages/TailCallAttribute.fs | 14 ++ 2 files changed, 112 insertions(+), 39 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index c0101b69b97..2ccd02c2144 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -85,10 +85,11 @@ type env = /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature sigToImplRemapInfo: (Remap * SignatureHidingInfo) list - /// Values in this recursive scope that have been marked [] - mutable mustTailCall: Zset + /// Values in module that have been marked [] + mustTailCall: Zset - mutable mustTailCallRanges: Map + /// Recursive expressions of [] attributed values + mustTailCallExprs: Map /// Are we in a quotation? quote : bool @@ -337,18 +338,11 @@ let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit -let BindVal cenv env (exprRange: Range option) (v: Val) = +let BindVal cenv env (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 - if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then - env.mustTailCall <- Zset.add v env.mustTailCall - match exprRange with - | Some r when not (env.mustTailCallRanges.ContainsKey v.Stamp) -> - env.mustTailCallRanges <- Map.add v.Stamp r env.mustTailCallRanges - | _ -> () - let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = match v.TryDeclaringEntity with @@ -373,10 +367,7 @@ let BindVal cenv env (exprRange: Range option) (v: Val) = else warning (Error(FSComp.SR.chkUnusedValue v.DisplayName, v.Range)) -let BindVals cenv env (exprRanges: Range option list) vs = - let zipped = List.zip exprRanges vs - zipped - |> List.iter (fun (exprRange, v) -> BindVal cenv env exprRange v) +let BindVals cenv env vs = List.iter (BindVal cenv env) vs let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then @@ -819,9 +810,6 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | None -> () | Some e -> errorR(e) -let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = - env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) - let rec allValsAndRangesOfModDef mdef = let abstractSlotValsAndRangesOfTycons (tycons: Tycon list) = abstractSlotValRefsOfTycons tycons @@ -874,7 +862,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then @@ -1012,7 +1000,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i else true - if not canTailCall && (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange m) then + if not canTailCall then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), m)) | _ -> () | _ -> () @@ -1121,7 +1109,7 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf PermitByRefExpr.Yes let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind - BindVal cenv env None v + BindVal cenv env v LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall CheckExprLinear cenv env body ctxt contf isTailCall @@ -1166,7 +1154,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) CheckExprNoByrefs cenv env isTailCall noneBranchExpr - BindVal cenv env None someVar + BindVal cenv env someVar CheckExprNoByrefs cenv env isTailCall someBranchExpr true @@ -1196,7 +1184,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo | IntegerForLoopExpr (_sp1, _sp2, _style, e1, e2, v, e3, _m) -> CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 - BindVal cenv env None v + BindVal cenv env v CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 true @@ -1213,8 +1201,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> - let exprRanges = List.replicate vs.Length None - BindVals cenv env exprRanges vs + BindVals cenv env vs CheckExprNoByrefs cenv env isTailCall targetExpr) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree true @@ -1223,7 +1210,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo // Restriction: resumable code can't contain local constrained generic functions when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore - BindVal cenv env None bind.Var + BindVal cenv env bind.Var CheckExprNoByrefs cenv env isTailCall bodyExpr true @@ -1392,8 +1379,7 @@ and CheckStructStateMachineExpr cenv env expr info = if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) - let exprRanges = [None; None; None; None] - BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] + BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody @@ -1506,8 +1492,7 @@ and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = and CheckLetRec cenv env (binds, bodyExpr) isTailCall = let vals = valsOfBinds binds - let exprRanges = List.replicate vals.Length None - BindVals cenv env exprRanges vals + BindVals cenv env vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr NoLimit @@ -1897,7 +1882,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT ) for arg in syntacticArgs do - BindVal cenv env None arg + BindVal cenv env arg // Check escapes in the body. Allow access to protected things within members. let freesOpt = CheckEscapes cenv memInfo.IsSome m syntacticArgs body @@ -1977,8 +1962,7 @@ and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = |> CombineLimits and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = - let exprRanges = List.replicate vs.Length None - BindVals cenv env exprRanges vs + BindVals cenv env vs for v in vs do CheckValSpec PermitByRefType.All cenv env v CheckExpr cenv env targetExpr ctxt isTailCall @@ -2731,15 +2715,13 @@ and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, tycons, mspecs, m) -> CheckNothingAfterEntryPoint cenv m - if isRec then - let valls, ranges = allValsAndRangesOfModDef mdef |> Seq.toList |> List.unzip - BindVals cenv env (ranges |> List.map Some) valls + if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m CheckModuleBinding cenv env false bind - BindVal cenv env (Some bind.Expr.Range) bind.Var + BindVal cenv env bind.Var | TMDefOpens _ -> () | TMDefDo(e, m) -> @@ -2758,13 +2740,79 @@ and CheckDefnInModule cenv env mdef = and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - BindVals cenv env [None] (valsOfBinds [bind]) + BindVals cenv env (valsOfBinds [bind]) CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } CheckDefnInModule cenv env rhs +//-------------------------------------------------------------------------- +// collect TailCall-attributed vals +//-------------------------------------------------------------------------- + +let rec allValsAndExprsOfModDef mdef = + seq { match mdef with + | TMDefRec(tycons = _tycons; bindings = mbinds) -> + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + yield bind.Var, bind.Expr + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndExprsOfModDef def + | TMDefLet(binding = bind) -> + let e = stripExpr bind.Expr + yield bind.Var, e + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allValsAndExprsOfModDef def + } + +let rec CollectCheckDefnsInModule cenv mdefs mustTailCall mustTailCallExpr = + List.fold (fun (mustTailCall, mustTailCallExpr) mdef -> + CollectCheckDefnInModule cenv mdef mustTailCall mustTailCallExpr + ) (mustTailCall, mustTailCallExpr) mdefs + +and CollectCheckDefnInModule cenv mdef (mustTailCall: Zset) (mustTailCallExpr: Map) = + match mdef with + | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> + let mustTailCall'', mustTailCallExprs'' = + if isRec then + let vallsAndExprs = allValsAndExprsOfModDef mdef + + let mustTailCall', mustTailCallExpr' = + Seq.fold (fun (mustTailCall, mustTailCallExpr) (v: Val, e) -> + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + let newSet = Zset.add v mustTailCall + let newMap = Map.add v.Stamp e mustTailCallExpr + (newSet, newMap) + else + (mustTailCall, mustTailCallExpr) + ) (mustTailCall, mustTailCallExpr) vallsAndExprs + + mustTailCall', mustTailCallExpr' + else + mustTailCall, mustTailCallExpr + + List.fold (fun (mustTailCall, mustTailCallExpr) mspec -> + CollectCheckModuleSpec cenv mspec mustTailCall mustTailCallExpr + ) (mustTailCall'', mustTailCallExprs'') mspecs + | TMDefLet(_bind, _m) -> + mustTailCall, mustTailCallExpr + | TMDefOpens _ -> + mustTailCall, mustTailCallExpr + | TMDefDo(_e, _m) -> + mustTailCall, mustTailCallExpr + | TMDefs defs -> CollectCheckDefnsInModule cenv defs mustTailCall mustTailCallExpr + +and CollectCheckModuleSpec cenv mbind mustTailCall mustTailCallExpr = + match mbind with + | ModuleOrNamespaceBinding.Binding _bind -> + mustTailCall, mustTailCallExpr + | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> + CollectCheckDefnInModule cenv rhs mustTailCall mustTailCallExpr + let CheckImplFileContents cenv env implFileTy implFileContents = let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } @@ -2808,7 +2856,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v boundTyparNames=[] argVals = ValMap.Empty mustTailCall = Zset.empty valOrder - mustTailCallRanges = Map.Empty + mustTailCallExprs = Map.Empty boundTypars= TyparMap.Empty reflect=false external=false @@ -2821,5 +2869,16 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then viewCcu.UsesFSharp20PlusQuotations <- true + + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + let mustTailCall, mustTailCallExprs = CollectCheckDefnInModule cenv implFileContents (Zset.empty valOrder) Map.Empty + + let env = + { env with mustTailCall = mustTailCall; mustTailCallExprs = mustTailCallExprs } + + for v in env.mustTailCall do + let expr = env.mustTailCallExprs[v.Stamp] + let binding = Binding.TBind(v, expr, DebugPointAtBinding.NoneAtLet) + CheckModuleBinding cenv env true binding cenv.entryPointGiven, cenv.anonRecdTypes diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index d6868feb2ac..50cb40dec1a 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -441,6 +441,13 @@ module rec M = |> typecheck |> shouldFail |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 6 + StartColumn = 28 + EndLine = 6 + EndColumn = 39 } + Message = + "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 Range = { StartLine = 6 StartColumn = 28 @@ -448,6 +455,13 @@ module rec M = EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 10 + StartColumn = 28 + EndLine = 10 + EndColumn = 39 } + Message = + "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 Range = { StartLine = 10 StartColumn = 28 From 2275a1c4254306dd750b9f53d74a54bac323f7be Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 30 Jun 2023 15:55:58 +0200 Subject: [PATCH 28/31] make tests more challenging --- .../ErrorMessages/TailCallAttribute.fs | 241 +++++++++++++----- 1 file changed, 184 insertions(+), 57 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 50cb40dec1a..ba4a6ac64d6 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -10,11 +10,12 @@ module ``TailCall Attribute`` = """ let mul x y = x * y -[] -let rec fact n acc = - if n = 0 - then acc - else (fact (n - 1) (mul n acc)) + 23 +module M = + [] + let rec fact n acc = + if n = 0 + then acc + else (fact (n - 1) (mul n acc)) + 23 """ |> FSharp |> withLangVersionPreview @@ -22,17 +23,17 @@ let rec fact n acc = |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 8 - StartColumn = 11 - EndLine = 8 - EndColumn = 35 } + Range = { StartLine = 9 + StartColumn = 15 + EndLine = 9 + EndColumn = 39 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 - Range = { StartLine = 8 - StartColumn = 11 - EndLine = 8 - EndColumn = 15 } + Range = { StartLine = 9 + StartColumn = 15 + EndLine = 9 + EndColumn = 19 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -123,25 +124,26 @@ r |> ignore let foo x = printfn "Foo: %x" x -[] -let rec bar x = - match x with - | 0 -> - foo x // OK: non-tail-recursive call to a function which doesn't share the current stack frame (i.e., 'bar' or 'baz'). - printfn "Zero" - - | 1 -> - bar (x - 1) // Warning: this call is not tail-recursive - printfn "Uno" - baz x // OK: tail-recursive call. - - | x -> - printfn "0x%08x" x - bar (x - 1) // OK: tail-recursive call. - -and [] baz x = - printfn "Baz!" - bar (x - 1) // OK: tail-recursive call. +module M = + [] + let rec bar x = + match x with + | 0 -> + foo x // OK: non-tail-recursive call to a function which doesn't share the current stack frame (i.e., 'bar' or 'baz'). + printfn "Zero" + + | 1 -> + bar (x - 1) // Warning: this call is not tail-recursive + printfn "Uno" + baz x // OK: tail-recursive call. + + | x -> + printfn "0x%08x" x + bar (x - 1) // OK: tail-recursive call. + + and [] baz x = + printfn "Baz!" + bar (x - 1) // OK: tail-recursive call. """ |> FSharp |> withLangVersionPreview @@ -149,17 +151,17 @@ and [] baz x = |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 13 - StartColumn = 9 - EndLine = 13 - EndColumn = 20 } + Range = { StartLine = 14 + StartColumn = 13 + EndLine = 14 + EndColumn = 24 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 - Range = { StartLine = 13 - StartColumn = 9 - EndLine = 13 - EndColumn = 12 } + Range = { StartLine = 14 + StartColumn = 13 + EndLine = 14 + EndColumn = 16 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -224,16 +226,18 @@ type C () = [] let ``Warn successfully for invalid tailcalls in type methods`` () = """ -type F () = - [] - member this.M1() = - printfn "M1 called" - this.M2() + 1 // should warn +module M1 = + module M2 = + type F () = + [] + member this.M1() = + printfn "M1 called" + this.M2() + 1 // should warn - [] - member this.M2() = - printfn "M2 called" - this.M1() + 2 // should warn + [] + member this.M2() = + printfn "M2 called" + this.M1() + 2 // should warn """ |> FSharp |> withLangVersionPreview @@ -241,17 +245,17 @@ type F () = |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 6 - StartColumn = 9 - EndLine = 6 - EndColumn = 18 } + Range = { StartLine = 8 + StartColumn = 17 + EndLine = 8 + EndColumn = 26 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 - Range = { StartLine = 11 - StartColumn = 9 - EndLine = 11 - EndColumn = 18 } + Range = { StartLine = 13 + StartColumn = 17 + EndLine = 13 + EndColumn = 26 } Message = "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -491,3 +495,126 @@ let run() = let mutable x = 0 in foo(&x) Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for yield! in tail position`` () = + """ +type Bind = { Var: string; Expr: string } + +type ModuleOrNamespaceBinding = + | Binding of bind: Bind + | Module of moduleOrNamespaceContents: MDef + +and MDef = + | TMDefRec of tycons: string list * bindings: ModuleOrNamespaceBinding list + | TMDefLet of binding: Bind + | TMDefDo of expr: string + | TMDefOpens of expr: string + | TMDefs of defs: MDef list + +[] +let rec allValsAndExprsOfModDef mdef = + seq { + match mdef with + | TMDefRec(tycons = _tycons; bindings = mbinds) -> + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> yield bind.Var, bind.Expr + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> + yield! allValsAndExprsOfModDef def + | TMDefLet(binding = bind) -> yield bind.Var, bind.Expr + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allValsAndExprsOfModDef def + } + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for calls in for and iter`` () = + """ +type Bind = { Var: string; Expr: string } + +type ModuleOrNamespaceBinding = + | Binding of bind: Bind + | Module of moduleOrNamespaceContents: MDef + +and MDef = + | TMDefRec of isRec: bool * tycons: string list * bindings: ModuleOrNamespaceBinding list + | TMDefLet of binding: Bind + | TMDefDo of expr: string + | TMDefOpens of expr: string + | TMDefs of defs: MDef list + +let someCheckFunc x = () + +[] +let rec CheckDefnsInModule cenv env mdefs = + for mdef in mdefs do + CheckDefnInModule cenv env mdef + +and CheckNothingAfterEntryPoint cenv = + if true then + printfn "foo" + +and [] CheckDefnInModule cenv env mdef = + match mdef with + | TMDefRec(isRec, tycons, mspecs) -> + CheckNothingAfterEntryPoint cenv + someCheckFunc tycons + List.iter (CheckModuleSpec cenv env isRec) mspecs + | TMDefLet bind -> + CheckNothingAfterEntryPoint cenv + someCheckFunc bind + | TMDefOpens _ -> () + | TMDefDo e -> + CheckNothingAfterEntryPoint cenv + let isTailCall = true + someCheckFunc isTailCall + | TMDefs defs -> CheckDefnsInModule cenv env defs + +and [] CheckModuleSpec cenv env isRec mbind = + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> someCheckFunc bind + | ModuleOrNamespaceBinding.Module mspec -> + someCheckFunc mspec + CheckDefnInModule cenv env mspec + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 20 + StartColumn = 9 + EndLine = 20 + EndColumn = 40 } + Message = + "The member or function 'CheckDefnInModule' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 20 + StartColumn = 9 + EndLine = 20 + EndColumn = 26 } + Message = + "The member or function 'CheckDefnInModule' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 31 + StartColumn = 20 + EndLine = 31 + EndColumn = 50 } + Message = + "The member or function 'CheckModuleSpec' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 31 + StartColumn = 20 + EndLine = 31 + EndColumn = 35 } + Message = + "The member or function 'CheckModuleSpec' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From a1eaebc52039fc1d2c43833c1a4f57cbaa287709 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 30 Jun 2023 15:56:28 +0200 Subject: [PATCH 29/31] do the TailCall checks during the main traversal --- src/Compiler/Checking/PostInferenceChecks.fs | 118 +++++++------------ 1 file changed, 40 insertions(+), 78 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 2ccd02c2144..398f1b0fed8 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2703,6 +2703,24 @@ let CheckEntityDefns cenv env tycons = // check modules //-------------------------------------------------------------------------- +let rec allValsAndExprsOfModDef mdef = + seq { match mdef with + | TMDefRec(tycons = _tycons; bindings = mbinds) -> + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + yield bind.Var, bind.Expr + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndExprsOfModDef def + | TMDefLet(binding = bind) -> + let e = stripExpr bind.Expr + yield bind.Var, e + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allValsAndExprsOfModDef def + } + let rec CheckDefnsInModule cenv env mdefs = for mdef in mdefs do CheckDefnInModule cenv env mdef @@ -2715,7 +2733,23 @@ and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, tycons, mspecs, m) -> CheckNothingAfterEntryPoint cenv m - if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) + let env = + if isRec then + BindVals cenv env (allValsOfModDef mdef |> Seq.toList) + + let vallsAndExprs = allValsAndExprsOfModDef mdef + let mustTailCall, mustTailCallExprs = + Seq.fold (fun (mustTailCall, mustTailCallExpr) (v: Val, e) -> + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + let newSet = Zset.add v mustTailCall + let newMap = Map.add v.Stamp e mustTailCallExpr + (newSet, newMap) + else + (mustTailCall, mustTailCallExpr) + ) (env.mustTailCall, env.mustTailCallExprs) vallsAndExprs + { env with mustTailCall = mustTailCall; mustTailCallExprs = mustTailCallExprs } + else + env CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> @@ -2740,6 +2774,11 @@ and CheckDefnInModule cenv env mdef = and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> + let env = + if env.mustTailCall.Contains bind.Var then + env + else + { env with mustTailCall = Zset.empty valOrder; mustTailCallExprs = Map.empty } BindVals cenv env (valsOfBinds [bind]) CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> @@ -2747,72 +2786,6 @@ and CheckModuleSpec cenv env isRec mbind = let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } CheckDefnInModule cenv env rhs -//-------------------------------------------------------------------------- -// collect TailCall-attributed vals -//-------------------------------------------------------------------------- - -let rec allValsAndExprsOfModDef mdef = - seq { match mdef with - | TMDefRec(tycons = _tycons; bindings = mbinds) -> - for mbind in mbinds do - match mbind with - | ModuleOrNamespaceBinding.Binding bind -> - yield bind.Var, bind.Expr - | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndExprsOfModDef def - | TMDefLet(binding = bind) -> - let e = stripExpr bind.Expr - yield bind.Var, e - | TMDefDo _ -> () - | TMDefOpens _ -> () - | TMDefs defs -> - for def in defs do - yield! allValsAndExprsOfModDef def - } - -let rec CollectCheckDefnsInModule cenv mdefs mustTailCall mustTailCallExpr = - List.fold (fun (mustTailCall, mustTailCallExpr) mdef -> - CollectCheckDefnInModule cenv mdef mustTailCall mustTailCallExpr - ) (mustTailCall, mustTailCallExpr) mdefs - -and CollectCheckDefnInModule cenv mdef (mustTailCall: Zset) (mustTailCallExpr: Map) = - match mdef with - | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> - let mustTailCall'', mustTailCallExprs'' = - if isRec then - let vallsAndExprs = allValsAndExprsOfModDef mdef - - let mustTailCall', mustTailCallExpr' = - Seq.fold (fun (mustTailCall, mustTailCallExpr) (v: Val, e) -> - if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then - let newSet = Zset.add v mustTailCall - let newMap = Map.add v.Stamp e mustTailCallExpr - (newSet, newMap) - else - (mustTailCall, mustTailCallExpr) - ) (mustTailCall, mustTailCallExpr) vallsAndExprs - - mustTailCall', mustTailCallExpr' - else - mustTailCall, mustTailCallExpr - - List.fold (fun (mustTailCall, mustTailCallExpr) mspec -> - CollectCheckModuleSpec cenv mspec mustTailCall mustTailCallExpr - ) (mustTailCall'', mustTailCallExprs'') mspecs - | TMDefLet(_bind, _m) -> - mustTailCall, mustTailCallExpr - | TMDefOpens _ -> - mustTailCall, mustTailCallExpr - | TMDefDo(_e, _m) -> - mustTailCall, mustTailCallExpr - | TMDefs defs -> CollectCheckDefnsInModule cenv defs mustTailCall mustTailCallExpr - -and CollectCheckModuleSpec cenv mbind mustTailCall mustTailCallExpr = - match mbind with - | ModuleOrNamespaceBinding.Binding _bind -> - mustTailCall, mustTailCallExpr - | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> - CollectCheckDefnInModule cenv rhs mustTailCall mustTailCallExpr - let CheckImplFileContents cenv env implFileTy implFileContents = let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } @@ -2870,15 +2843,4 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then viewCcu.UsesFSharp20PlusQuotations <- true - if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - let mustTailCall, mustTailCallExprs = CollectCheckDefnInModule cenv implFileContents (Zset.empty valOrder) Map.Empty - - let env = - { env with mustTailCall = mustTailCall; mustTailCallExprs = mustTailCallExprs } - - for v in env.mustTailCall do - let expr = env.mustTailCallExprs[v.Stamp] - let binding = Binding.TBind(v, expr, DebugPointAtBinding.NoneAtLet) - CheckModuleBinding cenv env true binding - cenv.entryPointGiven, cenv.anonRecdTypes From 8ad9710e14afb9b31c38ab96133ccdc8461ab294 Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 3 Jul 2023 12:53:46 +0200 Subject: [PATCH 30/31] don't warn for bindings of partial applications --- src/Compiler/Checking/PostInferenceChecks.fs | 64 ++++++++----------- .../ErrorMessages/TailCallAttribute.fs | 50 +++++++++++++++ 2 files changed, 75 insertions(+), 39 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 398f1b0fed8..3e5dd0dd255 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -810,34 +810,6 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | None -> () | Some e -> errorR(e) -let rec allValsAndRangesOfModDef mdef = - let abstractSlotValsAndRangesOfTycons (tycons: Tycon list) = - abstractSlotValRefsOfTycons tycons - |> List.map (fun v -> v.Deref, v.Deref.Range) - - seq { match mdef with - | TMDefRec(tycons = tycons; bindings = mbinds) -> - yield! abstractSlotValsAndRangesOfTycons tycons - for mbind in mbinds do - match mbind with - | ModuleOrNamespaceBinding.Binding bind -> - let r = - match (stripExpr bind.Expr) with - | Expr.Lambda _ -> bind.Expr.Range - | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range - | e -> e.Range - yield bind.Var, r - | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndRangesOfModDef def - | TMDefLet(binding = bind) -> - let e = stripExpr bind.Expr - yield bind.Var, e.Range - | TMDefDo _ -> () - | TMDefOpens _ -> () - | TMDefs defs -> - for def in defs do - yield! allValsAndRangesOfModDef def - } - /// Check an expression, where the expression is in a position where byrefs can be generated let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore @@ -2227,25 +2199,39 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(v, e, _) as bind) = if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then match bind.Expr with | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - let rec checkTailCall (insideSubBinding: bool) expr = + let rec checkTailCall (insideSubBinding: bool) (allArgsProvided: bool) expr = match expr with | Expr.Val(valRef, _valUseFlag, m) -> - if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + if isRec && insideSubBinding && allArgsProvided && env.mustTailCall.Contains valRef.Deref then warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - checkTailCall insideSubBinding funcExpr - exprs |> List.iter (checkTailCall insideSubBinding) - | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + let allArgsProvided = + match funcExpr with + | Expr.Link e + | Expr.Op (TOp.Coerce, _, [Expr.Link e], _) -> + let expr = e.Value + match expr with + | Expr.Val(valRef = valRef) -> + match valRef.ValReprInfo with + | Some info -> info.TotalArgCount = exprs.Length // Don't warn for partial application + | _ -> false + | _ -> false + | _ -> false + checkTailCall insideSubBinding allArgsProvided funcExpr + exprs |> List.iter (checkTailCall insideSubBinding false) + | Expr.Link exprRef -> checkTailCall insideSubBinding allArgsProvided exprRef.Value | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - checkTailCall insideSubBinding bodyExpr - | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + checkTailCall insideSubBinding allArgsProvided bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding allArgsProvided expr | Expr.Let(binding, bodyExpr, _range, _frees) -> - checkTailCall true binding.Expr - checkTailCall insideSubBinding bodyExpr + checkTailCall true allArgsProvided binding.Expr + checkTailCall insideSubBinding allArgsProvided bodyExpr | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> - decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding allArgsProvided target.TargetExpression) + | Expr.Op (TOp.Coerce, _, exprs, _) -> + exprs |> Seq.iter (checkTailCall insideSubBinding allArgsProvided) | _ -> () - checkTailCall false bodyExpr + checkTailCall false false bodyExpr | _ -> () // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index ba4a6ac64d6..d02e872ff38 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -618,3 +618,53 @@ and [] CheckModuleSpec cenv env isRec mbind = Message = "The member or function 'CheckModuleSpec' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for partial application but for calls in map and total applications`` () = + """ +type Type() = + member val HasElementType = true with get, set + member val IsArray = true with get, set + member val IsPointer = false with get, set + member val IsByRef = false with get, set + member val IsGenericParameter = false with get, set + member _.GetArray () = Array.empty + member _.GetArrayRank () = 2 + +[] +let rec instType a b (ty: Type) = + if a then + let typeArgs = Array.map (instType true 100) (ty.GetArray()) + 22 + elif ty.HasElementType then + let ety = instType true 23 // should not warn + let ety = instType true 23 ty // should warn + if ty.IsArray then + let rank = ty.GetArrayRank() + 23 + elif ty.IsPointer then 24 + elif ty.IsByRef then 25 + else 26 + elif ty.IsGenericParameter then + 27 + else 28 + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 18 + StartColumn = 19 + EndLine = 18 + EndColumn = 27 } + Message = + "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 35 + EndLine = 14 + EndColumn = 43 } + Message = + "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From b71b4bb226a0eeedd61b7e367abdfdfe097b5886 Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 3 Jul 2023 18:46:10 +0200 Subject: [PATCH 31/31] - support TyLambda bodies - keep warning for partial applications --- src/Compiler/Checking/PostInferenceChecks.fs | 51 +++++++----------- .../ErrorMessages/TailCallAttribute.fs | 54 ++++++++++++++++--- 2 files changed, 68 insertions(+), 37 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 3e5dd0dd255..85ebb57601b 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2198,40 +2198,29 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(v, e, _) as bind) = if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then match bind.Expr with - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - let rec checkTailCall (insideSubBinding: bool) (allArgsProvided: bool) expr = + | Expr.TyLambda(bodyExpr = bodyExpr) + | Expr.Lambda(bodyExpr = bodyExpr) -> + let rec checkTailCall (insideSubBinding: bool) expr = match expr with - | Expr.Val(valRef, _valUseFlag, m) -> - if isRec && insideSubBinding && allArgsProvided && env.mustTailCall.Contains valRef.Deref then + | Expr.Val(valRef = valRef; range = m) -> + if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - let allArgsProvided = - match funcExpr with - | Expr.Link e - | Expr.Op (TOp.Coerce, _, [Expr.Link e], _) -> - let expr = e.Value - match expr with - | Expr.Val(valRef = valRef) -> - match valRef.ValReprInfo with - | Some info -> info.TotalArgCount = exprs.Length // Don't warn for partial application - | _ -> false - | _ -> false - | _ -> false - checkTailCall insideSubBinding allArgsProvided funcExpr - exprs |> List.iter (checkTailCall insideSubBinding false) - | Expr.Link exprRef -> checkTailCall insideSubBinding allArgsProvided exprRef.Value - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - checkTailCall insideSubBinding allArgsProvided bodyExpr - | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding allArgsProvided expr - | Expr.Let(binding, bodyExpr, _range, _frees) -> - checkTailCall true allArgsProvided binding.Expr - checkTailCall insideSubBinding allArgsProvided bodyExpr - | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> - decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding allArgsProvided target.TargetExpression) - | Expr.Op (TOp.Coerce, _, exprs, _) -> - exprs |> Seq.iter (checkTailCall insideSubBinding allArgsProvided) + | Expr.App(funcExpr = funcExpr; args = argExprs) -> + checkTailCall insideSubBinding funcExpr + argExprs |> List.iter (checkTailCall insideSubBinding) + | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + | Expr.Lambda(bodyExpr = bodyExpr) -> + checkTailCall insideSubBinding bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let(binding = binding; bodyExpr = bodyExpr) -> + checkTailCall true binding.Expr + checkTailCall insideSubBinding bodyExpr + | Expr.Match(targets = decisionTreeTargets) -> + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | Expr.Op (op = TOp.Coerce; args = exprs) -> + exprs |> Seq.iter (checkTailCall insideSubBinding) | _ -> () - checkTailCall false false bodyExpr + checkTailCall false bodyExpr | _ -> () // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index d02e872ff38..4ed83083667 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -637,7 +637,7 @@ let rec instType a b (ty: Type) = let typeArgs = Array.map (instType true 100) (ty.GetArray()) 22 elif ty.HasElementType then - let ety = instType true 23 // should not warn + let ety = instType true 23 // ToDo: also warn for partial app? let ety = instType true 23 ty // should warn if ty.IsArray then let rank = ty.GetArrayRank() @@ -653,6 +653,20 @@ let rec instType a b (ty: Type) = |> withLangVersionPreview |> typecheck |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 35 + EndLine = 14 + EndColumn = 43 } + Message = + "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 17 + StartColumn = 19 + EndLine = 17 + EndColumn = 27 } + Message = + "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 Range = { StartLine = 18 StartColumn = 19 @@ -660,11 +674,39 @@ let rec instType a b (ty: Type) = EndColumn = 27 } Message = "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn for invalid calls in inner bindings of conditional`` () = + """ +[] +let rec foldBackOpt f (m: Map<'Key, 'Value>) x = + if not (Map.isEmpty m) then + x + else if m.Count = 1 then + let a = foldBackOpt f m x + f x + else + let a = foldBackOpt f m x + let x = f x + foldBackOpt f m a + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> withResults [ { Error = Warning 3569 - Range = { StartLine = 14 - StartColumn = 35 - EndLine = 14 - EndColumn = 43 } + Range = { StartLine = 7 + StartColumn = 17 + EndLine = 7 + EndColumn = 28 } Message = - "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'foldBackOpt' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 10 + StartColumn = 17 + EndLine = 10 + EndColumn = 28 } + Message = + "The member or function 'foldBackOpt' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ]