diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs new file mode 100644 index 00000000000..4f2185220a0 --- /dev/null +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -0,0 +1,792 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module internal FSharp.Compiler.TailCallChecks + +open Internal.Utilities.Collections +open Internal.Utilities.Library +open Internal.Utilities.Library.Extras +open FSharp.Compiler +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.DiagnosticsLogger +open FSharp.Compiler.Features +open FSharp.Compiler.Syntax +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTreeBasics +open FSharp.Compiler.TypedTreeOps +open FSharp.Compiler.TypeRelations + +let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_TailCallChecks" 50 + +let (|ValUseAtApp|_|) e = + match e with + | InnerExprPat (Expr.App(funcExpr = InnerExprPat (Expr.Val (valRef = vref; flags = valUseFlags))) | Expr.Val (valRef = vref + flags = valUseFlags)) -> + Some(vref, valUseFlags) + | _ -> None + +type TailCallReturnType = + | MustReturnVoid // indicates "has unit return type and must return void" + | NonVoid + +type TailCall = + | Yes of TailCallReturnType + | No + + 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 + + if isUnitTy g returnTy then + TailCallReturnType.MustReturnVoid + else + TailCallReturnType.NonVoid + | None -> TailCallReturnType.NonVoid + + static member YesFromVal (g: TcGlobals) (v: Val) = TailCall.Yes(TailCall.IsVoidRet g v) + + static member YesFromExpr (g: TcGlobals) (expr: Expr) = + match expr with + | ValUseAtApp (valRef, _) -> TailCall.Yes(TailCall.IsVoidRet g valRef.Deref) + | _ -> TailCall.Yes TailCallReturnType.NonVoid + + member x.AtExprLambda = + match x with + // Inside a lambda that is considered an expression, we must always return "unit" not "void" + | TailCall.Yes _ -> TailCall.Yes TailCallReturnType.NonVoid + | TailCall.No -> TailCall.No + +let IsValRefIsDllImport g (vref: ValRef) = + vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute + +type cenv = + { + stackGuard: StackGuard + + g: TcGlobals + + amap: Import.ImportMap + + reportErrors: bool + + /// Values in module that have been marked [] + mustTailCall: Zset + } + + override x.ToString() = "" + +//-------------------------------------------------------------------------- +// approx walk of type +//-------------------------------------------------------------------------- + +/// Indicates whether an address-of operation is permitted at a particular location +/// Type definition taken from PostInferenceChecks.fs. To be kept in sync. +[] +type PermitByRefExpr = + /// Permit a tuple of arguments where elements can be byrefs + | YesTupleOfArgs of int + + /// Context allows for byref typed expr. + | Yes + + /// Context allows for byref typed expr, but the byref must be returnable + | YesReturnable + + /// Context allows for byref typed expr, but the byref must be returnable and a non-local + | YesReturnableNonLocal + + /// General (address-of expr and byref values not allowed) + | No + + member ctxt.PermitOnlyReturnable = + match ctxt with + | PermitByRefExpr.YesReturnable + | PermitByRefExpr.YesReturnableNonLocal -> true + | _ -> false + +let mkArgsPermit n = + if n = 1 then + PermitByRefExpr.Yes + else + PermitByRefExpr.YesTupleOfArgs n + +/// Work out what byref-values are allowed at input positions to named F# functions or members +let mkArgsForAppliedVal isBaseCall (vref: ValRef) argsl = + match vref.ValReprInfo with + | Some valReprInfo -> + let argArities = valReprInfo.AritiesOfArgs + + let argArities = + if isBaseCall && argArities.Length >= 1 then + List.tail argArities + else + argArities + // Check for partial applications: arguments to partial applications don't get to use byrefs + if List.length argsl >= argArities.Length then + List.map mkArgsPermit argArities + else + [] + | None -> [] + +/// Work out what byref-values are allowed at input positions to functions +let rec mkArgsForAppliedExpr isBaseCall argsl x = + match stripDebugPoints (stripExpr x) with + // recognise val + | Expr.Val (vref, _, _) -> mkArgsForAppliedVal isBaseCall vref argsl + // step through instantiations + | Expr.App (f, _fty, _tyargs, [], _) -> mkArgsForAppliedExpr isBaseCall argsl f + // step through subsumption coercions + | Expr.Op (TOp.Coerce, _, [ f ], _) -> mkArgsForAppliedExpr isBaseCall argsl f + | _ -> [] + +/// Check an expression, where the expression is in a position where byrefs can be generated +let rec CheckExprNoByrefs cenv (tailCall: TailCall) expr = + CheckExpr cenv expr PermitByRefExpr.No tailCall + +/// Check an expression, warn if it's attributed with TailCall but our analysis concludes it's not a valid tail call +and CheckForNonTailRecCall (cenv: cenv) expr (tailCall: TailCall) = + let g = cenv.g + let expr = stripExpr expr + let expr = stripDebugPoints expr + + match expr with + | Expr.App (f, _fty, _tyargs, argsl, m) -> + + if cenv.reportErrors then + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match f with + | ValUseAtApp (vref, valUseFlags) when cenv.mustTailCall.Contains vref.Deref -> + + let canTailCall = + match tailCall with + | TailCall.No -> // an upper level has already decided that this is not in a tailcall position + false + | TailCall.Yes returnType -> + 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 && returnType <> TailCallReturnType.MustReturnVoid) + + let noTailCallBlockers = + not isNewObj + && not isSuperInit + && not isSelfInit + && not mustGenerateUnitAfterCall + && isNil laterArgs + && not (IsValRefIsDllImport cenv.g vref) + && not isCCall + && not hasByrefArg + + noTailCallBlockers // blockers that will prevent the IL level from emmiting a tail instruction + else + true + + // warn if we call inside of recursive scope in non-tail-call manner/with tail blockers. See + // ``Warn successfully in match clause`` + // ``Warn for byref parameters`` + if not canTailCall then + warning (Error(FSComp.SR.chkNotTailRecursive vref.DisplayName, m)) + | _ -> () + | _ -> () + +/// Check call arguments, including the return argument. +and CheckCall cenv args ctxts = CheckExprs cenv args ctxts TailCall.No + +/// Check call arguments, including the return argument. The receiver argument is handled differently. +and CheckCallWithReceiver cenv args ctxts = + match args with + | [] -> failwith "CheckCallWithReceiver: Argument list is empty." + | receiverArg :: args -> + + let receiverContext, ctxts = + match ctxts with + | [] -> PermitByRefExpr.No, [] + | ctxt :: ctxts -> ctxt, ctxts + + CheckExpr cenv receiverArg receiverContext TailCall.No + CheckExprs cenv args ctxts (TailCall.Yes TailCallReturnType.NonVoid) + +and CheckExprLinear (cenv: cenv) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = + match expr with + | Expr.Sequential (e1, e2, NormalSeq, _) -> + CheckExprNoByrefs cenv TailCall.No e1 + // tailcall + CheckExprLinear cenv e2 ctxt tailCall + + | Expr.Let (TBind (v, _bindRhs, _) as bind, body, _, _) -> + let isByRef = isByrefTy cenv.g v.Type + + let bindingContext = + if isByRef then + PermitByRefExpr.YesReturnable + else + PermitByRefExpr.Yes + + CheckBinding cenv false bindingContext bind + // tailcall + CheckExprLinear cenv body ctxt tailCall + + | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> + argsHead |> List.iter (CheckExprNoByrefs cenv tailCall) + // tailcall + CheckExprLinear cenv argLast PermitByRefExpr.No tailCall + + | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, _m, _ty) -> + CheckDecisionTree cenv dtree + CheckDecisionTreeTarget cenv tailCall ctxt tg1 + // tailcall + CheckExprLinear cenv e2 ctxt tailCall + + | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv innerExpr ctxt tailCall + + | _ -> + // not a linear expression + CheckExpr cenv expr ctxt (TailCall.YesFromExpr cenv.g expr) + +/// Check an expression, given information about the position of the expression +and CheckExpr (cenv: cenv) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = + + // Guard the stack for deeply nested expressions + cenv.stackGuard.Guard + <| fun () -> + + let g = cenv.g + + let origExpr = stripExpr origExpr + + // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs + CheckForNonTailRecCall cenv origExpr tailCall + let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr + let expr = stripExpr expr + + match expr with + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Let _ + | Expr.Sequential (_, _, NormalSeq, _) + | Expr.DebugPoint _ -> CheckExprLinear cenv expr ctxt tailCall + + | Expr.Sequential (e1, e2, ThenDoSeq, _) -> + CheckExprNoByrefs cenv TailCall.No e1 + CheckExprNoByrefs cenv TailCall.No e2 + + | Expr.Const _ + | Expr.Val _ + | Expr.Quote _ -> () + + | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv info + + | Expr.Obj (_, ty, _basev, superInitCall, overrides, iimpls, _) -> CheckObjectExpr cenv (ty, superInitCall, overrides, iimpls) + + // Allow base calls to F# methods + | Expr.App (InnerExprPat (ExprValWithPossibleTypeInst (v, vFlags, _, _) as f), _fty, _tyargs, Expr.Val (baseVal, _, _) :: rest, _m) when + ((match vFlags with + | VSlotDirectCall -> true + | _ -> false) + && baseVal.IsBaseVal) + -> + CheckFSharpBaseCall cenv (v, f, rest) + + // Allow base calls to IL methods + | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, _ilMethRef, _enclTypeInst, _methInst, _retTypes), + _tyargs, + Expr.Val (baseVal, _, _) :: rest, + _m) when not isVirtual && baseVal.IsBaseVal -> + + CheckILBaseCall cenv rest + + | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv (op, tyargs, args, m) ctxt + + // Allow 'typeof' calls as a special case, the only accepted use of System.Void! + | TypeOfExpr g ty when isVoidTy g ty -> () + + // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! + | TypeDefOfExpr g ty when isVoidTy g ty -> () + + // Check an application + | Expr.App (f, _fty, _tyargs, argsl, _m) -> CheckApplication cenv (f, argsl) tailCall + + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv expr (argvs, m, bodyTy) tailCall + + | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv expr (tps, m, bodyTy) tailCall + + | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv tailCall e1 + + | Expr.Match (_, _, dtree, targets, _m, _ty) -> CheckMatch cenv ctxt (dtree, targets) tailCall + + | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv (binds, bodyExpr) tailCall + + | Expr.StaticOptimization (_constraints, e2, e3, _m) -> CheckStaticOptimization cenv (e2, e3) + + | Expr.WitnessArg _ -> () + + | Expr.Link _ -> failwith "Unexpected reclink" + +and CheckStructStateMachineExpr cenv info = + + let (_dataTy, + (_moveNextThisVar, moveNextExpr), + (_setStateMachineThisVar, _setStateMachineStateVar, setStateMachineBody), + (_afterCodeThisVar, afterCodeBody)) = + info + + CheckExprNoByrefs cenv TailCall.No moveNextExpr + CheckExprNoByrefs cenv TailCall.No setStateMachineBody + CheckExprNoByrefs cenv TailCall.No afterCodeBody + +and CheckObjectExpr cenv (ty, superInitCall, overrides, iimpls) = + CheckExprNoByrefs cenv TailCall.No superInitCall + CheckMethods cenv (ty, overrides) + CheckInterfaceImpls cenv iimpls + +and CheckFSharpBaseCall cenv (v, f, rest) : unit = + let memberInfo = Option.get v.MemberInfo + + if memberInfo.MemberFlags.IsDispatchSlot then + () + else + CheckExprs cenv rest (mkArgsForAppliedExpr true rest f) TailCall.No + +and CheckILBaseCall cenv rest : unit = CheckExprsPermitByRefLike cenv rest + +and CheckApplication cenv (f, argsl) (tailCall: TailCall) : unit = + CheckExprNoByrefs cenv tailCall f + + let hasReceiver = + match f with + | Expr.Val (vref, _, _) when vref.IsInstanceMember && not argsl.IsEmpty -> true + | _ -> false + + let ctxts = mkArgsForAppliedExpr false argsl f + + if hasReceiver then + CheckCallWithReceiver cenv argsl ctxts + else + CheckCall cenv argsl ctxts + +and CheckLambda cenv expr (argvs, m, bodyTy) (tailCall: TailCall) = + let valReprInfo = + ValReprInfo([], [ argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1) ], ValReprInfo.unnamedRetVal) + + let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in + CheckLambdas false None cenv false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + +and CheckTyLambda cenv expr (tps, m, bodyTy) (tailCall: TailCall) = + let valReprInfo = + ValReprInfo(ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) + + let ty = mkForallTyIfNeeded tps bodyTy in + CheckLambdas false None cenv false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + +and CheckMatch cenv ctxt (dtree, targets) tailCall = + CheckDecisionTree cenv dtree + CheckDecisionTreeTargets cenv targets ctxt tailCall + +and CheckLetRec cenv (binds, bodyExpr) tailCall = + CheckBindings cenv binds + CheckExprNoByrefs cenv tailCall bodyExpr + +and CheckStaticOptimization cenv (e2, e3) = + CheckExprNoByrefs cenv TailCall.No e2 + CheckExprNoByrefs cenv TailCall.No e3 + +and CheckMethods cenv (ty, methods) = + methods |> List.iter (CheckMethod cenv ty) + +and CheckMethod cenv _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = + let tailCall = + match stripDebugPoints body with + | Expr.App _ as a -> TailCall.YesFromExpr cenv.g a + | _ -> TailCall.No + + CheckExpr cenv body PermitByRefExpr.YesReturnableNonLocal tailCall + +and CheckInterfaceImpls cenv l = + l |> List.iter (CheckInterfaceImpl cenv) + +and CheckInterfaceImpl cenv overrides = CheckMethods cenv overrides + +and CheckExprOp cenv (op, tyargs, args, m) ctxt : unit = + let g = cenv.g + + // Special cases + match op, tyargs, args with + // Handle these as special cases since mutables are allowed inside their bodies + | TOp.While _, _, [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _) ] -> + CheckExprsNoByRefLike cenv [ e1; e2 ] + + | TOp.TryFinally _, [ _ ], [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _) ] -> + CheckExpr cenv e1 ctxt TailCall.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 TailCall.No e2 + + | TOp.IntegerForLoop _, + _, + [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _); Expr.Lambda (_, _, _, [ _ ], e3, _, _) ] -> + CheckExprsNoByRefLike cenv [ e1; e2; e3 ] + + | TOp.TryWith _, + [ _ ], + [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], _e2, _, _); Expr.Lambda (_, _, _, [ _ ], e3, _, _) ] -> + CheckExpr cenv e1 ctxt TailCall.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] + CheckExpr cenv e3 ctxt TailCall.No // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + + | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, _enclTypeInst, _methInst, retTypes), _, _ -> + + let hasReceiver = + (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) + && not args.IsEmpty + + let argContexts = List.init args.Length (fun _ -> PermitByRefExpr.Yes) + + match retTypes with + | [ ty ] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> + if hasReceiver then + CheckCallWithReceiver cenv args argContexts + else + CheckCall cenv args argContexts + | _ -> + if hasReceiver then + CheckCallWithReceiver cenv args argContexts + else + CheckCall cenv args argContexts + + | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> + match ctxt with + | PermitByRefExpr.YesTupleOfArgs _nArity -> + // This tuple should not be generated. The known function arity + // means it just bundles arguments. + CheckExprsPermitByRefLike cenv args + | _ -> CheckExprsNoByRefLike cenv args + + | TOp.LValueOp (LAddrOf _, _vref), _, _ -> CheckExprsNoByRefLike cenv args + + | TOp.LValueOp (LByrefSet, _vref), _, [ _arg ] -> () + + | TOp.LValueOp (LByrefGet, _vref), _, [] -> () + + | TOp.LValueOp (LSet, _vref), _, [ _arg ] -> () + + | TOp.AnonRecdGet _, _, [ arg1 ] + | TOp.TupleFieldGet _, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv [ arg1 ] + + | TOp.ValFieldGet _rf, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv [ arg1 ] + + | TOp.ValFieldSet _rf, _, [ _arg1; _arg2 ] -> () + + | TOp.Coerce, [ tgtTy; srcTy ], [ x ] -> + let tailCall = TailCall.YesFromExpr cenv.g x + + if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then + CheckExpr cenv x ctxt tailCall + else + CheckExprNoByrefs cenv tailCall x + + | TOp.Reraise, [ _ty1 ], [] -> () + + // Check get of static field + | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [] -> () + + // Check get of instance field + | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [ obj ] -> + // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable + CheckExpr cenv obj ctxt TailCall.No + + | TOp.UnionCaseFieldGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv arg1 + + | TOp.UnionCaseTagGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv arg1 // allow byref - it may be address-of-struct + + | TOp.UnionCaseFieldGetAddr (_uref, _idx, _readonly), _tyargs, [ obj ] -> + // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable + CheckExpr cenv obj ctxt TailCall.No + + | TOp.ILAsm (instrs, _retTypes), _, _ -> + match instrs, args with + // Write a .NET instance field + | [ I_stfld (_alignment, _vol, _fspec) ], _ -> + match args with + | [ _; rhs ] -> CheckExprNoByrefs cenv TailCall.No 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 args + + // Read a .NET instance field + | [ I_ldfld (_alignment, _vol, _fspec) ], _ -> + // permit byref for lhs lvalue + CheckExprsPermitByRefLike cenv args + + // Read a .NET instance field + | [ I_ldfld (_alignment, _vol, _fspec); AI_nop ], _ -> + // permit byref for lhs lvalue of readonly value + CheckExprsPermitByRefLike cenv args + + | [ I_ldsflda _fspec ], [] -> () + + | [ I_ldflda _fspec ], [ obj ] -> + + // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable + CheckExpr cenv obj ctxt TailCall.No + + | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> + // permit byref for lhs lvalue + CheckExprPermitByRefLike cenv lhsArray + CheckExprsNoByRefLike cenv indices + + | [ AI_conv _ ], _ -> + // permit byref for args to conv + CheckExprsPermitByRefLike cenv args + + | _ -> CheckExprsNoByRefLike cenv args + + | TOp.TraitCall _, _, _ -> + // allow args to be byref here + CheckExprsPermitByRefLike cenv args + + | TOp.Recd _, _, _ -> CheckExprsPermitByRefLike cenv args + + | _ -> CheckExprsNoByRefLike cenv args + +and CheckLambdas + isTop + (memberVal: Val option) + cenv + inlined + valReprInfo + (tailCall: TailCall) + alwaysCheckNoReraise + expr + mOrig + ety + ctxt + : unit = + let g = cenv.g + + // The valReprInfo here says we are _guaranteeing_ to compile a function value + // as a .NET method with precisely the corresponding argument counts. + match stripDebugPoints expr with + | Expr.TyChoose (_tps, e1, m) -> CheckLambdas isTop memberVal cenv inlined valReprInfo tailCall alwaysCheckNoReraise e1 m ety ctxt + + | Expr.Lambda (_, _, _, _, _, m, _) + | Expr.TyLambda (_, _, _, m, _) -> + let _tps, _ctorThisValOpt, _baseValOpt, _vsl, body, bodyTy = + destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) + + // Check the body of the lambda + if isTop && not g.compilingFSharpCore && isByrefLikeTy g m bodyTy then + // allow byref to occur as return position for byref-typed top level function or method + CheckExprPermitReturnableByRef cenv body + else + CheckExprNoByrefs cenv (TailCall.YesFromExpr cenv.g body) body // TailCall.Yes for CPS + + // This path is for expression bindings that are not actually lambdas + | _ -> + let m = mOrig + + if not inlined && (isByrefLikeTy g m ety || isNativePtrTy g ety) then + // allow byref to occur as RHS of byref binding. + CheckExpr cenv expr ctxt tailCall + else + CheckExprNoByrefs cenv tailCall expr + +and CheckExprs cenv exprs ctxts (tailCall: TailCall) : unit = + 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 exp (argArity i) tailCall) + |> ignore + +and CheckExprsNoByRefLike cenv exprs : unit = + for expr in exprs do + CheckExprNoByrefs cenv TailCall.No expr + +and CheckExprsPermitByRefLike cenv exprs : unit = + exprs |> List.map (CheckExprPermitByRefLike cenv) |> ignore + +and CheckExprPermitByRefLike cenv expr : unit = + CheckExpr cenv expr PermitByRefExpr.Yes TailCall.No + +and CheckExprPermitReturnableByRef cenv expr : unit = + CheckExpr cenv expr PermitByRefExpr.YesReturnable TailCall.No + +and CheckDecisionTreeTargets cenv targets ctxt (tailCall: TailCall) = + targets + |> Array.map (CheckDecisionTreeTarget cenv tailCall ctxt) + |> List.ofArray + |> ignore + +and CheckDecisionTreeTarget cenv (tailCall: TailCall) ctxt (TTarget (_vs, targetExpr, _)) : unit = CheckExpr cenv targetExpr ctxt tailCall + +and CheckDecisionTree cenv dtree = + match dtree with + | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv resultExprs + | TDBind (bind, rest) -> + CheckBinding cenv false PermitByRefExpr.Yes bind + CheckDecisionTree cenv rest + | TDSwitch (inpExpr, cases, dflt, _m) -> CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt) + +and CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt) = + CheckExprPermitByRefLike cenv inpExpr // can be byref for struct union switch + + for TCase (discrim, dtree) in cases do + CheckDecisionTreeTest cenv discrim + CheckDecisionTree cenv dtree + + dflt |> Option.iter (CheckDecisionTree cenv) + +and CheckDecisionTreeTest cenv discrim = + match discrim with + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv TailCall.No exp + | _ -> () + +and CheckBinding cenv alwaysCheckNoReraise ctxt (TBind (v, bindRhs, _) as bind) : unit = + let g = cenv.g + let isTop = Option.isSome bind.Var.ValReprInfo + let tailCall = TailCall.YesFromVal g bind.Var + + let valReprInfo = + match bind.Var.ValReprInfo with + | Some info -> info + | _ -> ValReprInfo.emptyValData + + CheckLambdas isTop (Some v) cenv v.MustInline valReprInfo tailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + +and CheckBindings cenv binds = + for bind in binds do + CheckBinding cenv false PermitByRefExpr.Yes bind + +let CheckModuleBinding cenv (isRec: bool) (TBind _ as bind) = + // Check that a let binding to the result of a rec expression is not inside the rec expression + // see test ``Warn for invalid tailcalls in seq expression because of bind`` for an example + // see test ``Warn successfully for rec call in binding`` for an example + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match bind.Expr with + | Expr.TyLambda (bodyExpr = bodyExpr) + | Expr.Lambda (bodyExpr = bodyExpr) -> + let rec checkTailCall (insideSubBinding: bool) expr = + match expr with + | Expr.Val (valRef = valRef; range = m) -> + if isRec && insideSubBinding && cenv.mustTailCall.Contains valRef.Deref then + warning (Error(FSComp.SR.chkNotTailRecursive valRef.DisplayName, m)) + | 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 + + let warnForBodyExpr = + match stripDebugPoints bodyExpr with + | Expr.Op _ -> true // ToDo: too crude of a check? + | _ -> false + + checkTailCall warnForBodyExpr bodyExpr + | Expr.Match (targets = decisionTreeTargets) -> + decisionTreeTargets + |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | Expr.Op (args = exprs) -> exprs |> Seq.iter (checkTailCall insideSubBinding) + | _ -> () + + checkTailCall false bodyExpr + | _ -> () + + CheckBinding cenv true PermitByRefExpr.Yes bind + +//-------------------------------------------------------------------------- +// check modules +//-------------------------------------------------------------------------- + +let rec CheckDefnsInModule cenv mdefs = + for mdef in mdefs do + CheckDefnInModule cenv mdef + +and CheckDefnInModule cenv mdef = + match mdef with + | TMDefRec (isRec, _opens, _tycons, mspecs, _m) -> + let cenv = + if isRec then + let vals = allValsOfModDef mdef + + let mustTailCall = + Seq.fold + (fun mustTailCall (v: Val) -> + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + let newSet = Zset.add v mustTailCall + newSet + else + mustTailCall) + cenv.mustTailCall + vals + + { cenv with + mustTailCall = mustTailCall + } + else + cenv + + List.iter (CheckModuleSpec cenv isRec) mspecs + | TMDefLet (bind, _m) -> CheckModuleBinding cenv false bind + | TMDefOpens _ -> () + | TMDefDo (e, _m) -> + let tailCall = + match stripDebugPoints e with + | Expr.App (funcExpr = funcExpr) -> + match funcExpr with + | ValUseAtApp (vref, _valUseFlags) -> TailCall.YesFromVal cenv.g vref.Deref + | _ -> TailCall.No + | _ -> TailCall.No + + CheckExprNoByrefs cenv tailCall e + | TMDefs defs -> CheckDefnsInModule cenv defs + +and CheckModuleSpec cenv isRec mbind = + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + if cenv.mustTailCall.Contains bind.Var then + CheckModuleBinding cenv isRec bind + + | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv rhs + +let CheckImplFile (g, amap, reportErrors, implFileContents) = + let cenv = + { + g = g + reportErrors = reportErrors + stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") + amap = amap + mustTailCall = Zset.empty valOrder + } + + CheckDefnInModule cenv implFileContents diff --git a/src/Compiler/Checking/TailCallChecks.fsi b/src/Compiler/Checking/TailCallChecks.fsi new file mode 100644 index 00000000000..2fa3b163755 --- /dev/null +++ b/src/Compiler/Checking/TailCallChecks.fsi @@ -0,0 +1,13 @@ +module internal FSharp.Compiler.TailCallChecks + +open FSharp.Compiler +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.TypedTree + +/// Perform the TailCall analysis on the optimized TAST for a file. +/// The TAST is traversed analogously to the PostInferenceChecks phase. +/// For functions that are annotated with the [] attribute, a warning is emmitted if they are called in a +/// non-tailrecursive manner in the recursive scope of the function. +/// The ModuleOrNamespaceContents aren't mutated in any way by performing this check. +val CheckImplFile: + g: TcGlobals * amap: Import.ImportMap * reportErrors: bool * implFileContents: ModuleOrNamespaceContents -> unit diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 1810681cd25..a6cd7733b98 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -40,6 +40,7 @@ open FSharp.Compiler.CreateILModule open FSharp.Compiler.DependencyManager open FSharp.Compiler.Diagnostics open FSharp.Compiler.DiagnosticsLogger +open FSharp.Compiler.Features open FSharp.Compiler.IlxGen open FSharp.Compiler.InfoReader open FSharp.Compiler.IO @@ -878,6 +879,14 @@ let main3 optimizedImpls, EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) + if tcGlobals.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match optimizedImpls with + | CheckedAssemblyAfterOptimization checkedImplFileAfterOptimizations -> + ReportTime tcConfig ("TailCall Checks") + + for f in checkedImplFileAfterOptimizations do + TailCallChecks.CheckImplFile(tcGlobals, tcImports.GetImportMap(), true, f.ImplFile.Contents) + let refAssemblySignatureHash = match tcConfig.emitMetadataAssembly with | MetadataAssemblyGeneration.None -> None diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 9962c04abd4..baf787606fb 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1576,6 +1576,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." @@ -1700,4 +1701,5 @@ featureInformationalObjInferenceDiagnostic,"Diagnostic 3559 (warn when obj infer 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" 3568,parsMissingKeyword,"Missing keyword '%s'" +3569,chkNotTailRecursive,"The member or function '%s' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." 3577,tcOverrideUsesMultipleArgumentsInsteadOfTuple,"This override takes a tuple instead of multiple arguments. Try to add an additional layer of parentheses at the method definition (e.g. 'member _.Foo((x, y))'), or remove parentheses at the abstract method declaration (e.g. 'abstract member Foo: 'a * 'b -> 'c')." \ No newline at end of file diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 2ebec6942dd..92276d105ec 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -337,6 +337,8 @@ + + diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 9c44cf332b2..d9e63cc3473 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -71,6 +71,7 @@ type LanguageFeature = | WarningWhenMultipleRecdTypeChoice | ImprovedImpliedArgumentNames | DiagnosticForObjInference + | WarningWhenTailRecAttributeButNonTailRecUsage /// LanguageVersion management type LanguageVersion(versionText) = @@ -165,6 +166,7 @@ type LanguageVersion(versionText) = LanguageFeature.ImprovedImpliedArgumentNames, previewVersion LanguageFeature.DiagnosticForObjInference, previewVersion LanguageFeature.StrictIndentation, previewVersion + LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage, previewVersion ] @@ -291,6 +293,7 @@ type LanguageVersion(versionText) = | LanguageFeature.ImprovedImpliedArgumentNames -> FSComp.SR.featureImprovedImpliedArgumentNames () | LanguageFeature.DiagnosticForObjInference -> FSComp.SR.featureInformationalObjInferenceDiagnostic () | LanguageFeature.StrictIndentation -> FSComp.SR.featureStrictIndentation () + | 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 4f124a3324c..66853eb1e29 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -61,6 +61,7 @@ type LanguageFeature = | WarningWhenMultipleRecdTypeChoice | ImprovedImpliedArgumentNames | DiagnosticForObjInference + | WarningWhenTailRecAttributeButNonTailRecUsage /// LanguageVersion management type LanguageVersion = diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 495244203be..563add19a67 100755 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -1509,6 +1509,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 3098741d674..90e1cce8b45 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. @@ -207,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 2277d79cbbb..7d27833b09f 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". @@ -207,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 231200689ee..a8e677179ba 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. @@ -207,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 00825630174..a22f959e7aa 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. @@ -207,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 4fb3debe94f..7d21cdb16a1 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'. @@ -207,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 89bbcfc639b..ad052e25d22 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' を使用してください。 @@ -207,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 f48dc4ad136..a003c8ae916 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'를 사용하세요. @@ -207,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 fae8595a137..f829eaf8e68 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”. @@ -207,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 0377a0a1229..cc2041d6026 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'. @@ -207,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 db5d1c8d4b8..49e6c92d5e8 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". @@ -207,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 40647aabc76..5ea3abcc5ac 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. @@ -207,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 e46bf93fb8c..e95ce09f131 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"。 @@ -207,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 007b002b5cc..994a149ea54 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'。 @@ -207,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/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..aa3249d8690 100644 --- a/src/FSharp.Core/prim-types.fsi +++ b/src/FSharp.Core/prim-types.fsi @@ -950,6 +950,27 @@ namespace Microsoft.FSharp.Core /// NoCompilerInliningAttribute new: unit -> NoCompilerInliningAttribute + /// Indicates a function that should be called in a tail recursive way inside its recursive scope. + /// A warning is emitted if the function is analyzed as not tail recursive after the optimization phase. + /// + /// Attributes + /// + /// + /// + /// let mul x y = x * y + /// [<TailCall>] + /// let rec fact n acc = + /// if n = 0 + /// then acc + /// else (fact (n - 1) (mul n acc)) + 23 // warning because of the addition after the call to fact + /// + /// + [] + [] + 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..a1e32599137 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -0,0 +1,1047 @@ +namespace FSharp.Compiler.ComponentTests.ErrorMessages + +open FSharp.Test.Compiler +open FSharp.Test.Compiler.Assertions.StructuredResultsAsserts + +module ``TailCall Attribute`` = + + [] + let ``Warn successfully in if-else`` () = + """ +namespace N + + module M = + + 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 + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 12 + StartColumn = 19 + EndLine = 12 + EndColumn = 43 } + 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`` () = + """ +namespace N + + module M = + + let mul x y = x * y + + [] + let rec fact n acc = + match n with + | 0 -> acc + | _ -> (fact (n - 1) (mul n acc)) + 23 + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 12 + StartColumn = 21 + EndLine = 12 + EndColumn = 45 } + 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`` () = + """ +namespace N + + module M = + + 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 + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 13 + StartColumn = 25 + EndLine = 13 + EndColumn = 49 } + 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 and bind from toplevel`` () = + """ +namespace N + + module M = + + let mul x y = x * y + + [] + let rec fact n acc = + if n = 0 + then acc + else + printfn "%A" n + fact (n - 1) (mul n acc) + + let r = fact 100000 1 + r |> ignore + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn successfully for mutually recursive functions`` () = + """ +namespace N + + module M = + + 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 + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 17 + StartColumn = 17 + EndLine = 17 + EndColumn = 28 } + 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`` () = + """ +namespace N + + module M = + + type C () = + [] + member this.M1() = this.M1() + 1 + + type InnerC () = + [] + member this.InnerCMeth x = this.InnerCMeth x + 23 + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 8 + StartColumn = 32 + EndLine = 8 + EndColumn = 41 } + Message = + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 12 + StartColumn = 44 + EndLine = 12 + EndColumn = 61 } + Message = + "The member or function 'InnerCMeth' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcall in type method`` () = + """ +namespace N + + module M = + + type C () = + [] + member this.M1() = + printfn "M1 called" + this.M1() + + let c = C() + c.M1() + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in type methods`` () = + """ +namespace N + + module M = + + type C () = + [] + member this.M1() = + printfn "M1 called" + this.M2() // ok + + [] + member this.M2() = + printfn "M2 called" + this.M1() // ok + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn successfully for invalid tailcalls in type methods`` () = + """ +namespace N + + module M = + + 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 + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 10 + StartColumn = 17 + EndLine = 10 + EndColumn = 26 } + Message = + "The member or function 'M2' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 15 + StartColumn = 17 + EndLine = 15 + EndColumn = 26 } + Message = +#if Debug + "The member or function 'M2' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } +#else + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } +#endif + ] + + [] + let ``Don't warn for valid tailcall and bind from nested bind`` () = + """ +namespace N + + module M = + + let mul x y = x * y + + [] + let rec fact n acc = + if n = 0 + then acc + else + printfn "%A" n + fact (n - 1) (mul n acc) + + let f () = + let r = fact 100000 1 + r |> ignore + + fact 100000 1 |> ignore + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in seq expression because of bind`` () = + """ +namespace N + + module M = + + [] + let rec f x : seq = + seq { + let r = f (x - 1) + let r2 = Seq.map (fun x -> x + 1) r + yield! r2 + } + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 9 + StartColumn = 25 + EndLine = 9 + EndColumn = 34 } + 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`` () = + """ +namespace N + + module M = + + [] + let rec f x : seq = + seq { + yield! f (x - 1) |> Seq.map (fun x -> x + 1) + } + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 9 + StartColumn = 24 + EndLine = 9 + EndColumn = 33 } + 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`` () = + """ +namespace N + + module M = + + [] + let rec f x = seq { + let y = x - 1 + let z = y - 1 + yield! f (z - 1) + } + + let a: seq = f 10 + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in async expression`` () = + """ +namespace N + + module M = + + [] + let rec f x = async { + let y = x - 1 + let z = y - 1 + return! f (z - 1) + } + + let a: Async = f 10 + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in async expression`` () = + """ +namespace N + + module M = + + [] + let rec f x = async { + let! r = f (x - 1) + return r + } + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 8 + StartColumn = 22 + EndLine = 8 + EndColumn = 23 } + 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 rec module`` () = + """ +namespace N + + module rec M = + + module M1 = + [] + let m1func() = M2.m2func() + + module M2 = + [] + let m2func() = M1.m1func() + + let f () = + M1.m1func() |> ignore + + module M2 = + + M.M1.m1func() |> ignore + M.M2.m2func() + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in rec module`` () = + """ +namespace N + + module rec M = + + module M1 = + [] + let m1func() = 1 + M2.m2func() + + module M2 = + [] + let m2func() = 2 + M1.m1func() + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 8 + StartColumn = 32 + EndLine = 8 + EndColumn = 43 } + Message = + "The member or function 'm2func' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 12 + StartColumn = 32 + EndLine = 12 + EndColumn = 43 } + Message = + "The member or function 'm2func' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn for byref parameters`` () = + """ +namespace N + + module M = + + [] + let rec foo(x: int byref) = foo(&x) + let run() = let mutable x = 0 in foo(&x) + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 7 + StartColumn = 37 + EndLine = 7 + EndColumn = 44 } + Message = + "The member or function 'foo' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for yield! in tail position`` () = + """ +namespace N + + module M = + + 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 // ToDo: okay to not warn here? + } + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn for calls in for and iter`` () = + """ +namespace N + + module M = + + 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 + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 24 + StartColumn = 17 + EndLine = 24 + EndColumn = 48 } + Message = + "The member or function 'CheckDefnInModule' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 35 + StartColumn = 17 + EndLine = 35 + EndColumn = 66 } + Message = + "The member or function 'CheckModuleSpec' has the 'TailCallAttribute' 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`` () = + """ +namespace N + + module M = + 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 // ToDo: also warn for partial app? + 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 + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 21 + StartColumn = 27 + EndLine = 21 + EndColumn = 35 } + Message = + "The member or function 'instType' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 17 + StartColumn = 32 + EndLine = 17 + EndColumn = 77 } + Message = + "The member or function 'instType' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn for invalid calls in inner bindings of conditional`` () = + """ +namespace N + + module M = + + [] + 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 + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 11 + StartColumn = 25 + EndLine = 11 + EndColumn = 36 } + Message = + "The member or function 'foldBackOpt' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 25 + EndLine = 14 + EndColumn = 36 } + Message = + "The member or function 'foldBackOpt' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for piped arg in tailrec call`` () = + """ +namespace N + + module M = + + [] + let rec loop xs = + xs + |> fun xs -> + loop xs + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn for ColonColon with inner let-bound value to rec call`` () = + """ +namespace N + + module M = + + [] + let rec addOne (input: int list) : int list = + match input with + | [] -> [] + | x :: xs -> + let head = (x + 1) + let tail = addOne xs + head :: tail + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 12 + StartColumn = 28 + EndLine = 12 + EndColumn = 34 } + Message = + "The member or function 'addOne' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn for ColonColon with rec call`` () = + """ +namespace N + + module M = + + [] + let rec addOne (input: int list) : int list = + match input with + | [] -> [] + | x :: xs -> (x + 1) :: addOne xs + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 10 + StartColumn = 37 + EndLine = 10 + EndColumn = 43 } + Message = + "The member or function 'addOne' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for ColonColon as arg of valid tail call`` () = + """ +namespace N + + module M = + + [] + let rec addOne (input: int list) (acc: int list) : int list = + match input with + | [] -> acc + | x :: xs -> addOne xs ((x + 1) :: acc) + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Warn for non tail-rec traversal`` () = + """ +namespace N + + module M = + + type 'a Tree = + | Leaf of 'a + | Node of 'a Tree * 'a Tree + + [] + let rec findMax (tree: int Tree) : int = + match tree with + | Leaf i -> i + | Node (l, r) -> System.Math.Max(findMax l, findMax r) + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 46 + EndLine = 14 + EndColumn = 53 } + Message = + "The member or function 'findMax' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 57 + EndLine = 14 + EndColumn = 64 } + Message = + "The member or function 'findMax' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 46 + EndLine = 14 + EndColumn = 55 } + Message = + "The member or function 'findMax' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 14 + StartColumn = 57 + EndLine = 14 + EndColumn = 66 } + Message = + "The member or function 'findMax' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for Continuation Passing Style func using [] func in continuation lambda`` () = + """ +namespace N + + module M = + + type 'a Tree = + | Leaf of 'a + | Node of 'a Tree * 'a Tree + + [] + let rec findMaxInner (tree: int Tree) (continuation: int -> int) : int = + match tree with + | Leaf i -> i |> continuation + | Node (left, right) -> + findMaxInner left (fun lMax -> + findMaxInner right (fun rMax -> + System.Math.Max(lMax, rMax) |> continuation + ) + ) + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Don't warn for Continuation Passing Style func not using [] func in continuation lambda`` () = + """ +namespace N + + module M = + + [] + let rec loop + (files: string list) + (finalContinuation: string list * string list -> string list * string list) + = + match files with + | [] -> finalContinuation ([], []) + | h :: rest -> + loop rest (fun (files, folders) -> + if h.EndsWith("/") then + files, (h :: folders) + else + (h :: files), folders + |> finalContinuation) + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Don't warn for Continuation Passing Style func using [] func in continuation lambda 2`` () = + """ +namespace N + + module M = + type 'a RoseTree = + | Leaf of 'a + | Node of 'a * 'a RoseTree list + + [] + let rec findMaxInner (roseTree : int RoseTree) (continuation : int -> 'ret) : 'ret = + match roseTree with + | Leaf i + | Node (i, []) -> i |> continuation + | Node (i, [ x ]) -> + findMaxInner x (fun xMax -> + System.Math.Max(i, xMax) |> continuation + ) + | Node (i, [ x; y ]) -> + findMaxInner x (fun xMax -> + findMaxInner y (fun yMax -> + System.Math.Max(i, System.Math.Max(xMax, yMax)) |> continuation + ) + ) + | _ -> failwith "Nodes with lists longer than 2 are not supported" + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Don't warn for Continuation Passing Style func using [] func in list of continuations`` () = + """ +namespace N + + [] + module Continuation = + let rec sequence<'a, 'ret> (recursions : (('a -> 'ret) -> 'ret) list) (finalContinuation : 'a list -> 'ret) : 'ret = + match recursions with + | [] -> [] |> finalContinuation + | recurse :: recurses -> + recurse (fun ret -> + sequence recurses (fun rets -> + ret :: rets |> finalContinuation + ) + ) + + module M = + type 'a RoseTree = + | Leaf of 'a + | Node of 'a * 'a RoseTree list + + [] + let rec findMaxInner (roseTree : int RoseTree) (finalContinuation : int -> 'ret) : 'ret = + match roseTree with + | Leaf i -> + i |> finalContinuation + | Node (i : int, xs : int RoseTree list) -> + let continuations : ((int -> 'ret) -> 'ret) list = xs |> List.map findMaxInner + let finalContinuation (maxValues : int list) : 'ret = List.max (i :: maxValues) |> finalContinuation + Continuation.sequence continuations finalContinuation + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed + + [] + let ``Don't warn for Continuation Passing Style func using [] func in object interface expression`` () = + """ +namespace N + +[] +type Foo<'a> = + | Pure of 'a + | Apply of ApplyCrate<'a> + +and ApplyEval<'a, 'ret> = abstract Eval<'b,'c,'d> : 'b Foo -> 'c Foo -> 'd Foo -> ('b -> 'c -> 'd -> 'a) Foo -> 'ret + +and ApplyCrate<'a> = abstract Apply : ApplyEval<'a, 'ret> -> 'ret + +module M = + + [] + let rec evaluateCps<'a, 'b> (f : 'a Foo) (cont : 'a -> 'b) : 'b = + match f with + | Pure a -> cont a + | Apply crate -> + crate.Apply + { new ApplyEval<_,_> with + member _.Eval b c d f = + evaluateCps f (fun f -> + evaluateCps b (fun b -> + evaluateCps c (fun c -> + evaluateCps d (fun d -> cont (f b c d)) + ) + ) + ) + } + """ + |> FSharp + |> withLangVersionPreview + |> compile + |> shouldSucceed diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index abaeb77e799..1ae8e218fdc 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -143,6 +143,7 @@ + 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()