diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 145c7e0799c..85ebb57601b 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -85,6 +85,12 @@ 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 module that have been marked [] + mustTailCall: Zset + + /// Recursive expressions of [] attributed values + mustTailCallExprs: Map + /// Are we in a quotation? quote : bool @@ -190,6 +196,42 @@ 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 + + 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 YesFromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) + + static member YesFromExpr (g: TcGlobals) (expr: Expr) = + match expr with + | ValUseAtApp(valRef, _) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) + | _ -> IsTailCall.Yes false + + 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 + type cenv = { boundVals: Dictionary // really a hash set @@ -300,7 +342,7 @@ let BindVal cenv env (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 - + let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = match v.TryDeclaringEntity with @@ -769,11 +811,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)) @@ -791,13 +833,17 @@ 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 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 else 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 @@ -842,19 +888,19 @@ 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) expr = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr // 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 @@ -886,7 +932,50 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = | None -> () | _ -> () | _ -> () - | _ -> () + + 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) + + let noTailCallBlockers = + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + noTailCallBlockers + 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 @@ -950,7 +1039,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. @@ -964,9 +1053,9 @@ 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 + 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. @@ -975,12 +1064,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 @@ -995,31 +1084,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 @@ -1029,63 +1118,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, _)) -> + 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 @@ -1094,13 +1183,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 @@ -1108,13 +1197,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 () -> @@ -1124,11 +1213,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 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 @@ -1143,11 +1232,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 env e1 - CheckExprNoByrefs cenv env e2 + CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env IsTailCall.No e2 NoLimit | Expr.Const (_, m, ty) -> @@ -1155,7 +1244,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) @@ -1196,24 +1285,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) @@ -1226,7 +1315,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 @@ -1263,14 +1352,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 @@ -1295,11 +1384,11 @@ 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) + 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 @@ -1321,15 +1410,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 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 _ -> @@ -1345,7 +1434,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 @@ -1358,30 +1447,31 @@ 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 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 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) = - BindVals cenv env (valsOfBinds binds) +and CheckLetRec cenv env (binds, bodyExpr) isTailCall = + let vals = valsOfBinds binds + BindVals cenv env vals CheckBindings cenv env binds - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr NoLimit and CheckStaticOptimization cenv env (constraints, e2, e3, m) = - CheckExprNoByrefs cenv env e2 - CheckExprNoByrefs cenv 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 @@ -1408,7 +1498,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) @@ -1445,8 +1535,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 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, _, _)] -> @@ -1455,9 +1545,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 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 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), _, _ -> @@ -1578,11 +1668,12 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = NoLimit | TOp.Coerce, [tgtTy;srcTy], [x] -> + let isTailCall = IsTailCall.YesFromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt + CheckExpr cenv env x ctxt isTailCall else CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env x + CheckExprNoByrefs cenv env isTailCall x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -1617,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.UnionCaseFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs @@ -1638,7 +1729,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 @@ -1646,6 +1737,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 env IsTailCall.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 env args @@ -1671,7 +1766,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 @@ -1701,7 +1796,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) @@ -1710,7 +1805,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, _) -> @@ -1772,7 +1867,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 @@ -1800,25 +1895,25 @@ 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 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)) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) isTailCall) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do - CheckExprNoByrefs cenv env expr + CheckExprNoByrefs cenv env IsTailCall.No expr NoLimit and CheckExprsPermitByRefLike cenv env exprs : Limit = @@ -1827,22 +1922,22 @@ and CheckExprsPermitByRefLike cenv env exprs : Limit = |> CombineLimits and CheckExprPermitByRefLike cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.Yes + CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No and CheckExprPermitReturnableByRef cenv env expr : Limit = - CheckExpr cenv 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 @@ -1868,7 +1963,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 env IsTailCall.No exp | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = @@ -1878,8 +1973,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 env IsTailCall.No expr + CheckExprNoByrefs cenv env IsTailCall.No vexpr CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr @@ -2065,7 +2160,8 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () | _ -> () - + + 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 @@ -2084,14 +2180,14 @@ 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 env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings 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 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 @@ -2100,6 +2196,33 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) + 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 && env.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 + 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 bodyExpr + | _ -> () + // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields not v.IsMutable && @@ -2555,6 +2678,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 @@ -2567,26 +2708,54 @@ 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) 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 _ -> () | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs cenv env 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 mbind = +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 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 } @@ -2616,7 +2785,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v isLastCompiland = isLastCompiland isInternalTestSpanStackReferring = isInternalTestSpanStackReferring tcVal = tcValF - entryPointGiven = false} + 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. @@ -2634,6 +2803,8 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v quote=false boundTyparNames=[] argVals = ValMap.Empty + mustTailCall = Zset.empty valOrder + mustTailCallExprs = Map.Empty boundTypars= TyparMap.Empty reflect=false external=false @@ -2646,5 +2817,5 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then viewCcu.UsesFSharp20PlusQuotations <- true - + cenv.entryPointGiven, cenv.anonRecdTypes diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 764f3faf17b..44dbfea3501 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." @@ -1699,4 +1700,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 'TailCall' 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/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 ca6b200d289..d4af038c738 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 '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. + + 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 bdf17adf380..064ad7121a2 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 '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. + + 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 c5007a50061..2cc717cd617 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 '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. + + 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 c2463e00d85..a6027aaf8f8 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 '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. + + 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 5ebbcba622c..46715393955 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 '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. + + 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 c1386905952..acee9f2e2ad 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 '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. + + 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 0eb30c8dded..7bb1ae1e61f 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 '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. + + 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 3f6fea05549..6cd88b0f97e 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 '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. + + 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 f6266c53e42..21654e04158 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 '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. + + 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 ecdcfa32b82..54f3884a3bc 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 '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. + + 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 0fa9a39ce0e..e6dbcfcaed5 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 '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. + + 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 99389653fa3..a57627c7aed 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 '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. + + 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 3eb9b4952ab..4719be03134 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 '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. + + 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..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..4ed83083667 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -0,0 +1,712 @@ +namespace FSharp.Compiler.ComponentTests.ErrorMessages + +open FSharp.Test.Compiler +open FSharp.Test.Compiler.Assertions.StructuredResultsAsserts + +module ``TailCall Attribute`` = + + [] + let ``Warn successfully in if-else`` () = + """ +let mul x y = x * y + +module M = + [] + let rec fact n acc = + if n = 0 + then acc + else (fact (n - 1) (mul n acc)) + 23 + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3569 + 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 = 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." } + ] + + [] + 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 + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { 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 3569 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 17 } + Message = + "The member or function 'fact' has the 'TailCall' 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 + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 9 + StartColumn = 17 + EndLine = 9 + EndColumn = 21 } + Message = + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcall and bind from toplevel`` () = + """ +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 + |> typecheck + |> shouldSucceed + + [] + let ``Warn successfully for mutually recursive functions`` () = + """ +let foo x = + printfn "Foo: %x" x + +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 + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3569 + 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 = 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." } + ] + + [] + let ``Warn successfully for invalid tailcall in type method`` () = + """ +type C () = + [] + member this.M1() = this.M1() + 1 + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 4 + StartColumn = 24 + EndLine = 4 + EndColumn = 33 } + Message = + "The member or function 'M1' has the 'TailCall' 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() = + printfn "M1 called" + this.M1() + +let c = C() +c.M1() + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in type methods`` () = + """ +type C () = + [] + member this.M1() = + printfn "M1 called" + this.M2() // ok + + [] + member this.M2() = + printfn "M2 called" + this.M1() // ok + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn successfully for invalid tailcalls in type methods`` () = + """ +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 + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3569 + 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 = 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." } + ] + + [] + 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 + printfn "%A" n + fact (n - 1) (mul n acc) + +let f () = + let r = fact 100000 1 + r |> ignore + +fact 100000 1 |> ignore + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in seq expression because of bind`` () = + """ +[] +let rec f x : seq = + seq { + let r = f (x - 1) + let r2 = Seq.map (fun x -> x + 1) r + yield! r2 +} + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 5 + StartColumn = 17 + EndLine = 5 + EndColumn = 18 } + Message = + "The member or function 'f' has the 'TailCall' 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 + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { 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 3569 + Range = { StartLine = 5 + StartColumn = 16 + EndLine = 5 + EndColumn = 17 } + 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 seq expression`` () = + """ +[] +let rec f x = seq { + let y = x - 1 + let z = y - 1 + yield! f (z - 1) +} + +let a: seq = f 10 + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in async expression`` () = + """ +[] +let rec f x = async { + let y = x - 1 + let z = y - 1 + return! f (z - 1) +} + +let a: Async = f 10 + """ + |> 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 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 3569 + 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." } + ] + + [] + 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() + + let f () = + M1.m1func() |> ignore + +M.M1.m1func() |> ignore +M.M2.m2func() + """ + |> 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 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 + 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 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 + EndLine = 10 + EndColumn = 37 } + 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 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." } + ] + + [] + 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." } + ] + + [] + 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 // 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 + |> 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 + EndLine = 18 + 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 = 7 + StartColumn = 17 + EndLine = 7 + EndColumn = 28 } + Message = + "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." } + ] diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index c99458dabbf..d20aa0e1c3f 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()