From ee4e19ed9c21dd1a549e8b29b0ed87e5f7abeb9d Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 25 May 2023 11:28:56 +0200 Subject: [PATCH 01/77] Add TailCall attribute Move work of Avi Avni to current sources but use a field in cenv instead of a function parameter to pass around --- src/Compiler/Checking/PostInferenceChecks.fs | 1340 +++++++++-------- src/Compiler/FSComp.txt | 1 + src/Compiler/TypedTree/TcGlobals.fs | 1 + src/Compiler/xlf/FSComp.txt.cs.xlf | 5 + src/Compiler/xlf/FSComp.txt.de.xlf | 5 + src/Compiler/xlf/FSComp.txt.es.xlf | 5 + src/Compiler/xlf/FSComp.txt.fr.xlf | 5 + src/Compiler/xlf/FSComp.txt.it.xlf | 5 + src/Compiler/xlf/FSComp.txt.ja.xlf | 5 + src/Compiler/xlf/FSComp.txt.ko.xlf | 5 + src/Compiler/xlf/FSComp.txt.pl.xlf | 5 + src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 5 + src/Compiler/xlf/FSComp.txt.ru.xlf | 5 + src/Compiler/xlf/FSComp.txt.tr.xlf | 5 + src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 5 + src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 5 + src/FSharp.Core/prim-types.fs | 5 + src/FSharp.Core/prim-types.fsi | 6 + .../ErrorMessages/TailCallAttribute.fs | 147 ++ .../FSharp.Compiler.ComponentTests.fsproj | 1 + 20 files changed, 943 insertions(+), 623 deletions(-) create mode 100644 tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index b9dd8dbcc14..7dfa7440133 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -32,24 +32,24 @@ open FSharp.Compiler.TypeRelations //-------------------------------------------------------------------------- // NOTES: reraise safety checks //-------------------------------------------------------------------------- - + // "rethrow may only occur with-in the body of a catch handler". // -- Section 4.23. Part III. CLI Instruction Set. ECMA Draft 2002. -// +// // 1. reraise() calls are converted to TOp.Reraise in the type checker. // 2. any remaining reraise val_refs will be first class uses. These are trapped. // 3. The freevars track free TOp.Reraise (they are bound (cleared) at try-catch handlers). // 4. An outermost expression is not contained in a try-catch handler. -// These may not have unbound rethrows. +// These may not have unbound rethrows. // Outermost expressions occur at: // * module bindings. // * attribute arguments. -// * Any more? What about fields of a static class? +// * Any more? What about fields of a static class? // 5. A lambda body (from lambda-expression or method binding) will not occur under a try-catch handler. // These may not have unbound rethrows. // 6. All other constructs are assumed to generate IL code sequences. // For correctness, this claim needs to be justified. -// +// // Informal justification: // If a reraise occurs, then it is minimally contained by either: // a) a try-catch - accepted. @@ -67,15 +67,15 @@ type Resumable = | None /// Indicates we are expecting resumable code (the body of a ResumableCode delegate or /// the body of the MoveNextMethod for a state machine) - /// -- allowed: are we inside the 'then' branch of an 'if __useResumableCode then ...' + /// -- allowed: are we inside the 'then' branch of an 'if __useResumableCode then ...' /// for a ResumableCode delegate. | ResumableExpr of allowed: bool -type env = - { +type env = + { /// The bound type parameter names in scope - boundTyparNames: string list - + boundTyparNames: string list + /// The bound type parameters in scope boundTypars: TyparMap @@ -83,45 +83,48 @@ type env = argVals: ValMap /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature - sigToImplRemapInfo: (Remap * SignatureHidingInfo) list + sigToImplRemapInfo: (Remap * SignatureHidingInfo) list + + /// Values in this recursive scope that have been marked [] + mustTailCall: Zset; /// Are we in a quotation? - quote : bool + quote : bool /// Are we under []? reflect : bool /// Are we in an extern declaration? - external : bool - + external : bool + /// Current return scope of the expr. - returnScope : int - + returnScope : int + /// Are we in an app expression (Expr.App)? isInAppExpr: bool /// Are we expecting a resumable code block etc resumableCode: Resumable - } + } override _.ToString() = "" -let BindTypar env (tp: Typar) = - { env with +let BindTypar env (tp: Typar) = + { env with boundTyparNames = tp.Name :: env.boundTyparNames - boundTypars = env.boundTypars.Add (tp, ()) } + boundTypars = env.boundTypars.Add (tp, ()) } -let BindTypars g env (tps: Typar list) = +let BindTypars g env (tps: Typar list) = let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps if isNil tps then env else - // Here we mutate to provide better names for generalized type parameters + // Here we mutate to provide better names for generalized type parameters let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps - PrettyTypes.AssignPrettyTyparNames tps nms - List.fold BindTypar env tps + PrettyTypes.AssignPrettyTyparNames tps nms + List.fold BindTypar env tps -/// Set the set of vals which are arguments in the active lambda. We are allowed to return +/// Set the set of vals which are arguments in the active lambda. We are allowed to return /// byref arguments as byref returns. -let BindArgVals env (vs: Val list) = +let BindArgVals env (vs: Val list) = { env with argVals = ValMap.OfList (List.map (fun v -> (v, ())) vs) } /// Limit flags represent a type(s) returned from checking an expression(s) that is interesting to impose rules on. @@ -152,7 +155,7 @@ let NoLimit = { scope = 0; flags = LimitFlags.None } // Combining two limits will result in both limit flags merged. // If none of the limits are limited by a by-ref or a stack referring span-like // the scope will be 0. -let CombineTwoLimits limit1 limit2 = +let CombineTwoLimits limit1 limit2 = let isByRef1 = HasLimitFlag LimitFlags.ByRef limit1 let isByRef2 = HasLimitFlag LimitFlags.ByRef limit2 let isStackSpan1 = HasLimitFlag LimitFlags.StackReferringSpanLike limit1 @@ -160,7 +163,7 @@ let CombineTwoLimits limit1 limit2 = let isLimited1 = isByRef1 || isStackSpan1 let isLimited2 = isByRef2 || isStackSpan2 - // A limit that has a stack referring span-like but not a by-ref, + // A limit that has a stack referring span-like but not a by-ref, // we force the scope to 1. This is to handle call sites // that return a by-ref and have stack referring span-likes as arguments. // This is to ensure we can only prevent out of scope at the method level rather than visibility. @@ -190,27 +193,48 @@ let CombineLimits limits = (NoLimit, limits) ||> List.fold CombineTwoLimits -type cenv = +type IsTailCall = + | Yes of bool // true indicates "has unit return type and must return void" + | No + + static member AtMethodOrFunction isVoidRet = + IsTailCall.Yes isVoidRet + + member x.AtExprLambda = + match x with + // Inside a lambda that is considered an expression, we must always return "unit" not "void" + | IsTailCall.Yes _ -> IsTailCall.Yes false + | IsTailCall.No -> IsTailCall.No + +let IsValRefIsDllImport g (vref:ValRef) = + vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute + +let (|ValUseAtApp|_|) e = + match e with + | InnerExprPat(Expr.App(InnerExprPat(Expr.Val(vref,valUseFlags,_)),_,_,[],_) | Expr.Val(vref,valUseFlags,_)) -> Some (vref, valUseFlags) + | _ -> None + +type cenv = { boundVals: Dictionary // really a hash set limitVals: Dictionary - mutable potentialUnboundUsesOfVals: StampMap + mutable potentialUnboundUsesOfVals: StampMap - mutable anonRecdTypes: StampMap + mutable anonRecdTypes: StampMap stackGuard: StackGuard - g: TcGlobals + g: TcGlobals - amap: Import.ImportMap + amap: Import.ImportMap /// For reading metadata infoReader: InfoReader internalsVisibleToPaths : CompilationPath list - denv: DisplayEnv + denv: DisplayEnv viewCcu : CcuThunk @@ -223,10 +247,12 @@ type cenv = // outputs mutable usesQuotations: bool - mutable entryPointGiven: bool - + mutable entryPointGiven: bool + /// Callback required for quotation generation - tcVal: ConstraintSolver.TcValF } + tcVal: ConstraintSolver.TcValF + + isTailCall: IsTailCall } override x.ToString() = "" @@ -261,7 +287,7 @@ let GetLimitVal cenv env m (v: Val) = elif isByrefTy cenv.g v.Type then let isByRefOfSpanLike = isSpanLikeTy cenv.g m (destByrefTy cenv.g v.Type) - + if isByRefOfSpanLike then if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then { limit with flags = LimitFlags.ByRefOfStackReferringSpanLike } @@ -292,15 +318,15 @@ let GetLimitValByRef cenv env m v = { scope = scope; flags = flags } -let LimitVal cenv (v: Val) limit = +let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit -let BindVal cenv env (v: Val) = +let BindVal cenv env (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 @@ -311,14 +337,14 @@ let BindVal cenv env (v: Val) = | ValueSome e -> e.HasSignatureFile v.IsModuleBinding && not v.HasSignatureFile && parentHasSignatureFile () - + if not env.external && not alreadyDone && - cenv.reportErrors && - not v.HasBeenReferenced && + cenv.reportErrors && + not v.HasBeenReferenced && (not v.IsCompiledAsTopLevel || topLevelBindingHiddenBySignatureFile ()) && not (v.DisplayName.StartsWithOrdinal("_")) && - not v.IsCompilerGenerated then + not v.IsCompilerGenerated then if v.IsCtorThisVal then warning (Error(FSComp.SR.chkUnusedThisVariable v.DisplayName, v.Range)) @@ -328,9 +354,13 @@ let BindVal cenv env (v: Val) = let BindVals cenv env vs = List.iter (BindVal cenv env) vs let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = - if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then + if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo) +let ComputeMustTailCallForRecVals cenv env (binds: Bindings) = + let mustTailCall = [ for b in binds do if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute b.Var.Attribs then yield b.Var ] + { env with mustTailCall = Zset.addList mustTailCall env.mustTailCall } + //-------------------------------------------------------------------------- // approx walk of type //-------------------------------------------------------------------------- @@ -341,40 +371,40 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi // those attached to _solved_ type variables. This is used by PostTypeCheckSemanticChecks to detect uses of // values as solutions to trait constraints and determine if inference has caused the value to escape its scope. // The only record of these solutions is in the _solved_ constraints of types. - // In an ideal world we would, instead, record the solutions to these constraints as "witness variables" in expressions, - // rather than solely in types. - match ty with + // In an ideal world we would, instead, record the solutions to these constraints as "witness variables" in expressions, + // rather than solely in types. + match ty with | TType_var (tp, _) when tp.Solution.IsSome -> for cx in tp.Constraints do - match cx with - | TyparConstraint.MayResolveMember(TTrait(_, _, _, _, _, soln), _) -> - match visitTraitSolutionOpt, soln.Value with + match cx with + | TyparConstraint.MayResolveMember(TTrait(_, _, _, _, _, soln), _) -> + match visitTraitSolutionOpt, soln.Value with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () | _ -> () | _ -> () - + let ty = if g.compilingFSharpCore then match stripTyparEqns ty with // When compiling FSharp.Core, do not strip type equations at this point if we can't dereference a tycon. | TType_app (tcref, _, _) when not tcref.CanDeref -> ty | _ -> stripTyEqns g ty - else + else stripTyEqns g ty visitTy ty match ty with - | TType_forall (tps, body) -> + | TType_forall (tps, body) -> let env = BindTypars g env tps - CheckTypeDeep cenv f g env isInner body + CheckTypeDeep cenv f g env isInner body tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep cenv f g env)) | TType_measure _ -> () - | TType_app (tcref, tinst, _) -> - match visitTyconRefOpt with - | Some visitTyconRef -> visitTyconRef isInner tcref + | TType_app (tcref, tinst, _) -> + match visitTyconRefOpt with + | Some visitTyconRef -> visitTyconRef isInner tcref | None -> () // If it's a 'byref<'T>', don't check 'T as an inner. This allows byref>. @@ -384,11 +414,11 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi else CheckTypesDeep cenv f g env tinst - match visitAppTyOpt with + match visitAppTyOpt with | Some visitAppTy -> visitAppTy (tcref, tinst) | None -> () - | TType_anon (anonInfo, tys) -> + | TType_anon (anonInfo, tys) -> RecordAnonRecdInfo cenv anonInfo CheckTypesDeep cenv f g env tys @@ -402,91 +432,91 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi CheckTypeDeep cenv f g env true s CheckTypeDeep cenv f g env true t - | TType_var (tp, _) -> - if not tp.IsSolved then - match visitTyparOpt with + | TType_var (tp, _) -> + if not tp.IsSolved then + match visitTyparOpt with | None -> () - | Some visitTyar -> + | Some visitTyar -> visitTyar (env, tp) -and CheckTypesDeep cenv f g env tys = +and CheckTypesDeep cenv f g env tys = for ty in tys do CheckTypeDeep cenv f g env true ty -and CheckTypesDeepNoInner cenv f g env tys = +and CheckTypesDeepNoInner cenv f g env tys = for ty in tys do CheckTypeDeep cenv f g env false ty and CheckTypeConstraintDeep cenv f g env x = - match x with + match x with | TyparConstraint.CoercesTo(ty, _) -> CheckTypeDeep cenv f g env true ty | TyparConstraint.MayResolveMember(traitInfo, _) -> CheckTraitInfoDeep cenv f g env traitInfo | TyparConstraint.DefaultsTo(_, ty, _) -> CheckTypeDeep cenv f g env true ty | TyparConstraint.SimpleChoice(tys, _) -> CheckTypesDeep cenv f g env tys | TyparConstraint.IsEnum(underlyingTy, _) -> CheckTypeDeep cenv f g env true underlyingTy | TyparConstraint.IsDelegate(argTys, retTy, _) -> CheckTypeDeep cenv f g env true argTys; CheckTypeDeep cenv f g env true retTy - | TyparConstraint.SupportsComparison _ - | TyparConstraint.SupportsEquality _ - | TyparConstraint.SupportsNull _ - | TyparConstraint.IsNonNullableStruct _ + | TyparConstraint.SupportsComparison _ + | TyparConstraint.SupportsEquality _ + | TyparConstraint.SupportsNull _ + | TyparConstraint.IsNonNullableStruct _ | TyparConstraint.IsUnmanaged _ - | TyparConstraint.IsReferenceType _ + | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> () -and CheckTraitInfoDeep cenv (_, _, _, visitTraitSolutionOpt, _ as f) g env (TTrait(tys, _, _, argTys, retTy, soln)) = - CheckTypesDeep cenv f g env tys - CheckTypesDeep cenv f g env argTys +and CheckTraitInfoDeep cenv (_, _, _, visitTraitSolutionOpt, _ as f) g env (TTrait(tys, _, _, argTys, retTy, soln)) = + CheckTypesDeep cenv f g env tys + CheckTypesDeep cenv f g env argTys Option.iter (CheckTypeDeep cenv f g env true ) retTy - match visitTraitSolutionOpt, soln.Value with + match visitTraitSolutionOpt, soln.Value with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () /// Check for byref-like types -let CheckForByrefLikeType cenv env m ty check = +let CheckForByrefLikeType cenv env m ty check = CheckTypeDeep cenv (ignore, Some (fun _deep tcref -> if isByrefLikeTyconRef cenv.g m tcref then check()), None, None, None) cenv.g env false ty /// Check for byref types -let CheckForByrefType cenv env ty check = +let CheckForByrefType cenv env ty check = CheckTypeDeep cenv (ignore, Some (fun _deep tcref -> if isByrefTyconRef cenv.g tcref then check()), None, None, None) cenv.g env false ty /// check captures under lambdas /// -/// This is the definition of what can/can't be free in a lambda expression. This is checked at lambdas OR TBind(v, e) nodes OR TObjExprMethod nodes. -/// For TBind(v, e) nodes we may know an 'arity' which gives as a larger set of legitimate syntactic arguments for a lambda. -/// For TObjExprMethod(v, e) nodes we always know the legitimate syntactic arguments. +/// This is the definition of what can/can't be free in a lambda expression. This is checked at lambdas OR TBind(v, e) nodes OR TObjExprMethod nodes. +/// For TBind(v, e) nodes we may know an 'arity' which gives as a larger set of legitimate syntactic arguments for a lambda. +/// For TObjExprMethod(v, e) nodes we always know the legitimate syntactic arguments. let CheckEscapes cenv allowProtected m syntacticArgs body = (* m is a range suited to error reporting *) - if cenv.reportErrors then - let cantBeFree (v: Val) = - // If v is a syntactic argument, then it can be free since it was passed in. - // The following can not be free: - // a) BaseVal can never escape. - // b) Byref typed values can never escape. + if cenv.reportErrors then + let cantBeFree (v: Val) = + // If v is a syntactic argument, then it can be free since it was passed in. + // The following can not be free: + // a) BaseVal can never escape. + // b) Byref typed values can never escape. // Note that: Local mutables can be free, as they will be boxed later. - // These checks must correspond to the tests governing the error messages below. + // These checks must correspond to the tests governing the error messages below. (v.IsBaseVal || isByrefLikeTy cenv.g m v.Type) && not (ListSet.contains valEq v syntacticArgs) let frees = freeInExpr (CollectLocalsWithStackGuard()) body - let fvs = frees.FreeLocals + let fvs = frees.FreeLocals if not allowProtected && frees.UsesMethodLocalConstructs then errorR(Error(FSComp.SR.chkProtectedOrBaseCalled(), m)) - elif Zset.exists cantBeFree fvs then - let v = List.find cantBeFree (Zset.elements fvs) + elif Zset.exists cantBeFree fvs then + let v = List.find cantBeFree (Zset.elements fvs) - // byref error before mutable error (byrefs are mutable...). + // byref error before mutable error (byrefs are mutable...). if (isByrefLikeTy cenv.g m v.Type) then - // Inner functions are not guaranteed to compile to method with a predictable arity (number of arguments). - // As such, partial applications involving byref arguments could lead to closures containing byrefs. - // For safety, such functions are assumed to have no known arity, and so can not accept byrefs. + // Inner functions are not guaranteed to compile to method with a predictable arity (number of arguments). + // As such, partial applications involving byref arguments could lead to closures containing byrefs. + // For safety, such functions are assumed to have no known arity, and so can not accept byrefs. errorR(Error(FSComp.SR.chkByrefUsedInInvalidWay(v.DisplayName), m)) elif v.IsBaseVal then errorR(Error(FSComp.SR.chkBaseUsedInInvalidWay(), m)) else - // Should be dead code, unless governing tests change + // Should be dead code, unless governing tests change errorR(InternalError(FSComp.SR.chkVariableUsedInInvalidWay(v.DisplayName), m)) Some frees else @@ -498,17 +528,17 @@ let AccessInternalsVisibleToAsInternal thisCompPath internalsVisibleToPaths acce // Each internalsVisibleToPath is a compPath for the internals of some assembly. // Replace those by the compPath for the internals of this assembly. // This makes those internals visible here, but still internal. Bug://3737 - (access, internalsVisibleToPaths) ||> List.fold (fun access internalsVisibleToPath -> + (access, internalsVisibleToPaths) ||> List.fold (fun access internalsVisibleToPath -> accessSubstPaths (thisCompPath, internalsVisibleToPath) access) - + let CheckTypeForAccess (cenv: cenv) env objName valAcc m ty = - if cenv.reportErrors then + if cenv.reportErrors then - let visitType ty = - // We deliberately only check the fully stripped type for accessibility, + let visitType ty = + // We deliberately only check the fully stripped type for accessibility, // because references to private type abbreviations are permitted - match tryTcrefOfAppTy cenv.g ty with + match tryTcrefOfAppTy cenv.g ty with | ValueNone -> () | ValueSome tcref -> let thisCompPath = compPathOfCcu cenv.viewCcu @@ -519,12 +549,12 @@ let CheckTypeForAccess (cenv: cenv) env objName valAcc m ty = CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env false ty let WarnOnWrongTypeForAccess (cenv: cenv) env objName valAcc m ty = - if cenv.reportErrors then + if cenv.reportErrors then - let visitType ty = - // We deliberately only check the fully stripped type for accessibility, + let visitType ty = + // We deliberately only check the fully stripped type for accessibility, // because references to private type abbreviations are permitted - match tryTcrefOfAppTy cenv.g ty with + match tryTcrefOfAppTy cenv.g ty with | ValueNone -> () | ValueSome tcref -> let thisCompPath = compPathOfCcu cenv.viewCcu @@ -534,11 +564,11 @@ let WarnOnWrongTypeForAccess (cenv: cenv) env objName valAcc m ty = let warningText = errorText + Environment.NewLine + FSComp.SR.tcTypeAbbreviationsCheckedAtCompileTime() warning(AttributeChecking.ObsoleteWarning(warningText, m)) - CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env false ty + CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env false ty /// Indicates whether a byref or byref-like type is permitted at a particular location [] -type PermitByRefType = +type PermitByRefType = /// Don't permit any byref or byref-like types | None @@ -551,14 +581,14 @@ type PermitByRefType = /// Permit all byref and byref-like types | All - + /// Indicates whether an address-of operation is permitted at a particular location [] -type PermitByRefExpr = +type PermitByRefExpr = /// Permit a tuple of arguments where elements can be byrefs - | YesTupleOfArgs of int + | YesTupleOfArgs of int - /// Context allows for byref typed expr. + /// Context allows for byref typed expr. | Yes /// Context allows for byref typed expr, but the byref must be returnable @@ -567,19 +597,19 @@ type PermitByRefExpr = /// 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 + /// General (address-of expr and byref values not allowed) + | No - member ctxt.Disallow = - match ctxt with - | PermitByRefExpr.Yes - | PermitByRefExpr.YesReturnable - | PermitByRefExpr.YesReturnableNonLocal -> false + member ctxt.Disallow = + match ctxt with + | PermitByRefExpr.Yes + | PermitByRefExpr.YesReturnable + | PermitByRefExpr.YesReturnableNonLocal -> false | _ -> true - member ctxt.PermitOnlyReturnable = - match ctxt with - | PermitByRefExpr.YesReturnable + member ctxt.PermitOnlyReturnable = + match ctxt with + | PermitByRefExpr.YesReturnable | PermitByRefExpr.YesReturnableNonLocal -> true | _ -> false @@ -591,46 +621,46 @@ type PermitByRefExpr = let inline IsLimitEscapingScope env (ctxt: PermitByRefExpr) limit = (limit.scope >= env.returnScope || (limit.IsLocal && ctxt.PermitOnlyReturnableNonLocal)) -let mkArgsPermit n = +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 = +let mkArgsForAppliedVal isBaseCall (vref: ValRef) argsl = match vref.ValReprInfo with - | Some valReprInfo -> + | 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 + if List.length argsl >= argArities.Length then List.map mkArgsPermit argArities else [] - | None -> [] + | 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 + 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 + // 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 types occurring in the TAST. let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError = - if cenv.reportErrors then - let visitTyar (env, tp) = - if not (env.boundTypars.ContainsKey tp) then - if tp.IsCompilerGenerated then + if cenv.reportErrors then + let visitTyar (env, tp) = + if not (env.boundTypars.ContainsKey tp) then + if tp.IsCompilerGenerated then errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScopeAnon(), m)) else errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScope(tp.DisplayName), m)) let visitTyconRef isInner tcref = - + let isInnerByRefLike = isInner && isByrefLikeTyconRef cenv.g m tcref match permitByRefLike with @@ -642,25 +672,25 @@ let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError = onInnerByrefError () | _ -> () - if tyconRefEq cenv.g cenv.g.system_Void_tcref tcref then + if tyconRefEq cenv.g cenv.g.system_Void_tcref tcref then errorR(Error(FSComp.SR.chkSystemVoidOnlyInTypeof(), m)) // check if T contains byref types in case of byref - let visitAppTy (tcref, tinst) = + let visitAppTy (tcref, tinst) = if isByrefLikeTyconRef cenv.g m tcref then let visitType ty0 = match tryTcrefOfAppTy cenv.g ty0 with | ValueNone -> () - | ValueSome tcref2 -> - if isByrefTyconRef cenv.g tcref2 then - errorR(Error(FSComp.SR.chkNoByrefsOfByrefs(NicePrint.minimalStringOfType cenv.denv ty), m)) + | ValueSome tcref2 -> + if isByrefTyconRef cenv.g tcref2 then + errorR(Error(FSComp.SR.chkNoByrefsOfByrefs(NicePrint.minimalStringOfType cenv.denv ty), m)) CheckTypesDeep cenv (visitType, None, None, None, None) cenv.g env tinst - let visitTraitSolution info = - match info with - | FSMethSln(_, vref, _, _) -> + let visitTraitSolution info = + match info with + | FSMethSln(_, vref, _, _) -> //printfn "considering %s..." vref.DisplayName - if valRefInThisAssembly cenv.g.compilingFSharpCore vref && not (cenv.boundVals.ContainsKey(vref.Stamp)) then + if valRefInThisAssembly cenv.g.compilingFSharpCore vref && not (cenv.boundVals.ContainsKey(vref.Stamp)) then //printfn "recording %s..." vref.DisplayName cenv.potentialUnboundUsesOfVals <- cenv.potentialUnboundUsesOfVals.Add(vref.Stamp, m) | _ -> () @@ -671,7 +701,7 @@ let CheckType permitByRefLike cenv env m ty = CheckTypeAux permitByRefLike cenv env m ty (fun () -> errorR(Error(FSComp.SR.chkErrorUseOfByref(), m))) /// Check types occurring in TAST (like CheckType) and additionally reject any byrefs. -/// The additional byref checks are to catch "byref instantiations" - one place were byref are not permitted. +/// The additional byref checks are to catch "byref instantiations" - one place were byref are not permitted. let CheckTypeNoByrefs (cenv: cenv) env m ty = CheckType PermitByRefType.None cenv env m ty /// Check types occurring in TAST but allow a Span or similar @@ -690,21 +720,21 @@ let CheckTypeInstNoInnerByrefs cenv env m tyargs = tyargs |> List.iter (CheckTypeNoInnerByrefs cenv env m) /// Applied functions get wrapped in coerce nodes for subsumption coercions -let (|OptionalCoerce|) expr = +let (|OptionalCoerce|) expr = match stripDebugPoints expr with - | Expr.Op (TOp.Coerce, _, [DebugPoints(Expr.App (f, _, _, [], _), _)], _) -> f + | Expr.Op (TOp.Coerce, _, [DebugPoints(Expr.App (f, _, _, [], _), _)], _) -> f | _ -> expr /// Check an expression doesn't contain a 'reraise' -let CheckNoReraise cenv freesOpt (body: Expr) = +let CheckNoReraise cenv freesOpt (body: Expr) = if cenv.reportErrors then - // Avoid recomputing the free variables + // Avoid recomputing the free variables let fvs = match freesOpt with None -> freeInExpr CollectLocals body | Some fvs -> fvs if fvs.UsesUnboundRethrow then errorR(Error(FSComp.SR.chkErrorContainsCallToRethrow(), body.Range)) /// Check if a function is a quotation splice operator -let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.splice_raw_expr_vref +let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.splice_raw_expr_vref /// Examples: @@ -722,11 +752,11 @@ type TTypeEquality = | NotEqual let compareTypesWithRegardToTypeVariablesAndMeasures g amap m ty1 ty2 = - + if (typeEquiv g ty1 ty2) then ExactlyEqual else - if (typeEquiv g ty1 ty2 || TypesFeasiblyEquivStripMeasures g amap m ty1 ty2) then + if (typeEquiv g ty1 ty2 || TypesFeasiblyEquivStripMeasures g amap m ty1 ty2) then FeasiblyEqual else NotEqual @@ -773,9 +803,9 @@ let rec CheckExprNoByrefs cenv env expr = CheckExpr cenv env expr PermitByRefExpr.No |> ignore /// Check a value -and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = +and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = - if cenv.reportErrors then + if cenv.reportErrors then if isSpliceOperator cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)) if isSpliceOperator cenv.g v then errorR(Error(FSComp.SR.chkNoFirstClassSplicing(), m)) if valRefEq cenv.g v cenv.g.addrof_vref then errorR(Error(FSComp.SR.chkNoFirstClassAddressOf(), m)) @@ -787,40 +817,43 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = if valRefEq cenv.g v cenv.g.refcell_incr_vref then informationalWarning(Error(FSComp.SR.chkInfoRefcellIncr(), m)) if valRefEq cenv.g v cenv.g.refcell_decr_vref then informationalWarning(Error(FSComp.SR.chkInfoRefcellDecr(), m)) - // ByRefLike-typed values can only occur in permitting ctxts - if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then + // ByRefLike-typed values can only occur in permitting ctxts + if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) + if env.mustTailCall.Contains v.Deref && cenv.isTailCall = IsTailCall.No then + warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) + if env.isInAppExpr then CheckTypePermitAllByrefs cenv env m v.Type // we do checks for byrefs elsewhere else 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) = + let g = cenv.g let limit = GetLimitVal cenv env m vref.Deref - if cenv.reportErrors then + if cenv.reportErrors then - if vref.IsBaseVal then + if vref.IsBaseVal then errorR(Error(FSComp.SR.chkLimitationsOfBaseKeyword(), m)) - let isCallOfConstructorOfAbstractType = - (match vFlags with NormalValUse -> true | _ -> false) && - vref.IsConstructor && + let isCallOfConstructorOfAbstractType = + (match vFlags with NormalValUse -> true | _ -> false) && + vref.IsConstructor && (match vref.TryDeclaringEntity with Parent tcref -> isAbstractTycon tcref.Deref | _ -> false) - if isCallOfConstructorOfAbstractType then + if isCallOfConstructorOfAbstractType then errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(), m)) // This is used to handle this case: // let x = 1 // let y = &x // &y - let isReturnExprBuiltUsingStackReferringByRefLike = + let isReturnExprBuiltUsingStackReferringByRefLike = ctxt.PermitOnlyReturnable && ((HasLimitFlag LimitFlags.ByRef limit && IsLimitEscapingScope env ctxt limit) || HasLimitFlag LimitFlags.StackReferringSpanLike limit) @@ -833,9 +866,9 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB | true, false -> errorR(Error(FSComp.SR.chkNoSpanLikeVariable(vref.DisplayName), m)) | false, true -> errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) | false, false -> errorR(Error(FSComp.SR.chkNoByrefAddressOfLocal(vref.DisplayName), m)) - - let isReturnOfStructThis = - ctxt.PermitOnlyReturnable && + + let isReturnOfStructThis = + ctxt.PermitOnlyReturnable && isByrefTy g vref.Type && (vref.IsMemberThisVal) @@ -845,9 +878,9 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB CheckValRef cenv env vref m ctxt limit - + /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -861,12 +894,12 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = // Special diagnostics for `raise`, `failwith`, `failwithf`, `nullArg`, `invalidOp` library intrinsics commonly used to raise exceptions // to warn on over-application. match f with - | OptionalCoerce(Expr.Val (v, _, funcRange)) + | OptionalCoerce(Expr.Val (v, _, funcRange)) when (valRefEq g v g.raise_vref || valRefEq g v g.failwith_vref || valRefEq g v g.null_arg_vref || valRefEq g v g.invalid_op_vref) -> match argsl with | [] | [_] -> () | _ :: _ :: _ -> - warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(v.DisplayName, 1, argsl.Length), funcRange)) + warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(v.DisplayName, 1, argsl.Length), funcRange)) | OptionalCoerce(Expr.Val (v, _, funcRange)) when valRefEq g v g.invalid_arg_vref -> match argsl with @@ -886,6 +919,48 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = | None -> () | _ -> () | _ -> () + + match f with + | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> + + let canTailCall = + match cenv.isTailCall with + | IsTailCall.No -> false + | IsTailCall.Yes isVoidRet -> + if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then + + let topValInfo = vref.ValReprInfo.Value + let (nowArgs, laterArgs), returnTy = + let _tps, tau = destTopForallTy g topValInfo _fty + let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m + (List.splitAfter curriedArgInfos.Length argsl), returnTy + let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) + let isCCall = + match valUseFlags with + | PossibleConstrainedCall _ -> true + | _ -> false + + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) + let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + + else + true + + if not canTailCall then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)); + + CheckExprNoByrefs { cenv with isTailCall = (IsTailCall.Yes true) } env f + + | _ -> + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env f | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = @@ -893,14 +968,14 @@ and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = let isReturnSpanLike = isSpanLikeTy cenv.g m returnTy // If return is a byref, and being used as a return, then a single argument cannot be a local-byref or a stack referring span-like. - let isReturnLimitedByRef = - isReturnByref && - (HasLimitFlag LimitFlags.ByRef limitArgs || + let isReturnLimitedByRef = + isReturnByref && + (HasLimitFlag LimitFlags.ByRef limitArgs || HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs) // If return is a byref, and being used as a return, then a single argument cannot be a stack referring span-like or a local-byref of a stack referring span-like. - let isReturnLimitedSpanLike = - isReturnSpanLike && + let isReturnLimitedSpanLike = + isReturnSpanLike && (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs) @@ -911,11 +986,11 @@ and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = else errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) - // You cannot call a function that takes a byref of a span-like (not stack referring) and + // You cannot call a function that takes a byref of a span-like (not stack referring) and // either a stack referring span-like or a local-byref of a stack referring span-like. - let isCallLimited = - HasLimitFlag LimitFlags.ByRefOfSpanLike limitArgs && - (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || + let isCallLimited = + HasLimitFlag LimitFlags.ByRefOfSpanLike limitArgs && + (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs) if isCallLimited then @@ -965,7 +1040,7 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = | ctxt :: ctxts -> ctxt, ctxts let receiverLimit = CheckExpr cenv env receiverArg receiverContext - let limitArgs = + let limitArgs = let limitArgs = CheckExprs cenv env args ctxts // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike receiverLimit then @@ -975,9 +1050,9 @@ 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) = match expr with - | Expr.Sequential (e1, e2, NormalSeq, _) -> + | Expr.Sequential (e1, e2, NormalSeq, _) -> CheckExprNoByrefs cenv env e1 // tailcall CheckExprLinear cenv env e2 ctxt contf @@ -991,35 +1066,35 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf else PermitByRefExpr.Yes - let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind + let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind 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 | LinearOpExpr (_op, tyargs, argsHead, argLast, m) -> CheckTypeInstNoByrefs cenv env m tyargs - argsHead |> List.iter (CheckExprNoByrefs cenv env) + argsHead |> List.iter (CheckExprNoByrefs cenv env) // tailcall CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, m, ty) -> - CheckTypeNoInnerByrefs cenv env m ty + CheckTypeNoInnerByrefs cenv env m ty CheckDecisionTree cenv env dtree let lim1 = CheckDecisionTreeTarget cenv env ctxt tg1 // tailcall CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) - | Expr.DebugPoint (_, innerExpr) -> + | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt contf - | _ -> + | _ -> // not a linear expression contf (CheckExpr cenv env expr ctxt) /// 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 : bool = let g = cenv.g match env.resumableCode with @@ -1029,14 +1104,14 @@ 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 } thenExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } 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 noneBranchExpr BindVal cenv env someVar CheckExprNoByrefs cenv env someBranchExpr true @@ -1083,7 +1158,7 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = 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) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree @@ -1096,97 +1171,97 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = BindVal cenv env bind.Var CheckExprNoByrefs cenv env 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 -> + | Expr.LetRec(_bindings, bodyExpr, _range, _frees) when allowed -> errorR(Error(FSComp.SR.tcResumableCodeContainsLetRec(), expr.Range)) CheckExprNoByrefs cenv env bodyExpr true // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match - | Expr.Const (Const.Zero, _, _) -> + | Expr.Const (Const.Zero, _, _) -> true - | Expr.DebugPoint (_, innerExpr) -> + | Expr.DebugPoint (_, innerExpr) -> TryCheckResumableCodeConstructs cenv env innerExpr | _ -> 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) : Limit = + // 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 - CheckForOverAppliedExceptionRaisingPrimitive cenv origExpr + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr match TryCheckResumableCodeConstructs cenv env expr with - | true -> + | true -> // we've handled the special cases of resumable code and don't do other checks. - NoLimit - | false -> + NoLimit + | false -> // Handle ResumableExpr --> other expression let env = { env with resumableCode = Resumable.None } match expr with - | LinearOpExpr _ - | LinearMatchExpr _ - | Expr.Let _ + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) - | Expr.DebugPoint _ -> + | Expr.DebugPoint _ -> CheckExprLinear cenv env expr ctxt id - | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs cenv env e1 - CheckExprNoByrefs cenv env e2 + | Expr.Sequential (e1, e2, ThenDoSeq, _) -> + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e1 + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 NoLimit - | Expr.Const (_, m, ty) -> - CheckTypeNoInnerByrefs cenv env m ty + | Expr.Const (_, m, ty) -> + CheckTypeNoInnerByrefs cenv env m ty NoLimit - - | Expr.Val (vref, vFlags, m) -> + + | Expr.Val (vref, vFlags, m) -> CheckValUse cenv env (vref, vFlags, m) ctxt - - | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> + + | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> CheckQuoteExpr cenv env (ast, savedConv, m, ty) | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv env expr info - | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) + | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> + CheckObjectExpr { cenv with isTailCall = IsTailCall.No } env (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods - | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) - when ((match vFlags with VSlotDirectCall -> true | _ -> false) && + | 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 env expr (v, f, _fty, tyargs, baseVal, rest, m) // Allow base calls to IL methods - | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), tyargs, Expr.Val (baseVal, _, _) :: rest, m) + | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), tyargs, Expr.Val (baseVal, _, _) :: rest, m) when not isVirtual && baseVal.IsBaseVal -> - + CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv env (op, tyargs, args, m) ctxt expr - // Allow 'typeof' calls as a special case, the only accepted use of System.Void! + // Allow 'typeof' calls as a special case, the only accepted use of System.Void! | TypeOfExpr g ty when isVoidTy g ty -> NoLimit - // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! + // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! | TypeDefOfExpr g ty when isVoidTy g ty -> NoLimit @@ -1198,65 +1273,65 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt - | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv env expr (argvs, m, bodyTy) - | Expr.TyLambda (_, tps, _, m, bodyTy) -> + | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) - | Expr.TyChoose (tps, e1, _) -> - let env = BindTypars g env tps - CheckExprNoByrefs cenv env e1 + | Expr.TyChoose (tps, e1, _) -> + let env = BindTypars g env tps + CheckExprNoByrefs cenv env e1 NoLimit - | Expr.Match (_, _, dtree, targets, m, ty) -> + | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) - | Expr.LetRec (binds, bodyExpr, _, _) -> + | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv env (binds, bodyExpr) - | Expr.StaticOptimization (constraints, e2, e3, m) -> + | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) | Expr.WitnessArg _ -> NoLimit - | Expr.Link _ -> + | Expr.Link _ -> failwith "Unexpected reclink" and CheckQuoteExpr cenv env (ast, savedConv, m, ty) = let g = cenv.g CheckExprNoByrefs cenv {env with quote=true} ast - if cenv.reportErrors then + if cenv.reportErrors then cenv.usesQuotations <- true // Translate the quotation to quotation data - try - let doData suppressWitnesses = - let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.No) - let qdata = QuotationTranslator.ConvExprPublic qscope suppressWitnesses ast + try + let doData suppressWitnesses = + let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.No) + let qdata = QuotationTranslator.ConvExprPublic qscope suppressWitnesses ast let typeDefs, spliceTypes, spliceExprs = qscope.Close() typeDefs, List.map fst spliceTypes, List.map fst spliceExprs, qdata let data1 = doData true let data2 = doData false - match savedConv.Value with + match savedConv.Value with | None -> savedConv.Value <- Some (data1, data2) | Some _ -> () - with QuotationTranslator.InvalidQuotedTerm e -> + with QuotationTranslator.InvalidQuotedTerm e -> errorRecovery e m - + CheckTypeNoByrefs cenv env m ty NoLimit and CheckStructStateMachineExpr cenv env expr info = let g = cenv.g - let (_dataTy, - (moveNextThisVar, moveNextExpr), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), + let (_dataTy, + (moveNextThisVar, moveNextExpr), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), (afterCodeThisVar, afterCodeBody)) = info if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then @@ -1275,8 +1350,8 @@ and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) = CheckInterfaceImpls cenv env basev iimpls CheckTypeNoByrefs cenv env m ty - let interfaces = - [ if isInterfaceTy g ty then + let interfaces = + [ if isInterfaceTy g ty then yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty for ty, _ in iimpls do yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty ] @@ -1291,7 +1366,7 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = if memberInfo.MemberFlags.IsDispatchSlot then errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName), m)) NoLimit - else + else let env = { env with isInAppExpr = true } let returnTy = tyOfExpr g expr @@ -1301,9 +1376,9 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = CheckTypeNoInnerByrefs cenv env m returnTy CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) -and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = +and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = let g = cenv.g - // Disallow calls to abstract base methods on IL types. + // Disallow calls to abstract base methods on IL types. match tryTcrefOfAppTy g baseVal.Type with | ValueSome tcref when tcref.IsILTycon -> try @@ -1324,14 +1399,14 @@ and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyarg CheckValRef cenv env baseVal m PermitByRefExpr.No CheckExprsPermitByRefLike cenv env rest -and CheckSpliceApplication cenv env (tinst, arg, m) = +and CheckSpliceApplication cenv env (tinst, arg, m) = CheckTypeInstNoInnerByrefs cenv env m tinst // it's the splice operator, a byref instantiation is allowed - CheckExprNoByrefs cenv env arg + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env arg NoLimit -and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = +and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = let g = cenv.g - match expr with + match expr with | ResumableCodeInvoke g _ -> warning(Error(FSComp.SR.tcResumableCodeInvocation(), m)) | _ -> () @@ -1358,43 +1433,43 @@ 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) = - 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 +and CheckLambda cenv env expr (argvs, m, bodyTy) = + let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) + let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in + CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) = - let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - let ty = mkForallTyIfNeeded tps bodyTy in - CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes +and CheckTyLambda cenv env expr (tps, m, bodyTy) = + let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) + let ty = mkForallTyIfNeeded tps bodyTy in + CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, m, ty) = +and CheckMatch cenv env ctxt (dtree, targets, m, ty) = CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch CheckDecisionTree cenv env dtree CheckDecisionTreeTargets cenv env targets ctxt -and CheckLetRec cenv env (binds, bodyExpr) = +and CheckLetRec cenv env (binds, bodyExpr) = BindVals cenv env (valsOfBinds binds) CheckBindings cenv env binds CheckExprNoByrefs cenv env bodyExpr NoLimit -and CheckStaticOptimization cenv env (constraints, e2, e3, m) = - CheckExprNoByrefs cenv env e2 - CheckExprNoByrefs cenv env e3 +and CheckStaticOptimization cenv env (constraints, e2, e3, m) = + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e3 constraints |> List.iter (function - | TTyconEqualsTycon(ty1, ty2) -> + | TTyconEqualsTycon(ty1, ty2) -> CheckTypeNoByrefs cenv env m ty1 CheckTypeNoByrefs cenv env m ty2 - | TTyconIsStruct ty1 -> + | TTyconIsStruct ty1 -> CheckTypeNoByrefs cenv env m ty1) NoLimit -and CheckMethods cenv env baseValOpt (ty, methods) = - methods |> List.iter (CheckMethod cenv env baseValOpt ty) +and CheckMethods cenv env baseValOpt (ty, methods) = + methods |> List.iter (CheckMethod cenv env baseValOpt ty) -and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, body, m)) = - let env = BindTypars cenv.g env tps +and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, body, m)) = + let env = BindTypars cenv.g env tps let vs = List.concat vs let env = BindArgVals env vs let env = @@ -1410,18 +1485,18 @@ and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, 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 -and CheckInterfaceImpls cenv env baseValOpt l = +and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) - -and CheckInterfaceImpl cenv env baseValOpt overrides = - CheckMethods cenv env baseValOpt overrides + +and CheckInterfaceImpl cenv env baseValOpt overrides = + CheckMethods cenv env baseValOpt overrides and CheckNoResumableStmtConstructs cenv _env expr = let g = cenv.g - match expr with - | Expr.Val (v, _, m) - when valRefEq g v g.cgh__resumeAt_vref || - valRefEq g v g.cgh__resumableEntry_vref || + match expr with + | Expr.Val (v, _, m) + when valRefEq g v g.cgh__resumeAt_vref || + valRefEq g v g.cgh__resumableEntry_vref || valRefEq g v g.cgh__stateMachine_vref -> errorR(Error(FSComp.SR.tcInvalidResumableConstruct(v.DisplayName), m)) | _ -> () @@ -1431,22 +1506,22 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // Ensure anonymous record type requirements are recorded match op with - | TOp.AnonRecdGet (anonInfo, _) - | TOp.AnonRecd anonInfo -> + | TOp.AnonRecdGet (anonInfo, _) + | TOp.AnonRecd anonInfo -> RecordAnonRecdInfo cenv anonInfo | _ -> () // Special cases - match op, tyargs, args with - // Handle these as special cases since mutables are allowed inside their bodies + 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, _, _)] -> - CheckTypeInstNoByrefs cenv env m tyargs + CheckTypeInstNoByrefs cenv env m tyargs CheckExprsNoByRefLike cenv env [e1;e2] | 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 + CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/finally can be a byref + let limit = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/finally can be a byref if in a position where the overall expression is can be a byref + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 limit | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> @@ -1454,19 +1529,19 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckExprsNoByRefLike cenv env [e1;e2;e3] | 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 + CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/catch can be a byref + let limit1 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref // [(* e2; -- don't check filter body - duplicates logic in 'catch' body *) e3] - let limit2 = CheckExpr cenv env e3 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit2 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e3 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref CombineTwoLimits limit1 limit2 - + | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), _, _ -> CheckTypeInstNoByrefs cenv env m tyargs CheckTypeInstNoByrefs cenv env m enclTypeInst CheckTypeInstNoByrefs cenv env m methInst CheckTypeInstNoInnerByrefs cenv env m retTypes // permit byref returns - let hasReceiver = + let hasReceiver = (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) && not args.IsEmpty @@ -1475,46 +1550,46 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = let argContexts = List.init args.Length (fun _ -> PermitByRefExpr.Yes) match retTypes with - | [ty] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> + | [ty] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts ctxt else CheckCall cenv env m returnTy args argContexts ctxt - | _ -> + | _ -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes else CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes - | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> - match ctxt with - | PermitByRefExpr.YesTupleOfArgs nArity -> - if cenv.reportErrors then - if args.Length <> nArity then + | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> + match ctxt with + | PermitByRefExpr.YesTupleOfArgs nArity -> + if cenv.reportErrors then + if args.Length <> nArity then errorR(InternalError("Tuple arity does not correspond to planned function argument arity", m)) - // This tuple should not be generated. The known function arity - // means it just bundles arguments. - CheckExprsPermitByRefLike cenv env args - | _ -> + // This tuple should not be generated. The known function arity + // means it just bundles arguments. + CheckExprsPermitByRefLike cenv env args + | _ -> CheckTypeInstNoByrefs cenv env m tyargs - CheckExprsNoByRefLike cenv env args + CheckExprsNoByRefLike cenv env args - | TOp.LValueOp (LAddrOf _, vref), _, _ -> + | TOp.LValueOp (LAddrOf _, vref), _, _ -> let limit1 = GetLimitValByRef cenv env m vref.Deref let limit2 = CheckExprsNoByRefLike cenv env args let limit = CombineTwoLimits limit1 limit2 - if cenv.reportErrors then + if cenv.reportErrors then - if ctxt.Disallow then + if ctxt.Disallow then errorR(Error(FSComp.SR.chkNoAddressOfAtThisPoint(vref.DisplayName), m)) - - let returningAddrOfLocal = - ctxt.PermitOnlyReturnable && + + let returningAddrOfLocal = + ctxt.PermitOnlyReturnable && HasLimitFlag LimitFlags.ByRef limit && IsLimitEscapingScope env ctxt limit - - if returningAddrOfLocal then + + if returningAddrOfLocal then if vref.IsCompilerGenerated then errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) else @@ -1522,15 +1597,15 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = limit - | TOp.LValueOp (LByrefSet, vref), _, [arg] -> + | TOp.LValueOp (LByrefSet, vref), _, [arg] -> let limit = GetLimitVal cenv env m vref.Deref let isVrefLimited = not (HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit) let isArgLimited = HasLimitFlag LimitFlags.StackReferringSpanLike (CheckExprPermitByRefLike cenv env arg) - if isVrefLimited && isArgLimited then + if isVrefLimited && isArgLimited then errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(vref.DisplayName), m)) NoLimit - | TOp.LValueOp (LByrefGet, vref), _, [] -> + | TOp.LValueOp (LByrefGet, vref), _, [] -> let limit = GetLimitVal cenv env m vref.Deref if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then @@ -1546,27 +1621,27 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = else { scope = 1; flags = LimitFlags.None } - | TOp.LValueOp (LSet, vref), _, [arg] -> + | TOp.LValueOp (LSet, vref), _, [arg] -> let isVrefLimited = not (HasLimitFlag LimitFlags.StackReferringSpanLike (GetLimitVal cenv env m vref.Deref)) let isArgLimited = HasLimitFlag LimitFlags.StackReferringSpanLike (CheckExprPermitByRefLike cenv env arg) - if isVrefLimited && isArgLimited then + if isVrefLimited && isArgLimited then errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(vref.DisplayName), m)) NoLimit | TOp.AnonRecdGet _, _, [arg1] - | TOp.TupleFieldGet _, _, [arg1] -> + | TOp.TupleFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprsPermitByRefLike cenv env [arg1] - | TOp.ValFieldGet _rf, _, [arg1] -> + | TOp.ValFieldGet _rf, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs - //See mkRecdFieldGetViaExprAddr -- byref arg1 when #args =1 - // Property getters on mutable structs come through here. - CheckExprsPermitByRefLike cenv env [arg1] + //See mkRecdFieldGetViaExprAddr -- byref arg1 when #args =1 + // Property getters on mutable structs come through here. + CheckExprsPermitByRefLike cenv env [arg1] - | TOp.ValFieldSet rf, _, [arg1;arg2] -> + | TOp.ValFieldSet rf, _, [arg1;arg2] -> CheckTypeInstNoByrefs cenv env m tyargs - // See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 + // See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 // Field setters on mutable structs come through here let limit1 = CheckExprPermitByRefLike cenv env arg1 let limit2 = CheckExprPermitByRefLike cenv env arg2 @@ -1579,10 +1654,10 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.Coerce, [tgtTy;srcTy], [x] -> if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt + CheckExpr { cenv with isTailCall = IsTailCall.No } env x ctxt else - CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env x + CheckTypeInstNoByrefs { cenv with isTailCall = IsTailCall.No } env m tyargs + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -1591,9 +1666,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // Check get of static field | TOp.ValFieldGetAddr (rfref, _readonly), tyargs, [] -> - + if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)) + errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)) CheckTypeInstNoByrefs cenv env m tyargs NoLimit @@ -1606,24 +1681,24 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // C# applies a rule where the APIs to struct types can't return the addresses of fields in that struct. // There seems no particular reason for this given that other protections in the language, though allowing - // it would mean "readonly" on a struct doesn't imply immutability-of-contents - it only implies + // it would mean "readonly" on a struct doesn't imply immutability-of-contents - it only implies if ctxt.PermitOnlyReturnable && (match stripDebugPoints obj with Expr.Val (vref, _, _) -> vref.IsMemberThisVal | _ -> false) && isByrefTy g (tyOfExpr g obj) then errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)) - // This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. + // This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. 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 - | TOp.UnionCaseFieldGet _, _, [arg1] -> + | TOp.UnionCaseFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprPermitByRefLike cenv env arg1 - | TOp.UnionCaseTagGet _, _, [arg1] -> + | TOp.UnionCaseTagGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprPermitByRefLike cenv env arg1 // allow byref - it may be address-of-struct @@ -1646,18 +1721,22 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = match instrs, args with // Write a .NET instance field | [ I_stfld (_alignment, _vol, _fspec) ], _ -> - // permit byref for lhs lvalue + match args with + | [ _; rhs ] -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env rhs + | _ -> () + + // permit byref for lhs lvalue // permit byref for rhs lvalue (field would have to have ByRefLike type, i.e. be a field in another ByRefLike type) CheckExprsPermitByRefLike cenv env args // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec) ], _ -> - // permit byref for lhs lvalue + // permit byref for lhs lvalue CheckExprsPermitByRefLike cenv env args // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec); AI_nop ], _ -> - // permit byref for lhs lvalue of readonly value + // permit byref for lhs lvalue of readonly value CheckExprsPermitByRefLike cenv env args | [ I_ldsflda fspec ], [] -> @@ -1676,56 +1755,56 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | [ I_ldelema (_, isNativePtr, _, _) ], lhsArray :: indices -> if ctxt.Disallow && cenv.reportErrors && not isNativePtr && isByrefLikeTy g m (tyOfExpr g expr) then errorR(Error(FSComp.SR.chkNoAddressOfArrayElementAtThisPoint(), m)) - // permit byref for lhs lvalue + // permit byref for lhs lvalue let limit = CheckExprPermitByRefLike cenv env lhsArray CheckExprsNoByRefLike cenv env indices |> ignore limit | [ AI_conv _ ], _ -> - // permit byref for args to conv - CheckExprsPermitByRefLike cenv env args + // permit byref for args to conv + CheckExprsPermitByRefLike cenv env args | _ -> - CheckExprsNoByRefLike cenv env args + CheckExprsNoByRefLike cenv env args | TOp.TraitCall _, _, _ -> CheckTypeInstNoByrefs cenv env m tyargs - // allow args to be byref here + // allow args to be byref here CheckExprsPermitByRefLike cenv env args - + | TOp.Recd _, _, _ -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprsPermitByRefLike cenv env args - | _ -> + | _ -> CheckTypeInstNoByrefs cenv env m tyargs - CheckExprsNoByRefLike cenv env args + CheckExprsNoByRefLike cenv env args and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwaysCheckNoReraise expr mOrig ety ctxt = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) - // The valReprInfo here says we are _guaranteeing_ to compile a function value - // as a .NET method with precisely the corresponding argument counts. + // 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) -> + | Expr.TyChoose (tps, e1, m) -> let env = BindTypars g env tps CheckLambdas isTop memberVal cenv env inlined valReprInfo alwaysCheckNoReraise e1 m ety ctxt - | Expr.Lambda (_, _, _, _, _, m, _) + | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) - let env = BindTypars g env tps + let env = BindTypars g env tps let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt let restArgs = List.concat vsl let syntacticArgs = thisAndBase @ restArgs let env = BindArgVals env restArgs - match memInfo with + match memInfo with | None -> () - | Some mi -> + | Some mi -> // ctorThis and baseVal values are always considered used - for v in thisAndBase do v.SetHasBeenReferenced() + for v in thisAndBase do v.SetHasBeenReferenced() // instance method 'this' is always considered used match mi.MemberFlags.IsInstance, restArgs with | true, firstArg :: _ -> firstArg.SetHasBeenReferenced() @@ -1743,10 +1822,10 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa // Check argument types for arg in syntacticArgs do - if arg.InlineIfLambda && (not inlined || not (isFunTy g arg.Type || isFSharpDelegateTy g arg.Type)) then + if arg.InlineIfLambda && (not inlined || not (isFunTy g arg.Type || isFSharpDelegateTy g arg.Type)) then errorR(Error(FSComp.SR.tcInlineIfLambdaUsedOnNonInlineFunctionOrMethod(), arg.Range)) - CheckValSpecAux permitByRefType cenv env arg (fun () -> + CheckValSpecAux permitByRefType cenv env arg (fun () -> if arg.IsCompilerGenerated then errorR(Error(FSComp.SR.chkErrorUseOfByref(), arg.Range)) else @@ -1765,7 +1844,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa let freesOpt = CheckEscapes cenv memInfo.IsSome m syntacticArgs body // no reraise under lambda expression - CheckNoReraise cenv freesOpt body + CheckNoReraise cenv freesOpt body // Check the body of the lambda if isTop && not g.compilingFSharpCore && isByrefLikeTy g m bodyTy then @@ -1775,83 +1854,83 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa CheckExprNoByrefs cenv env body // Check byref return types - if cenv.reportErrors then + if cenv.reportErrors then if not isTop then - CheckForByrefLikeType cenv env m bodyTy (fun () -> + CheckForByrefLikeType cenv env m bodyTy (fun () -> errorR(Error(FSComp.SR.chkFirstClassFuncNoByref(), m))) - elif not g.compilingFSharpCore && isByrefTy g bodyTy then + elif not g.compilingFSharpCore && isByrefTy g bodyTy then // check no byrefs-in-the-byref - CheckForByrefType cenv env (destByrefTy g bodyTy) (fun () -> + CheckForByrefType cenv env (destByrefTy g bodyTy) (fun () -> errorR(Error(FSComp.SR.chkReturnTypeNoByref(), m))) - for tp in tps do - if tp.Constraints |> List.sumBy (function TyparConstraint.CoercesTo(ty, _) when isClassTy g ty -> 1 | _ -> 0) > 1 then + for tp in tps do + if tp.Constraints |> List.sumBy (function TyparConstraint.CoercesTo(ty, _) when isClassTy g ty -> 1 | _ -> 0) > 1 then errorR(Error(FSComp.SR.chkTyparMultipleClassConstraints(), m)) NoLimit - + // This path is for expression bindings that are not actually lambdas - | _ -> + | _ -> let m = mOrig // Permit byrefs for let x = ... CheckTypeNoInnerByrefs cenv env m ety - let limit = + let limit = if not inlined && (isByrefLikeTy g m ety || isNativePtrTy g ety) then - // allow byref to occur as RHS of byref binding. + // allow byref to occur as RHS of byref binding. CheckExpr cenv env expr ctxt - else + else CheckExprNoByrefs cenv env expr NoLimit - if alwaysCheckNoReraise then + if alwaysCheckNoReraise then CheckNoReraise cenv None expr limit and CheckExprs cenv env exprs ctxts : Limit = - let ctxts = Array.ofList ctxts - let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No - exprs - |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i)) + let ctxts = Array.ofList ctxts + let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No + exprs + |> List.mapi (fun i exp -> CheckExpr { cenv with isTailCall = IsTailCall.No } env exp (argArity i)) |> CombineLimits -and CheckExprsNoByRefLike cenv env exprs : Limit = +and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do - CheckExprNoByrefs cenv env expr + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr NoLimit -and CheckExprsPermitByRefLike cenv env exprs : Limit = - exprs +and CheckExprsPermitByRefLike cenv env exprs : Limit = + exprs |> List.map (CheckExprPermitByRefLike cenv env) |> CombineLimits -and CheckExprPermitByRefLike cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.Yes +and CheckExprPermitByRefLike cenv env expr : Limit = + CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.Yes -and CheckExprPermitReturnableByRef cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.YesReturnable +and CheckExprPermitReturnableByRef cenv env expr : Limit = + CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.YesReturnable -and CheckDecisionTreeTargets cenv env targets ctxt = - targets - |> Array.map (CheckDecisionTreeTarget cenv env ctxt) +and CheckDecisionTreeTargets cenv env targets ctxt = + targets + |> Array.map (CheckDecisionTreeTarget cenv env ctxt) |> List.ofArray |> CombineLimits -and CheckDecisionTreeTarget cenv env ctxt (TTarget(vs, targetExpr, _)) = - BindVals cenv env vs +and CheckDecisionTreeTarget cenv env 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 and CheckDecisionTree cenv env dtree = - match dtree with - | TDSuccess (resultExprs, _) -> + match dtree with + | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv env resultExprs |> ignore - | TDBind(bind, rest) -> + | TDBind(bind, rest) -> CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore - CheckDecisionTree cenv env rest - | TDSwitch (inpExpr, cases, dflt, m) -> + CheckDecisionTree cenv env rest + | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = @@ -1859,7 +1938,7 @@ and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = for (TCase(discrim, dtree)) in cases do CheckDecisionTreeTest cenv env m discrim CheckDecisionTree cenv env dtree - dflt |> Option.iter (CheckDecisionTree cenv env) + dflt |> Option.iter (CheckDecisionTree cenv env) and CheckDecisionTreeTest cenv env m discrim = match discrim with @@ -1868,7 +1947,7 @@ and CheckDecisionTreeTest cenv env m discrim = | DecisionTreeTest.Const _ -> () | DecisionTreeTest.IsNull -> () | DecisionTreeTest.IsInst (srcTy, tgtTy) -> CheckTypeNoInnerByrefs cenv env m srcTy; CheckTypeNoInnerByrefs cenv env m tgtTy - | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env exp | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = @@ -1877,25 +1956,25 @@ and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = props |> List.iter (fun (AttribNamedArg(_, _, _, expr)) -> CheckAttribExpr cenv env expr) args |> List.iter (CheckAttribExpr cenv env) -and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = - CheckExprNoByrefs cenv env expr - CheckExprNoByrefs cenv env vexpr - CheckNoReraise cenv None expr +and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env vexpr + CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr -and CheckAttribArgExpr cenv env expr = +and CheckAttribArgExpr cenv env expr = let g = cenv.g - match expr with + match expr with - // Detect standard constants - | Expr.Const (c, m, _) -> - match c with - | Const.Bool _ - | Const.Int32 _ + // Detect standard constants + | Expr.Const (c, m, _) -> + match c with + | Const.Bool _ + | Const.Int32 _ | Const.SByte _ | Const.Int16 _ | Const.Int32 _ - | Const.Int64 _ + | Const.Int64 _ | Const.Byte _ | Const.UInt16 _ | Const.UInt32 _ @@ -1905,56 +1984,56 @@ and CheckAttribArgExpr cenv env expr = | Const.Char _ | Const.Zero | Const.String _ -> () - | _ -> - if cenv.reportErrors then + | _ -> + if cenv.reportErrors then errorR (Error (FSComp.SR.tastNotAConstantExpression(), m)) - - | Expr.Op (TOp.Array, [_elemTy], args, _m) -> + + | Expr.Op (TOp.Array, [_elemTy], args, _m) -> List.iter (CheckAttribArgExpr cenv env) args - | TypeOfExpr g _ -> + | TypeOfExpr g _ -> () - | TypeDefOfExpr g _ -> + | TypeDefOfExpr g _ -> () - | Expr.Op (TOp.Coerce, _, [arg], _) -> + | Expr.Op (TOp.Coerce, _, [arg], _) -> CheckAttribArgExpr cenv env arg - | EnumExpr g arg1 -> + | EnumExpr g arg1 -> CheckAttribArgExpr cenv env arg1 | AttribBitwiseOrExpr g (arg1, arg2) -> CheckAttribArgExpr cenv env arg1 CheckAttribArgExpr cenv env arg2 - | _ -> - if cenv.reportErrors then + | _ -> + if cenv.reportErrors then errorR (Error (FSComp.SR.chkInvalidCustAttrVal(), expr.Range)) - -and CheckAttribs cenv env (attribs: Attribs) = + +and CheckAttribs cenv env (attribs: Attribs) = if isNil attribs then () else let tcrefs = [ for Attrib(tcref, _, _, _, gs, _, m) in attribs -> (tcref, gs, m) ] // Check for violations of allowMultiple = false - let duplicates = + let duplicates = tcrefs |> Seq.groupBy (fun (tcref, gs, _) -> // Don't allow CompiledNameAttribute on both a property and its getter/setter (see E_CompiledName test) if tyconRefEq cenv.g cenv.g.attrib_CompiledNameAttribute.TyconRef tcref then (tcref.Stamp, false) else - (tcref.Stamp, gs)) - |> Seq.map (fun (_, elems) -> List.last (List.ofSeq elems), Seq.length elems) - |> Seq.filter (fun (_, count) -> count > 1) - |> Seq.map fst + (tcref.Stamp, gs)) + |> Seq.map (fun (_, elems) -> List.last (List.ofSeq elems), Seq.length elems) + |> Seq.filter (fun (_, count) -> count > 1) + |> Seq.map fst |> Seq.toList // Filter for allowMultiple = false |> List.filter (fun (tcref, _, m) -> TryFindAttributeUsageAttribute cenv.g m tcref <> Some true) - if cenv.reportErrors then + if cenv.reportErrors then for tcref, _, m in duplicates do errorR(Error(FSComp.SR.chkAttrHasAllowMultiFalse(tcref.DisplayName), m)) - - attribs |> List.iter (CheckAttrib cenv env) + + attribs |> List.iter (CheckAttrib cenv env) and CheckValInfo cenv env (ValReprInfo(_, args, ret)) = args |> List.iterSquared (CheckArgInfo cenv env) ret |> CheckArgInfo cenv env -and CheckArgInfo cenv env (argInfo : ArgReprInfo) = +and CheckArgInfo cenv env (argInfo : ArgReprInfo) = CheckAttribs cenv env argInfo.Attribs and CheckValSpecAux permitByRefLike cenv env (v: Val) onInnerByrefError = @@ -1966,12 +2045,12 @@ and CheckValSpec permitByRefLike cenv env v = CheckValSpecAux permitByRefLike cenv env v (fun () -> errorR(Error(FSComp.SR.chkErrorUseOfByref(), v.Range))) and AdjustAccess isHidden (cpath: unit -> CompilationPath) access = - if isHidden then + if isHidden then let (TAccess l) = access // FSharp 1.0 bug 1908: Values hidden by signatures are implicitly at least 'internal' let scoref = cpath().ILScopeRef TAccess(CompPath(scoref, []) :: l) - else + else access and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : Limit = @@ -1983,14 +2062,14 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin let env = { env with external = env.external || g.attrib_DllImportAttribute |> Option.exists (fun attr -> HasFSharpAttribute g attr v.Attribs) } // Check that active patterns don't have free type variables in their result - match TryGetActivePatternInfo vref with - | Some _apinfo when _apinfo.ActiveTags.Length > 1 -> + match TryGetActivePatternInfo vref with + | Some _apinfo when _apinfo.ActiveTags.Length > 1 -> if doesActivePatternHaveFreeTypars g vref then errorR(Error(FSComp.SR.activePatternChoiceHasFreeTypars(v.LogicalName), v.Range)) | _ -> () - + match cenv.potentialUnboundUsesOfVals.TryFind v.Stamp with - | None -> () + | None -> () | Some m -> let nm = v.DisplayName errorR(Error(FSComp.SR.chkMemberUsedInInvalidWay(nm, nm, stringOfRange m), v.Range)) @@ -2000,170 +2079,183 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin v.ValReprInfo |> Option.iter (CheckValInfo cenv env) // Check accessibility - if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then + if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then let access = AdjustAccess (IsHiddenVal env.sigToImplRemapInfo v) (fun () -> v.DeclaringEntity.CompilationPath) v.Accessibility CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access v.Range v.Type - - if cenv.reportErrors then + + if cenv.reportErrors then // Check top-level let-bound values match bind.Var.ValReprInfo with - | Some info when info.HasNoArgs -> + | Some info when info.HasNoArgs -> CheckForByrefLikeType cenv env v.Range v.Type (fun () -> errorR(Error(FSComp.SR.chkNoByrefAsTopValue(), v.Range))) | _ -> () match v.PublicPath with | None -> () | _ -> - if + if // Don't support implicit [] on generated members, except the implicit members // for 'let' bound functions in classes. (not v.IsCompilerGenerated || v.IsIncrClassGeneratedMember) && - + (// Check the attributes on any enclosing module - env.reflect || + env.reflect || // Check the attributes on the value HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.Attribs || - // Also check the enclosing type for members - for historical reasons, in the TAST member values + // Also check the enclosing type for members - for historical reasons, in the TAST member values // are stored in the entity that encloses the type, hence we will not have noticed the ReflectedDefinition // on the enclosing type at this point. - HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then + HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then if v.IsInstanceMember && v.MemberApparentEntity.IsStructOrEnumTycon then errorR(Error(FSComp.SR.chkNoReflectedDefinitionOnStructMember(), v.Range)) cenv.usesQuotations <- true - // If we've already recorded a definition then skip this - match v.ReflectedDefinition with + // If we've already recorded a definition then skip this + match v.ReflectedDefinition with | None -> v.SetValDefn bindRhs | Some _ -> () // Run the conversion process over the reflected definition to report any errors in the // front end rather than the back end. We currently re-run this during ilxgen.fs but there's - // no real need for that except that it helps us to bundle all reflected definitions up into + // no real need for that except that it helps us to bundle all reflected definitions up into // one blob for pickling to the binary format try - let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.Yes) + let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.Yes) let methName = v.CompiledName g.CompilerGlobalState QuotationTranslator.ConvReflectedDefinition qscope methName v bindRhs |> ignore - + let _, _, exprSplices = qscope.Close() - if not (isNil exprSplices) then + if not (isNil exprSplices) then errorR(Error(FSComp.SR.chkReflectedDefCantSplice(), v.Range)) - with - | QuotationTranslator.InvalidQuotedTerm e -> + with + | QuotationTranslator.InvalidQuotedTerm e -> errorR e - - match v.MemberInfo with - | Some memberInfo when not v.IsIncrClassGeneratedMember -> - match memberInfo.MemberFlags.MemberKind with + + match v.MemberInfo with + | Some memberInfo when not v.IsIncrClassGeneratedMember -> + match memberInfo.MemberFlags.MemberKind with | SynMemberKind.PropertySet | SynMemberKind.PropertyGet -> // These routines raise errors for ill-formed properties v |> ReturnTypeOfPropertyVal g |> ignore v |> ArgInfosOfPropertyVal g |> ignore | _ -> () - + | _ -> () - let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData + let _topValInfo, isVoidRet = + match bind.Var.ValReprInfo with + | Some info -> + let _tps, tau = destTopForallTy g info v.Type + let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range + info, isUnitTy g returnTy + | None -> + ValReprInfo.emptyValData, false + + let isTailCall = IsTailCall.AtMethodOrFunction isVoidRet + + let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline // unless warning is suppressed (user must know what they're doing). // // If the method has ResumableCode return attribute we check the body w.r.t. that - let env = + let env = if cenv.reportErrors && isReturnsResumableCodeTy g v.TauType then if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then error(Error(FSComp.SR.tcResumableCodeNotSupported(), bind.Var.Range)) - if not v.MustInline then + if not v.MustInline then warning(Error(FSComp.SR.tcResumableCodeFunctionMustBeInline(), v.Range)) - if isReturnsResumableCodeTy g v.TauType then - { env with resumableCode = Resumable.ResumableExpr false } + if isReturnsResumableCodeTy g v.TauType then + { env with resumableCode = Resumable.ResumableExpr false } else env - CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) {cenv with isTailCall = isTailCall } env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt -and CheckBindings cenv env binds = +and CheckBindings cenv env binds = + let env = ComputeMustTailCallForRecVals cenv env binds for bind in binds do CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore // Top binds introduce expression, check they are reraise free. let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = + let env = ComputeMustTailCallForRecVals cenv env [bind] let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs - if isExplicitEntryPoint then + if isExplicitEntryPoint then cenv.entryPointGiven <- true let isLastCompiland = fst cenv.isLastCompiland - if not isLastCompiland && cenv.reportErrors then - errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) + if not isLastCompiland && cenv.reportErrors then + errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields - not v.IsMutable && + not v.IsMutable && // Literals always have fields - not (HasFSharpAttribute g g.attrib_LiteralAttribute v.Attribs) && - not (HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute v.Attribs) && - not (HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute v.Attribs) && + not (HasFSharpAttribute g g.attrib_LiteralAttribute v.Attribs) && + not (HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute v.Attribs) && + not (HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute v.Attribs) && // Having a field makes the binding a static initialization trigger - IsSimpleSyntacticConstantExpr g e && + IsSimpleSyntacticConstantExpr g e && // Check the thing is actually compiled as a property IsCompiledAsStaticProperty g v || (g.compilingFSharpCore && v.Attribs |> List.exists(fun (Attrib(tc, _, _, _, _, _, _)) -> tc.CompiledName = "ValueAsStaticPropertyAttribute")) - then + then v.SetIsCompiledAsStaticPropertyWithoutField() // Check for value name clashes begin - try + try // Skip compiler generated values if v.IsCompilerGenerated then () else // Skip explicit implementations of interface methods if ValIsExplicitImpl g v then () else - - match v.TryDeclaringEntity with + + match v.TryDeclaringEntity with | ParentNone -> () // this case can happen after error recovery from earlier error - | Parent _ -> - let tcref = v.DeclaringEntity - let hasDefaultAugmentation = + | Parent _ -> + let tcref = v.DeclaringEntity + let hasDefaultAugmentation = tcref.IsUnionTycon && match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with | Some(Attrib(_, _, [ AttribBoolArg b ], _, _, _, _)) -> b | _ -> true (* not hiddenRepr *) let kind = (if v.IsMember then "member" else "value") - let check skipValCheck nm = - if not skipValCheck && - v.IsModuleBinding && - tcref.ModuleOrNamespaceType.AllValsByLogicalName.ContainsKey nm && + let check skipValCheck nm = + if not skipValCheck && + v.IsModuleBinding && + tcref.ModuleOrNamespaceType.AllValsByLogicalName.ContainsKey nm && not (valEq tcref.ModuleOrNamespaceType.AllValsByLogicalName[nm] v) then - + error(Duplicate(kind, v.DisplayName, v.Range)) #if CASES_IN_NESTED_CLASS - if tcref.IsUnionTycon && nm = "Cases" then + if tcref.IsUnionTycon && nm = "Cases" then errorR(NameClash(nm, kind, v.DisplayName, v.Range, "generated type", "Cases", tcref.Range)) #endif - if tcref.IsUnionTycon then - match nm with + if tcref.IsUnionTycon then + match nm with | "Tag" -> errorR(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.typeInfoGeneratedProperty(), "Tag", tcref.Range)) | "Tags" -> errorR(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.typeInfoGeneratedType(), "Tags", tcref.Range)) | _ -> - if hasDefaultAugmentation then - match tcref.GetUnionCaseByName nm with + if hasDefaultAugmentation then + match tcref.GetUnionCaseByName nm with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.typeInfoUnionCase(), uc.DisplayName, uc.Range)) | None -> () - let hasNoArgs = - match v.ValReprInfo with - | None -> false + let hasNoArgs = + match v.ValReprInfo with + | None -> false | Some arity -> List.sum arity.AritiesOfArgs - v.NumObjArgs <= 0 && arity.NumTypars = 0 - // In unions user cannot define properties that clash with generated ones - if tcref.UnionCasesArray.Length = 1 && hasNoArgs then + // In unions user cannot define properties that clash with generated ones + if tcref.UnionCasesArray.Length = 1 && hasNoArgs then let ucase1 = tcref.UnionCasesArray[0] for f in ucase1.RecdFieldsArray do if f.LogicalName = nm then @@ -2172,18 +2264,18 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = // Default augmentation contains the nasty 'Case' etc. let prefix = "New" if nm.StartsWithOrdinal prefix then - match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with + match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseCompiledForm(), uc.DisplayName, uc.Range)) | None -> () // Default augmentation contains the nasty 'Is' etc. let prefix = "Is" if nm.StartsWithOrdinal prefix && hasDefaultAugmentation then - match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with + match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(), uc.DisplayName, uc.Range)) | None -> () - match tcref.GetFieldByName nm with + match tcref.GetFieldByName nm with | Some rf -> error(NameClash(nm, kind, v.DisplayName, v.Range, "field", rf.LogicalName, rf.Range)) | None -> () @@ -2192,27 +2284,27 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = check false (v.CompiledName cenv.g.CompilerGlobalState) // Check if an F# extension member clashes - if v.IsExtensionMember then - tcref.ModuleOrNamespaceType.AllValsAndMembersByLogicalNameUncached[v.LogicalName] |> List.iter (fun v2 -> + if v.IsExtensionMember then + tcref.ModuleOrNamespaceType.AllValsAndMembersByLogicalNameUncached[v.LogicalName] |> List.iter (fun v2 -> if v2.IsExtensionMember && not (valEq v v2) && (v.CompiledName cenv.g.CompilerGlobalState) = (v2.CompiledName cenv.g.CompilerGlobalState) then let minfo1 = FSMeth(g, generalizedTyconRef g tcref, mkLocalValRef v, Some 0UL) let minfo2 = FSMeth(g, generalizedTyconRef g tcref, mkLocalValRef v2, Some 0UL) - if tyconRefEq g v.MemberApparentEntity v2.MemberApparentEntity && - MethInfosEquivByNameAndSig EraseAll true g cenv.amap v.Range minfo1 minfo2 then + if tyconRefEq g v.MemberApparentEntity v2.MemberApparentEntity && + MethInfosEquivByNameAndSig EraseAll true g cenv.amap v.Range minfo1 minfo2 then errorR(Duplicate(kind, v.DisplayName, v.Range))) // Properties get 'get_X', only if there are no args // Properties get 'get_X' - match v.ValReprInfo with + match v.ValReprInfo with | Some arity when arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("get_" + v.DisplayName) | _ -> () - match v.ValReprInfo with + match v.ValReprInfo with | Some arity when v.IsMutable && arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("set_" + v.DisplayName) | _ -> () - match TryChopPropertyName v.DisplayName with - | Some res -> check true res + match TryChopPropertyName v.DisplayName with + | Some res -> check true res | None -> () - with e -> errorRecovery e v.Range + with e -> errorRecovery e v.Range end CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore @@ -2221,26 +2313,26 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = // check tycons //-------------------------------------------------------------------------- -let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = +let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = let g = cenv.g let tcref = mkLocalTyconRef tycon let m = rfield.Range let fieldTy = stripTyEqns cenv.g rfield.FormalType - let isHidden = - IsHiddenTycon env.sigToImplRemapInfo tycon || - IsHiddenTyconRepr env.sigToImplRemapInfo tycon || + let isHidden = + IsHiddenTycon env.sigToImplRemapInfo tycon || + IsHiddenTyconRepr env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility CheckTypeForAccess cenv env (fun () -> rfield.LogicalName) access m fieldTy - if isByrefLikeTyconRef g m tcref then + if isByrefLikeTyconRef g m tcref then // Permit Span fields in IsByRefLike types CheckTypePermitSpanLike cenv env m fieldTy if cenv.reportErrors then CheckForByrefType cenv env fieldTy (fun () -> errorR(Error(FSComp.SR.chkCantStoreByrefValue(), tycon.Range))) else CheckTypeNoByrefs cenv env m fieldTy - if cenv.reportErrors then + if cenv.reportErrors then CheckForByrefLikeType cenv env m fieldTy (fun () -> errorR(Error(FSComp.SR.chkCantStoreByrefValue(), tycon.Range))) CheckAttribs cenv env rfield.PropertyAttribs @@ -2251,7 +2343,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = if tycon.IsProvidedGeneratedTycon then () else #endif let g = cenv.g - let m = tycon.Range + let m = tycon.Range let tcref = mkLocalTyconRef tycon let ty = generalizedTyconRef g tcref @@ -2268,9 +2360,9 @@ let CheckEntityDefn cenv env (tycon: Entity) = if not tycon.IsTypeAbbrev then - let allVirtualMethsInParent = - match GetSuperTypeOfType g cenv.amap m ty with - | Some superTy -> + let allVirtualMethsInParent = + match GetSuperTypeOfType g cenv.amap m ty with + | Some superTy -> GetIntrinsicMethInfosOfType cenv.infoReader None AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m superTy |> List.filter (fun minfo -> minfo.IsVirtual) | None -> [] @@ -2282,7 +2374,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = then MethInfosEquivByNameAndSig eraseFlag true g cenv.amap m minfo minfo2 else MethInfosEquivByNameAndPartialSig eraseFlag true g cenv.amap m minfo minfo2 (* partial ignores return type *) - let immediateMeths = + let immediateMeths = [ for v in tycon.AllGeneratedValues do yield FSMeth (g, ty, v, None) yield! GetImmediateIntrinsicMethInfosOfType (None, AccessibleFromSomewhere) g cenv.amap m ty ] @@ -2292,24 +2384,24 @@ let CheckEntityDefn cenv env (tycon: Entity) = match hash.TryGetValue nm with | true, h -> h | _ -> [] - + // precompute methods grouped by MethInfo.LogicalName - let hashOfImmediateMeths = + let hashOfImmediateMeths = let h = Dictionary() for minfo in immediateMeths do match h.TryGetValue minfo.LogicalName with - | true, methods -> + | true, methods -> h[minfo.LogicalName] <- minfo :: methods - | false, _ -> + | false, _ -> h[minfo.LogicalName] <- [minfo] h - let getOtherMethods (minfo : MethInfo) = + let getOtherMethods (minfo : MethInfo) = [ //we have added all methods to the dictionary on the previous step let methods = hashOfImmediateMeths[minfo.LogicalName] for m in methods do // use referential identity to filter out 'minfo' method - if not(Object.ReferenceEquals(m, minfo)) then + if not(Object.ReferenceEquals(m, minfo)) then yield m ] @@ -2319,34 +2411,34 @@ let CheckEntityDefn cenv env (tycon: Entity) = let m = (match minfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) let others = getOtherMethods minfo // abstract/default pairs of duplicate methods are OK - let IsAbstractDefaultPair (x: MethInfo) (y: MethInfo) = + let IsAbstractDefaultPair (x: MethInfo) (y: MethInfo) = x.IsDispatchSlot && y.IsDefiniteFSharpOverride - let IsAbstractDefaultPair2 (minfo: MethInfo) (minfo2: MethInfo) = + let IsAbstractDefaultPair2 (minfo: MethInfo) (minfo2: MethInfo) = IsAbstractDefaultPair minfo minfo2 || IsAbstractDefaultPair minfo2 minfo let checkForDup erasureFlag (minfo2: MethInfo) = not (IsAbstractDefaultPair2 minfo minfo2) && (minfo.IsInstance = minfo2.IsInstance) && MethInfosEquivWrtUniqueness erasureFlag m minfo minfo2 - if others |> List.exists (checkForDup EraseAll) then - if others |> List.exists (checkForDup EraseNone) then + if others |> List.exists (checkForDup EraseAll) then + if others |> List.exists (checkForDup EraseNone) then errorR(Error(FSComp.SR.chkDuplicateMethod(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) else errorR(Error(FSComp.SR.chkDuplicateMethodWithSuffix(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) let numCurriedArgSets = minfo.NumArgs.Length - if numCurriedArgSets > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then + if numCurriedArgSets > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then errorR(Error(FSComp.SR.chkDuplicateMethodCurried(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) - if numCurriedArgSets > 1 && - (minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) - |> List.existsSquared (fun (ParamData(isParamArrayArg, _isInArg, isOutArg, optArgInfo, callerInfo, _, reflArgInfo, ty)) -> - isParamArrayArg || isOutArg || reflArgInfo.AutoQuote || optArgInfo.IsOptional || callerInfo <> NoCallerInfo || isByrefLikeTy g m ty)) then + if numCurriedArgSets > 1 && + (minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) + |> List.existsSquared (fun (ParamData(isParamArrayArg, _isInArg, isOutArg, optArgInfo, callerInfo, _, reflArgInfo, ty)) -> + isParamArrayArg || isOutArg || reflArgInfo.AutoQuote || optArgInfo.IsOptional || callerInfo <> NoCallerInfo || isByrefLikeTy g m ty)) then errorR(Error(FSComp.SR.chkCurriedMethodsCantHaveOutParams(), m)) if numCurriedArgSets = 1 then - minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) + minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) |> List.iterSquared (fun (ParamData(_, isInArg, _, optArgInfo, callerInfo, _, _, ty)) -> ignore isInArg match (optArgInfo, callerInfo) with @@ -2370,46 +2462,46 @@ let CheckEntityDefn cenv env (tycon: Entity) = | CalleeSide, CallerMemberName -> if not ((isOptionTy g ty) && (typeEquiv g g.string_ty (destOptionTy g ty))) then errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfo.ToString(), "string", NicePrint.minimalStringOfType cenv.denv (destOptionTy g ty)), m))) - + for pinfo in immediateProps do let nm = pinfo.PropertyName - let m = - match pinfo.ArbitraryValRef with - | None -> m + let m = + match pinfo.ArbitraryValRef with + | None -> m | Some vref -> vref.DefinitionRange - if hashOfImmediateMeths.ContainsKey nm then + if hashOfImmediateMeths.ContainsKey nm then errorR(Error(FSComp.SR.chkPropertySameNameMethod(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) let others = getHash hashOfImmediateProps nm - if pinfo.HasGetter && pinfo.HasSetter && pinfo.GetterMethod.IsVirtual <> pinfo.SetterMethod.IsVirtual then + if pinfo.HasGetter && pinfo.HasSetter && pinfo.GetterMethod.IsVirtual <> pinfo.SetterMethod.IsVirtual then errorR(Error(FSComp.SR.chkGetterSetterDoNotMatchAbstract(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) - let checkForDup erasureFlag pinfo2 = + let checkForDup erasureFlag pinfo2 = // abstract/default pairs of duplicate properties are OK - let IsAbstractDefaultPair (x: PropInfo) (y: PropInfo) = + let IsAbstractDefaultPair (x: PropInfo) (y: PropInfo) = x.IsDispatchSlot && y.IsDefiniteFSharpOverride not (IsAbstractDefaultPair pinfo pinfo2 || IsAbstractDefaultPair pinfo2 pinfo) && PropInfosEquivByNameAndPartialSig erasureFlag g cenv.amap m pinfo pinfo2 (* partial ignores return type *) if others |> List.exists (checkForDup EraseAll) then - if others |> List.exists (checkForDup EraseNone) then + if others |> List.exists (checkForDup EraseNone) then errorR(Error(FSComp.SR.chkDuplicateProperty(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) else errorR(Error(FSComp.SR.chkDuplicatePropertyWithSuffix(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) // Check to see if one is an indexer and one is not - if ( (pinfo.HasGetter && - pinfo.HasSetter && + if ( (pinfo.HasGetter && + pinfo.HasSetter && let setterArgs = pinfo.DropGetter().GetParamTypes(cenv.amap, m) let getterArgs = pinfo.DropSetter().GetParamTypes(cenv.amap, m) setterArgs.Length <> getterArgs.Length) - || + || (let nargs = pinfo.GetParamTypes(cenv.amap, m).Length - others |> List.exists (fun pinfo2 -> (isNil(pinfo2.GetParamTypes(cenv.amap, m))) <> (nargs = 0)))) then - + others |> List.exists (fun pinfo2 -> (isNil(pinfo2.GetParamTypes(cenv.amap, m))) <> (nargs = 0)))) then + errorR(Error(FSComp.SR.chkPropertySameNameIndexer(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) // Check to see if the signatures of the both getter and the setter imply the same property type @@ -2421,7 +2513,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = errorR(Error(FSComp.SR.chkGetterAndSetterHaveSamePropertyType(pinfo.PropertyName, NicePrint.minimalStringOfType cenv.denv ty1, NicePrint.minimalStringOfType cenv.denv ty2), m)) hashOfImmediateProps[nm] <- pinfo :: others - + if not (isInterfaceTy g ty) then let hashOfAllVirtualMethsInParent = Dictionary() for minfo in allVirtualMethsInParent do @@ -2432,192 +2524,193 @@ let CheckEntityDefn cenv env (tycon: Entity) = if not minfo.IsDispatchSlot && not minfo.IsVirtual && minfo.IsInstance then let nm = minfo.LogicalName let m = (match minfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) - let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm + let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm let checkForDup erasureFlag (minfo2: MethInfo) = minfo2.IsDispatchSlot && MethInfosEquivByNameAndSig erasureFlag true g cenv.amap m minfo minfo2 match parentMethsOfSameName |> List.tryFind (checkForDup EraseAll) with | None -> () | Some minfo -> let mtext = NicePrint.stringOfMethInfo cenv.infoReader m cenv.denv minfo - if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then + if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then warning(Error(FSComp.SR.tcNewMemberHidesAbstractMember mtext, m)) else warning(Error(FSComp.SR.tcNewMemberHidesAbstractMemberWithSuffix mtext, m)) - + if minfo.IsDispatchSlot then let nm = minfo.LogicalName let m = (match minfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) - let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm + let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm let checkForDup erasureFlag minfo2 = MethInfosEquivByNameAndSig erasureFlag true g cenv.amap m minfo minfo2 - + if parentMethsOfSameName |> List.exists (checkForDup EraseAll) then - if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then + if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then errorR(Error(FSComp.SR.chkDuplicateMethodInheritedType nm, m)) else errorR(Error(FSComp.SR.chkDuplicateMethodInheritedTypeWithSuffix nm, m)) - if TyconRefHasAttributeByName m tname_IsByRefLikeAttribute tcref && not tycon.IsStructOrEnumTycon then + if TyconRefHasAttributeByName m tname_IsByRefLikeAttribute tcref && not tycon.IsStructOrEnumTycon then errorR(Error(FSComp.SR.tcByRefLikeNotStruct(), tycon.Range)) - if TyconRefHasAttribute g m g.attrib_IsReadOnlyAttribute tcref && not tycon.IsStructOrEnumTycon then + if TyconRefHasAttribute g m g.attrib_IsReadOnlyAttribute tcref && not tycon.IsStructOrEnumTycon then errorR(Error(FSComp.SR.tcIsReadOnlyNotStruct(), tycon.Range)) - // Considers TFSharpObjectRepr, TFSharpRecdRepr and TFSharpUnionRepr. + // Considers TFSharpObjectRepr, TFSharpRecdRepr and TFSharpUnionRepr. // [Review] are all cases covered: TILObjectRepr, TAsmRepr. [Yes - these are FSharp.Core.dll only] tycon.AllFieldsArray |> Array.iter (CheckRecdField false cenv env tycon) - + // Abstract slots can have byref arguments and returns - for vref in abstractSlotValsOfTycons [tycon] do - match vref.ValReprInfo with - | Some valReprInfo -> + for vref in abstractSlotValsOfTycons [tycon] do + match vref.ValReprInfo with + | Some valReprInfo -> let tps, argTysl, retTy, _ = GetValReprTypeInFSharpForm g valReprInfo vref.Type m let env = BindTypars g env tps - for argTys in argTysl do - for argTy, _ in argTys do + for argTys in argTysl do + for argTy, _ in argTys do CheckTypeNoInnerByrefs cenv env vref.Range argTy CheckTypeNoInnerByrefs cenv env vref.Range retTy | None -> () // Supported interface may not have byrefs - tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypeNoByrefs cenv env m) + tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypeNoByrefs cenv env m) - superOfTycon g tycon |> CheckTypeNoByrefs cenv env m + superOfTycon g tycon |> CheckTypeNoByrefs cenv env m - if tycon.IsUnionTycon then + if tycon.IsUnionTycon then for ucase in tycon.UnionCasesArray do - CheckAttribs cenv env ucase.Attribs + CheckAttribs cenv env ucase.Attribs ucase.RecdFieldsArray |> Array.iter (CheckRecdField true cenv env tycon) // Access checks let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility - let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty + let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty - abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) + abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) superOfTycon g tycon |> visitType // We do not have to check access of interface implementations. - if tycon.IsFSharpDelegateTycon then - match tycon.TypeReprInfo with + if tycon.IsFSharpDelegateTycon then + match tycon.TypeReprInfo with | TFSharpObjectRepr r -> - match r.fsobjmodel_kind with + match r.fsobjmodel_kind with | TFSharpDelegate ss -> - //ss.ClassTypars - //ss.MethodTypars + //ss.ClassTypars + //ss.MethodTypars ss.FormalReturnType |> Option.iter visitType ss.FormalParams |> List.iterSquared (fun (TSlotParam(_, ty, _, _, _, _)) -> visitType ty) | _ -> () | _ -> () - let interfaces = + let interfaces = AllSuperTypesOfType g cenv.amap tycon.Range AllowMultiIntfInstantiations.Yes ty |> List.filter (isInterfaceTy g) - - if tycon.IsFSharpInterfaceTycon then + + if tycon.IsFSharpInterfaceTycon then List.iter visitType interfaces // Check inherited interface is as accessible if not (isRecdOrStructTyconRefAssumedImmutable g tcref) && isRecdOrStructTyconRefReadOnly g m tcref then errorR(Error(FSComp.SR.readOnlyAttributeOnStructWithMutableField(), m)) - - if cenv.reportErrors then - if not tycon.IsTypeAbbrev then + + if cenv.reportErrors then + if not tycon.IsTypeAbbrev then let interfaces = GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g cenv.amap m ty |> List.collect (AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes) |> List.filter (isInterfaceTy g) CheckMultipleInterfaceInstantiations cenv ty interfaces false m - + // Check fields. We check these late because we have to have first checked that the structs are // free of cycles - if tycon.IsStructOrEnumTycon then + if tycon.IsStructOrEnumTycon then for f in tycon.AllInstanceFieldsAsList do - // Check if it's marked unsafe + // Check if it's marked unsafe let zeroInitUnsafe = TryFindFSharpBoolAttribute g g.attrib_DefaultValueAttribute f.FieldAttribs if zeroInitUnsafe = Some true then - if not (TypeHasDefaultValue g m ty) then + if not (TypeHasDefaultValue g m ty) then errorR(Error(FSComp.SR.chkValueWithDefaultValueMustHaveDefaultValue(), m)) // Check type abbreviations - match tycon.TypeAbbrev with + match tycon.TypeAbbrev with | None -> () - | Some ty -> + | Some ty -> // Library-defined outref<'T> and inref<'T> contain byrefs on the r.h.s. - if not g.compilingFSharpCore then + if not g.compilingFSharpCore then CheckForByrefType cenv env ty (fun () -> errorR(Error(FSComp.SR.chkNoByrefInTypeAbbrev(), tycon.Range))) -let CheckEntityDefns cenv env tycons = - tycons |> List.iter (CheckEntityDefn cenv env) +let CheckEntityDefns cenv env tycons = + tycons |> List.iter (CheckEntityDefn cenv env) //-------------------------------------------------------------------------- // check modules //-------------------------------------------------------------------------- -let rec CheckDefnsInModule cenv env mdefs = +let rec CheckDefnsInModule cenv env mdefs = for mdef in mdefs do CheckDefnInModule cenv env mdef and CheckNothingAfterEntryPoint cenv m = - if cenv.entryPointGiven && cenv.reportErrors then - errorR(Error(FSComp.SR.chkEntryPointUsage(), m)) + if cenv.entryPointGiven && cenv.reportErrors then + errorR(Error(FSComp.SR.chkEntryPointUsage(), m)) -and CheckDefnInModule cenv env mdef = - match mdef with - | TMDefRec(isRec, _opens, tycons, mspecs, m) -> +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) CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env) mspecs - | TMDefLet(bind, m) -> + | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m - CheckModuleBinding cenv env bind + CheckModuleBinding cenv env bind BindVal cenv env bind.Var | TMDefOpens _ -> () - | TMDefDo(e, m) -> + | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs cenv env e - | TMDefs defs -> CheckDefnsInModule cenv env defs + CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e + | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env mbind = - match mbind with + match mbind with | ModuleOrNamespaceBinding.Binding bind -> BindVals cenv env (valsOfBinds [bind]) CheckModuleBinding cenv env bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } - CheckDefnInModule cenv env rhs + CheckDefnInModule cenv env rhs -let CheckImplFileContents cenv env implFileTy implFileContents = +let CheckImplFileContents cenv env implFileTy implFileContents = let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } UpdatePrettyTyparNames.updateModuleOrNamespaceType implFileTy CheckDefnInModule cenv env implFileContents - + let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = - let cenv = - { g = g - reportErrors = reportErrors - boundVals = Dictionary<_, _>(100, HashIdentity.Structural) - limitVals = Dictionary<_, _>(100, HashIdentity.Structural) + let cenv = + { g = g + reportErrors = reportErrors + boundVals = Dictionary<_, _>(100, HashIdentity.Structural) + limitVals = Dictionary<_, _>(100, HashIdentity.Structural) stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") - potentialUnboundUsesOfVals = Map.empty + potentialUnboundUsesOfVals = Map.empty anonRecdTypes = StampMap.Empty - usesQuotations = false - infoReader = infoReader + usesQuotations = false + infoReader = infoReader internalsVisibleToPaths = internalsVisibleToPaths - amap = amap - denv = denv + amap = amap + denv = denv viewCcu = viewCcu isLastCompiland = isLastCompiland isInternalTestSpanStackReferring = isInternalTestSpanStackReferring tcVal = tcValF - entryPointGiven = false} - + entryPointGiven = false + isTailCall = IsTailCall.No } + // Certain type equality checks go faster if these TyconRefs are pre-resolved. // This is because pre-resolving allows tycon equality to be determined by pointer equality on the entities. // See primEntityRefEq. @@ -2629,14 +2722,15 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v resolve g.system_ArgIterator_tcref resolve g.system_RuntimeArgumentHandle_tcref - let env = + let env = { sigToImplRemapInfo=[] quote=false boundTyparNames=[] argVals = ValMap.Empty + mustTailCall = Zset.empty valOrder boundTypars= TyparMap.Empty reflect=false - external=false + external=false returnScope = 0 isInAppExpr = false resumableCode = Resumable.None } @@ -2644,7 +2738,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v CheckImplFileContents cenv env implFileTy implFileContents CheckAttribs cenv env extraAttribs - if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then + 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 9962c04abd4..4963a12d9a9 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1700,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 '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/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..bd4c35f46c3 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -102,6 +102,11 @@ Pokud typ používá atribut [<Sealed>] i [<AbstractClass>], znamená to, že je statický. Členové instance nejsou povoleni. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. Atribut AssemblyKeyNameAttribute je zastaralý. Použijte místo něj AssemblyKeyFileAttribute. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 2277d79cbbb..a4807cf4acf 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -102,6 +102,11 @@ Wenn ein Typ sowohl das Attribute [<Sealed>] wie auch [<AbstractClass>] verwendet, bedeutet dies, dass er statisch ist. Members in Instanzen sind nicht zulässig. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. "AssemblyKeyNameAttribute" gilt als veraltet. Verwenden Sie stattdessen "AssemblyKeyFileAttribute". diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 231200689ee..ae5df78558e 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -102,6 +102,11 @@ Si un tipo usa los atributos [<Sealed>] y [<AbstractClass>], significa que es estático. No se permiten miembros de instancia. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. El elemento "AssemblyKeyNameAttribute" está en desuso. Use "AssemblyKeyFileAttribute" en su lugar. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 00825630174..df1ac5c2917 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -102,6 +102,11 @@ Si un type utilise les attributs [<Sealed>] et [<AbstractClass>], cela signifie qu’il est statique. Les membres de l’instance ne sont pas autorisés. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' a été déprécié. Utilisez 'AssemblyKeyFileAttribute' à la place. diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 4fb3debe94f..2846aa3ee2d 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -102,6 +102,11 @@ Se un tipo usa entrambi gli attributi [<Sealed>] e [<AbstractClass>], significa che è statico. Membri dell'istanza non consentiti. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. L'attributo 'AssemblyKeyNameAttribute' è deprecato. In alternativa, usare 'AssemblyKeyFileAttribute'. diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 89bbcfc639b..33fd02862eb 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -102,6 +102,11 @@ 型が [<Sealed>] と [<AbstractClass>] の両方の属性を使用する場合、それは静的であることを意味します。インスタンス メンバーは許可されません。 + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' は非推奨になりました。代わりに 'AssemblyKeyFileAttribute' を使用してください。 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index f48dc4ad136..9879986d75f 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -102,6 +102,11 @@ 형식이 [<Sealed>] 및 [<AbstractClass>] 특성을 모두 사용하는 경우 정적임을 의미합니다. 인스턴스 멤버는 허용되지 않습니다. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute'는 사용되지 않습니다. 대신 'AssemblyKeyFileAttribute'를 사용하세요. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index fae8595a137..48f510bece4 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -102,6 +102,11 @@ Jeśli typ używa obu [<Sealed>] i [< AbstractClass>] atrybutów, oznacza to, że jest statyczny. Elementy członkowskie wystąpienia są niedozwolone. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. Element „AssemblyKeyNameAttribute” jest przestarzały. Zamiast niego użyj elementu „AssemblyKeyFileAttribute”. diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 0377a0a1229..f483b56b8ce 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -102,6 +102,11 @@ Se um tipo usa os atributos [<Sealed>] e [<AbstractClass>], significa que é estático. Membros da instância não são permitidos. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. O 'AssemblyKeyNameAttribute' foi preterido. Use o 'AssemblyKeyFileAttribute'. diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index db5d1c8d4b8..69591c60e4b 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -102,6 +102,11 @@ Если тип использует атрибуты [<Sealed>] и [<AbstractClass>], это означает, что он статический. Элементы экземпляра не разрешены. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. Атрибут "AssemblyKeyNameAttribute" является устаревшим. Используйте вместо него атрибут "AssemblyKeyFileAttribute". diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 40647aabc76..8fcac975c6c 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -102,6 +102,11 @@ Bir tür, hem [<Sealed>] hem de [< AbstractClass>] özniteliklerini kullanıyorsa bu statik olduğu anlamına gelir. Örnek üyelerine izin verilmez. + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' kullanım dışı bırakıldı. Bunun yerine 'AssemblyKeyFileAttribute' kullanın. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index e46bf93fb8c..7759137ab4c 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -102,6 +102,11 @@ 如果类型同时使用 [<Sealed>] 和 [<AbstractClass>] 属性，则表示它是静态的。不允许使用实例成员。 + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. "AssemblyKeyNameAttribute" 已被弃用。请改为使用 "AssemblyKeyFileAttribute"。 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 007b002b5cc..5759c1d906c 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -102,6 +102,11 @@ 如果類型同時使用 [<Sealed>] 和 [<AbstractClass>] 屬性，表示其為靜態。不允許執行個體成員。 + + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + + The 'AssemblyKeyNameAttribute' has been deprecated. Use 'AssemblyKeyFileAttribute' instead. 'AssemblyKeyNameAttribute' 已淘汰。請改用 'AssemblyKeyFileAttribute'。 diff --git a/src/FSharp.Core/prim-types.fs b/src/FSharp.Core/prim-types.fs index e05a55fa47b..7693d7e6441 100644 --- a/src/FSharp.Core/prim-types.fs +++ b/src/FSharp.Core/prim-types.fs @@ -374,6 +374,11 @@ namespace Microsoft.FSharp.Core type NoCompilerInliningAttribute() = inherit Attribute() + [] + [] + type TailCallAttribute() = + inherit System.Attribute() + #if !NET5_0_OR_GREATER namespace System.Diagnostics.CodeAnalysis diff --git a/src/FSharp.Core/prim-types.fsi b/src/FSharp.Core/prim-types.fsi index bcbfa77e320..bb29b51ed55 100644 --- a/src/FSharp.Core/prim-types.fsi +++ b/src/FSharp.Core/prim-types.fsi @@ -950,6 +950,12 @@ namespace Microsoft.FSharp.Core /// NoCompilerInliningAttribute new: unit -> NoCompilerInliningAttribute + [] + [] + type TailCallAttribute = + inherit System.Attribute + new : unit -> TailCallAttribute + namespace System.Diagnostics.CodeAnalysis open System diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs new file mode 100644 index 00000000000..bebf8e286d6 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -0,0 +1,147 @@ +namespace FSharp.Compiler.ComponentTests.ErrorMessages + +open FSharp.Test.Compiler +open FSharp.Test.Compiler.Assertions.StructuredResultsAsserts +open Xunit + +module ``TailCall Attribute`` = + + [] + let ``Warn successfully in if-else`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + if n = 0 + then acc + else (fact (n-1) (mul n acc)) + 23 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 11 + EndLine = 8 + EndColumn = 33 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 11 + EndLine = 8 + EndColumn = 15 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn successfully in match clause`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + match n with + | 0 -> acc + | _ -> (fact (n-1) (mul n acc)) + 23 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 35 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 17 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Warn successfully for rec call in binding`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + match n with + | 0 -> acc + | _ -> + let r = (fact (n-1) (mul n acc)) + r + 23 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 35 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3566 + Range = { StartLine = 8 + StartColumn = 13 + EndLine = 8 + EndColumn = 17 } + Message = + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcall`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + if n = 0 + then acc + else (fact (n-1) (mul n acc)) + """ + |> FSharp + |> typecheck + |> shouldSucceed + + [] + let ``Warn successfully for mutually recursive functions`` () = + """ +let foo x = + printfn "Foo: %x" x + +[] +let rec bar x = + match x with + | 0 -> + foo x // OK: non-tail-recursive call to a function which doesn't share the current stack frame (i.e., 'bar' or 'baz'). + printfn "Zero" + + | 1 -> + bar (x - 1) // Warning: this call is not tail-recursive + printfn "Uno" + baz x // OK: tail-recursive call. + + | x -> + printfn "0x%08x" x + bar (x - 1) // OK: tail-recursive call. + +and [] baz x = + printfn "Baz!" + bar (x - 1) // OK: tail-recursive call. + """ + |> FSharp + |> typecheck + |> shouldFail diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 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 @@ + From 3390880b54b68d7925ba3d30ee5facbf61f87e1d Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 30 May 2023 14:50:15 +0200 Subject: [PATCH 02/77] Adjust error number after merge --- .../ErrorMessages/TailCallAttribute.fs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index bebf8e286d6..9e92c7acefa 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -21,14 +21,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 33 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 @@ -52,14 +52,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 @@ -85,14 +85,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3566 + { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 From 08b3714607fc70821ba5bc574caafbc5ad5b529e Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 30 May 2023 18:59:31 +0200 Subject: [PATCH 03/77] add two test cases for type members --- .../ErrorMessages/TailCallAttribute.fs | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 9e92c7acefa..f072809873d 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -145,3 +145,34 @@ and [] baz x = |> FSharp |> typecheck |> shouldFail + + [] + let ``Warn successfully for invalid tailcall in type method`` () = + """ +type C () = + [] + member this.M1() = this.M1() + 1 + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 24 + EndLine = 4 + EndColumn = 33 } + Message = + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcall in type method`` () = + """ +type C () = + [] + member this.M1() = this.M1() + """ + |> FSharp + |> typecheck + |> shouldSucceed From c49018a5811625cc6b6326b805eecced6945be31 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 30 May 2023 19:10:40 +0200 Subject: [PATCH 04/77] Don't try to split empty CurriedArgInfos --- src/Compiler/Checking/PostInferenceChecks.fs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 7dfa7440133..a2bef406e7b 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -933,7 +933,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m - (List.splitAfter curriedArgInfos.Length argsl), returnTy + if argsl.Length >= curriedArgInfos.Length then + (List.splitAfter curriedArgInfos.Length argsl), returnTy + else + ([], argsl), returnTy let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) let isCCall = match valUseFlags with From a9eae39621aca90d6ed3e30c34d62b2e4dff00cc Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 31 May 2023 14:39:20 +0200 Subject: [PATCH 05/77] Add more member tests --- .../ErrorMessages/TailCallAttribute.fs | 48 +++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index f072809873d..5c9cfbde3a9 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -176,3 +176,51 @@ type C () = |> FSharp |> typecheck |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in type methods`` () = + """ +type C () = + [] + member this.M1() = + this.M2() // ok + + [] + member this.M2() = + this.M1() // ok + """ + |> FSharp + |> typecheck + |> shouldSucceed + + [] + let ``Warn successfully for invalid tailcalls in type methods`` () = + """ +type F () = + [] + member this.M1() = + this.M2() + 1 // should warn + + [] + member this.M2() = + this.M1() + 2 // should warn + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 9 + EndLine = 5 + EndColumn = 18 } + Message = + "The member or function 'M2' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 9 + StartColumn = 9 + EndLine = 9 + EndColumn = 18 } + Message = + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] From 44d17bf8f7694d10e13be9c712cbdfeb76ee7286 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 31 May 2023 14:49:02 +0200 Subject: [PATCH 06/77] seems like we need to build up the env.mustTailCall set earlier in the traversal to have the content ready when checking members which call each other --- src/Compiler/Checking/PostInferenceChecks.fs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index a2bef406e7b..c52ac150cfe 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -86,7 +86,7 @@ type env = sigToImplRemapInfo: (Remap * SignatureHidingInfo) list /// Values in this recursive scope that have been marked [] - mustTailCall: Zset; + mutable mustTailCall: Zset /// Are we in a quotation? quote : bool @@ -326,6 +326,9 @@ let BindVal cenv env (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 + + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + env.mustTailCall <- Zset.add v env.mustTailCall let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = @@ -357,10 +360,6 @@ let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo) -let ComputeMustTailCallForRecVals cenv env (binds: Bindings) = - let mustTailCall = [ for b in binds do if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute b.Var.Attribs then yield b.Var ] - { env with mustTailCall = Zset.addList mustTailCall env.mustTailCall } - //-------------------------------------------------------------------------- // approx walk of type //-------------------------------------------------------------------------- @@ -2180,13 +2179,11 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin CheckLambdas isTop (Some v) {cenv with isTailCall = isTailCall } env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = - let env = ComputeMustTailCallForRecVals cenv env binds for bind in binds do CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore // Top binds introduce expression, check they are reraise free. let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = - let env = ComputeMustTailCallForRecVals cenv env [bind] let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then From 94ac8da7dc1b634d73e9a7590fb95154db509bde Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 31 May 2023 19:40:40 +0200 Subject: [PATCH 07/77] Fix an error from migrating the old PR to current sources. --- src/Compiler/Checking/PostInferenceChecks.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index c52ac150cfe..552a935072f 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -959,10 +959,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = if not canTailCall then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)); - CheckExprNoByrefs { cenv with isTailCall = (IsTailCall.Yes true) } env f + () | _ -> - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env f + () | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = From b95a52b4f891ce089cdaf5b658ef9c0d69d02f7b Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 2 Jun 2023 00:49:11 +0200 Subject: [PATCH 08/77] As cenv is mutated in loops, doing "with" copies isn't that great as the failing CI shows. Making isTailCall also mutable is error prone as one has to switch back to orig values in many places. So refactor to use a flag like Avi did. This should fix the side effects (shown by the failing CI) and more tailrec specific tests --- src/Compiler/Checking/PostInferenceChecks.fs | 234 +++++++++--------- .../ErrorMessages/TailCallAttribute.fs | 16 ++ 2 files changed, 129 insertions(+), 121 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 552a935072f..f221326febe 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -250,9 +250,7 @@ type cenv = mutable entryPointGiven: bool /// Callback required for quotation generation - tcVal: ConstraintSolver.TcValF - - isTailCall: IsTailCall } + tcVal: ConstraintSolver.TcValF } override x.ToString() = "" @@ -798,11 +796,11 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | Some e -> errorR(e) /// Check an expression, where the expression is in a position where byrefs can be generated -let rec CheckExprNoByrefs cenv env expr = - CheckExpr cenv env expr PermitByRefExpr.No |> ignore +let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = + CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore /// Check a value -and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = +and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = if cenv.reportErrors then if isSpliceOperator cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)) @@ -820,7 +818,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) - if env.mustTailCall.Contains v.Deref && cenv.isTailCall = IsTailCall.No then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then @@ -829,7 +827,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = CheckTypeNoInnerByrefs cenv env m v.Type /// Check a use of a value -and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) = +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = let g = cenv.g @@ -874,12 +872,12 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB if isReturnOfStructThis then errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) - CheckValRef cenv env vref m ctxt + CheckValRef cenv env vref m ctxt isTailCall limit /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -923,11 +921,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> let canTailCall = - match cenv.isTailCall with + match isTailCall with | IsTailCall.No -> false | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then - let topValInfo = vref.ValReprInfo.Value let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty @@ -941,9 +938,9 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = match valUseFlags with | PossibleConstrainedCall _ -> true | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + not isNewObj && not isSuperInit && not isSelfInit && @@ -951,18 +948,14 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr = isNil laterArgs && not (IsValRefIsDllImport cenv.g vref) && not isCCall && - not hasByrefArg - + not hasByrefArg else true if not canTailCall then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)); - - () - - | _ -> + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) () + | _ -> () | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = @@ -1041,7 +1034,7 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = | [] -> PermitByRefExpr.No, [] | ctxt :: ctxts -> ctxt, ctxts - let receiverLimit = CheckExpr cenv env receiverArg receiverContext + let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No let limitArgs = let limitArgs = CheckExprs cenv env args ctxts // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. @@ -1052,12 +1045,12 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = limitArgs CheckCallLimitArgs cenv env m returnTy limitArgs ctxt -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) (isTailCall: IsTailCall) = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> - CheckExprNoByrefs cenv env e1 + CheckExprNoByrefs cenv env IsTailCall.No e1 // tailcall - CheckExprLinear cenv env e2 ctxt contf + CheckExprLinear cenv env e2 ctxt contf isTailCall | Expr.Let (TBind(v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type @@ -1072,31 +1065,31 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf BindVal cenv env v LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall - CheckExprLinear cenv env body ctxt contf + CheckExprLinear cenv env body ctxt contf isTailCall | LinearOpExpr (_op, tyargs, argsHead, argLast, m) -> CheckTypeInstNoByrefs cenv env m tyargs - argsHead |> List.iter (CheckExprNoByrefs cenv env) + argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) // tailcall - CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) + CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) isTailCall | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, m, ty) -> CheckTypeNoInnerByrefs cenv env m ty CheckDecisionTree cenv env dtree - let lim1 = CheckDecisionTreeTarget cenv env ctxt tg1 + let lim1 = CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) + CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) isTailCall | Expr.DebugPoint (_, innerExpr) -> - CheckExprLinear cenv env innerExpr ctxt contf + CheckExprLinear cenv env innerExpr ctxt contf isTailCall | _ -> // not a linear expression - contf (CheckExpr cenv env expr ctxt) + contf (CheckExpr cenv env expr ctxt isTailCall) /// Check a resumable code expression (the body of a ResumableCode delegate or /// the body of the MoveNextMethod for a state machine) -and TryCheckResumableCodeConstructs cenv env expr : bool = +and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : bool = let g = cenv.g match env.resumableCode with @@ -1106,63 +1099,63 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = | Resumable.ResumableExpr allowed -> match expr with | IfUseResumableStateMachinesExpr g (thenExpr, elseExpr) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } thenExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } elseExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } isTailCall thenExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall elseExpr true | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, _rebuild) -> if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) - CheckExprNoByrefs cenv env noneBranchExpr + CheckExprNoByrefs cenv env isTailCall noneBranchExpr BindVal cenv env someVar - CheckExprNoByrefs cenv env someBranchExpr + CheckExprNoByrefs cenv env isTailCall someBranchExpr true | ResumeAtExpr g pcExpr -> if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumeAt"), expr.Range)) - CheckExprNoByrefs cenv env pcExpr + CheckExprNoByrefs cenv env isTailCall pcExpr true | ResumableCodeInvoke g (_, f, args, _, _) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } f + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall f for arg in args do CheckExprPermitByRefLike cenv { env with resumableCode = Resumable.None } arg |> ignore true | SequentialResumableCode g (e1, e2, _m, _recreate) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr allowed }e1 - CheckExprNoByrefs cenv env e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr allowed } isTailCall e1 + CheckExprNoByrefs cenv env isTailCall e2 true | WhileExpr (_sp1, _sp2, guardExpr, bodyExpr, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } guardExpr - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall guardExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr true // Integer for-loops are allowed but their bodies are not currently resumable | IntegerForLoopExpr (_sp1, _sp2, _style, e1, e2, v, e3, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 BindVal cenv env v - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e3 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 true | TryWithExpr (_spTry, _spWith, _resTy, bodyExpr, _filterVar, filterExpr, _handlerVar, handlerExpr, _m) -> - CheckExprNoByrefs cenv env bodyExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } handlerExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } filterExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall handlerExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall filterExpr true | TryFinallyExpr (_sp1, _sp2, _ty, e1, e2, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 true | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> BindVals cenv env vs - CheckExprNoByrefs cenv env targetExpr) + CheckExprNoByrefs cenv env isTailCall targetExpr) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree true @@ -1171,13 +1164,13 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore BindVal cenv env bind.Var - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr true // LetRec bindings may not appear as part of resumable code (more careful work is needed to make them compilable) | Expr.LetRec(_bindings, bodyExpr, _range, _frees) when allowed -> errorR(Error(FSComp.SR.tcResumableCodeContainsLetRec(), expr.Range)) - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr true // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match @@ -1185,13 +1178,13 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = true | Expr.DebugPoint (_, innerExpr) -> - TryCheckResumableCodeConstructs cenv env innerExpr + TryCheckResumableCodeConstructs cenv env innerExpr isTailCall | _ -> false /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = +and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : Limit = // Guard the stack for deeply nested expressions cenv.stackGuard.Guard <| fun () -> @@ -1201,11 +1194,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr - match TryCheckResumableCodeConstructs cenv env expr with + match TryCheckResumableCodeConstructs cenv env expr isTailCall with | true -> // we've handled the special cases of resumable code and don't do other checks. NoLimit @@ -1220,11 +1213,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) | Expr.DebugPoint _ -> - CheckExprLinear cenv env expr ctxt id + CheckExprLinear cenv env expr ctxt id isTailCall | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e1 - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 + CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env IsTailCall.No e2 NoLimit | Expr.Const (_, m, ty) -> @@ -1232,7 +1225,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = NoLimit | Expr.Val (vref, vFlags, m) -> - CheckValUse cenv env (vref, vFlags, m) ctxt + CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> CheckQuoteExpr cenv env (ast, savedConv, m, ty) @@ -1241,7 +1234,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = CheckStructStateMachineExpr cenv env expr info | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr { cenv with isTailCall = IsTailCall.No } env (ty, basev, superInitCall, overrides, iimpls, m) + CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) @@ -1273,24 +1266,24 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = // Check an application | Expr.App (f, _fty, tyargs, argsl, m) -> - CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt + CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> - CheckLambda cenv env expr (argvs, m, bodyTy) + CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall | Expr.TyLambda (_, tps, _, m, bodyTy) -> - CheckTyLambda cenv env expr (tps, m, bodyTy) + CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall | Expr.TyChoose (tps, e1, _) -> let env = BindTypars g env tps - CheckExprNoByrefs cenv env e1 + CheckExprNoByrefs cenv env isTailCall e1 NoLimit | Expr.Match (_, _, dtree, targets, m, ty) -> - CheckMatch cenv env ctxt (dtree, targets, m, ty) + CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall | Expr.LetRec (binds, bodyExpr, _, _) -> - CheckLetRec cenv env (binds, bodyExpr) + CheckLetRec cenv env (binds, bodyExpr) isTailCall | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) @@ -1303,7 +1296,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = and CheckQuoteExpr cenv env (ast, savedConv, m, ty) = let g = cenv.g - CheckExprNoByrefs cenv {env with quote=true} ast + CheckExprNoByrefs cenv {env with quote=true} IsTailCall.No ast if cenv.reportErrors then cenv.usesQuotations <- true @@ -1340,14 +1333,14 @@ and CheckStructStateMachineExpr cenv env expr info = error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } moveNextExpr - CheckExprNoByrefs cenv env setStateMachineBody - CheckExprNoByrefs cenv env afterCodeBody + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr + CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody + CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody NoLimit and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) = let g = cenv.g - CheckExprNoByrefs cenv env superInitCall + CheckExprNoByrefs cenv env IsTailCall.No superInitCall CheckMethods cenv env basev (ty, overrides) CheckInterfaceImpls cenv env basev iimpls CheckTypeNoByrefs cenv env m ty @@ -1372,8 +1365,8 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = let env = { env with isInAppExpr = true } let returnTy = tyOfExpr g expr - CheckValRef cenv env v m PermitByRefExpr.No - CheckValRef cenv env baseVal m PermitByRefExpr.No + CheckValRef cenv env v m PermitByRefExpr.No IsTailCall.No + CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckTypeInstNoByrefs cenv env m tyargs CheckTypeNoInnerByrefs cenv env m returnTy CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) @@ -1398,15 +1391,15 @@ and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyarg CheckTypeInstNoByrefs cenv env m enclTypeInst CheckTypeInstNoByrefs cenv env m methInst CheckTypeInstNoByrefs cenv env m retTypes - CheckValRef cenv env baseVal m PermitByRefExpr.No + CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprsPermitByRefLike cenv env rest and CheckSpliceApplication cenv env (tinst, arg, m) = CheckTypeInstNoInnerByrefs cenv env m tinst // it's the splice operator, a byref instantiation is allowed - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env arg + CheckExprNoByrefs cenv env IsTailCall.No arg NoLimit -and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = +and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt (isTailCall: IsTailCall) = let g = cenv.g match expr with | ResumableCodeInvoke g _ -> @@ -1422,7 +1415,7 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = let env = { env with isInAppExpr = true } CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env f + CheckExprNoByrefs cenv env isTailCall f let hasReceiver = match f with @@ -1435,30 +1428,30 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = else CheckCall cenv env m returnTy argsl ctxts ctxt -and CheckLambda cenv env expr (argvs, m, bodyTy) = +and CheckLambda cenv env expr (argvs, m, bodyTy) (isTailCall: IsTailCall) = let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in - CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) = +and CheckTyLambda cenv env expr (tps, m, bodyTy) (isTailCall: IsTailCall) = let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) let ty = mkForallTyIfNeeded tps bodyTy in - CheckLambdas false None { cenv with isTailCall = cenv.isTailCall.AtExprLambda } env false valReprInfo false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, m, ty) = +and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch CheckDecisionTree cenv env dtree - CheckDecisionTreeTargets cenv env targets ctxt + CheckDecisionTreeTargets cenv env targets ctxt isTailCall -and CheckLetRec cenv env (binds, bodyExpr) = +and CheckLetRec cenv env (binds, bodyExpr) isTailCall = BindVals cenv env (valsOfBinds binds) CheckBindings cenv env binds - CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv env isTailCall bodyExpr NoLimit and CheckStaticOptimization cenv env (constraints, e2, e3, m) = - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e3 + CheckExprNoByrefs cenv env IsTailCall.No e2 + CheckExprNoByrefs cenv env IsTailCall.No e3 constraints |> List.iter (function | TTyconEqualsTycon(ty1, ty2) -> CheckTypeNoByrefs cenv env m ty1 @@ -1485,7 +1478,7 @@ and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, body CheckAttribs cenv env attribs CheckNoReraise cenv None body CheckEscapes cenv true m (match baseValOpt with Some x -> x :: vs | None -> vs) body |> ignore - CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal |> ignore + CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -1522,8 +1515,8 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/finally can be a byref - let limit = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/finally can be a byref if in a position where the overall expression is can be a byref - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e2 + let limit = CheckExpr cenv env e1 ctxt IsTailCall.No // result of a try/finally can be a byref if in a position where the overall expression is can be a byref + CheckExprNoByrefs cenv env IsTailCall.No e2 limit | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> @@ -1532,9 +1525,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/catch can be a byref - let limit1 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e1 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit1 = CheckExpr cenv env e1 ctxt IsTailCall.No // result of a try/catch can be a byref if in a position where the overall expression is can be a byref // [(* e2; -- don't check filter body - duplicates logic in 'catch' body *) e3] - let limit2 = CheckExpr { cenv with isTailCall = IsTailCall.No } env e3 ctxt // result of a try/catch can be a byref if in a position where the overall expression is can be a byref + let limit2 = CheckExpr cenv env e3 ctxt IsTailCall.No // result of a try/catch can be a byref if in a position where the overall expression is can be a byref CombineTwoLimits limit1 limit2 | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), _, _ -> @@ -1656,10 +1649,10 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.Coerce, [tgtTy;srcTy], [x] -> if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr { cenv with isTailCall = IsTailCall.No } env x ctxt + CheckExpr cenv env x ctxt IsTailCall.No else - CheckTypeInstNoByrefs { cenv with isTailCall = IsTailCall.No } env m tyargs - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env x + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprNoByrefs cenv env IsTailCall.No x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -1694,7 +1687,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckTypeInstNoByrefs cenv env m tyargs // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt + CheckExpr cenv env obj ctxt IsTailCall.No | TOp.UnionCaseFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs @@ -1715,7 +1708,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckTypeInstNoByrefs cenv env m tyargs // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt + CheckExpr cenv env obj ctxt IsTailCall.No | TOp.ILAsm (instrs, retTypes), _, _ -> CheckTypeInstNoInnerByrefs cenv env m retTypes @@ -1724,7 +1717,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // Write a .NET instance field | [ I_stfld (_alignment, _vol, _fspec) ], _ -> match args with - | [ _; rhs ] -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env rhs + | [ _; rhs ] -> CheckExprNoByrefs cenv env IsTailCall.No rhs | _ -> () // permit byref for lhs lvalue @@ -1752,7 +1745,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(fspec.Name), m)) // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt + CheckExpr cenv env obj ctxt IsTailCall.No | [ I_ldelema (_, isNativePtr, _, _) ], lhsArray :: indices -> if ctxt.Disallow && cenv.reportErrors && not isNativePtr && isByrefLikeTy g m (tyOfExpr g expr) then @@ -1782,7 +1775,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckTypeInstNoByrefs cenv env m tyargs CheckExprsNoByRefLike cenv env args -and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwaysCheckNoReraise expr mOrig ety ctxt = +and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) @@ -1791,7 +1784,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa match stripDebugPoints expr with | Expr.TyChoose (tps, e1, m) -> let env = BindTypars g env tps - CheckLambdas isTop memberVal cenv env inlined valReprInfo alwaysCheckNoReraise e1 m ety ctxt + CheckLambdas isTop memberVal cenv env inlined valReprInfo isTailCall alwaysCheckNoReraise e1 m ety ctxt | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> @@ -1853,7 +1846,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa // allow byref to occur as return position for byref-typed top level function or method CheckExprPermitReturnableByRef cenv env body |> ignore else - CheckExprNoByrefs cenv env body + CheckExprNoByrefs cenv env isTailCall body // Check byref return types if cenv.reportErrors then @@ -1881,9 +1874,9 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa let limit = if not inlined && (isByrefLikeTy g m ety || isNativePtrTy g ety) then // allow byref to occur as RHS of byref binding. - CheckExpr cenv env expr ctxt + CheckExpr cenv env expr ctxt isTailCall else - CheckExprNoByrefs cenv env expr + CheckExprNoByrefs cenv env isTailCall expr NoLimit if alwaysCheckNoReraise then @@ -1894,12 +1887,12 @@ and CheckExprs cenv env exprs ctxts : Limit = let ctxts = Array.ofList ctxts let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No exprs - |> List.mapi (fun i exp -> CheckExpr { cenv with isTailCall = IsTailCall.No } env exp (argArity i)) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) IsTailCall.No) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr + CheckExprNoByrefs cenv env IsTailCall.No expr NoLimit and CheckExprsPermitByRefLike cenv env exprs : Limit = @@ -1908,22 +1901,22 @@ and CheckExprsPermitByRefLike cenv env exprs : Limit = |> CombineLimits and CheckExprPermitByRefLike cenv env expr : Limit = - CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.Yes + CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No and CheckExprPermitReturnableByRef cenv env expr : Limit = - CheckExpr { cenv with isTailCall = IsTailCall.No } env expr PermitByRefExpr.YesReturnable + CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No -and CheckDecisionTreeTargets cenv env targets ctxt = +and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = targets - |> Array.map (CheckDecisionTreeTarget cenv env ctxt) + |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) |> List.ofArray |> CombineLimits -and CheckDecisionTreeTarget cenv env ctxt (TTarget(vs, targetExpr, _)) = +and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = BindVals cenv env vs for v in vs do CheckValSpec PermitByRefType.All cenv env v - CheckExpr cenv env targetExpr ctxt + CheckExpr cenv env targetExpr ctxt isTailCall and CheckDecisionTree cenv env dtree = match dtree with @@ -1949,7 +1942,7 @@ and CheckDecisionTreeTest cenv env m discrim = | DecisionTreeTest.Const _ -> () | DecisionTreeTest.IsNull -> () | DecisionTreeTest.IsInst (srcTy, tgtTy) -> CheckTypeNoInnerByrefs cenv env m srcTy; CheckTypeNoInnerByrefs cenv env m tgtTy - | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env IsTailCall.No exp | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = @@ -1959,8 +1952,8 @@ and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = args |> List.iter (CheckAttribExpr cenv env) and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env expr - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env vexpr + CheckExprNoByrefs cenv env IsTailCall.No expr + CheckExprNoByrefs cenv env IsTailCall.No vexpr CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr @@ -2176,7 +2169,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin else env - CheckLambdas isTop (Some v) {cenv with isTailCall = isTailCall } env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = for bind in binds do @@ -2671,7 +2664,7 @@ and CheckDefnInModule cenv env mdef = | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs { cenv with isTailCall = IsTailCall.No } env e + CheckExprNoByrefs cenv env IsTailCall.No e | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env mbind = @@ -2708,8 +2701,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v isLastCompiland = isLastCompiland isInternalTestSpanStackReferring = isInternalTestSpanStackReferring tcVal = tcValF - entryPointGiven = false - isTailCall = IsTailCall.No } + entryPointGiven = false } // Certain type equality checks go faster if these TyconRefs are pre-resolved. // This is because pre-resolving allows tycon equality to be determined by pointer equality on the entities. diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 5c9cfbde3a9..c75e7d7e151 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -145,6 +145,22 @@ and [] baz x = |> FSharp |> typecheck |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 13 + StartColumn = 9 + EndLine = 13 + EndColumn = 20 } + Message = + "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 13 + StartColumn = 9 + EndLine = 13 + EndColumn = 12 } + Message = + "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] [] let ``Warn successfully for invalid tailcall in type method`` () = From 2abeb9ed96bca5d8bf763a892faf21c085dbf59e Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 2 Jun 2023 12:38:30 +0200 Subject: [PATCH 09/77] update baselines for FSharp.Core to include TailCallAttribute --- .../FSharp.Core.SurfaceArea.netstandard20.debug.bsl | 1 + .../FSharp.Core.SurfaceArea.netstandard20.release.bsl | 1 + .../FSharp.Core.SurfaceArea.netstandard21.debug.bsl | 1 + .../FSharp.Core.SurfaceArea.netstandard21.release.bsl | 1 + 4 files changed, 4 insertions(+) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index e373ae3440b..e677bf9a8c7 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -2042,6 +2042,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index e314c7263a2..0e8c47b4a88 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -2041,6 +2041,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index 29f826a24ba..20941451236 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -2043,6 +2043,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index 5114bd40b1d..36284cfb987 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -2042,6 +2042,7 @@ Microsoft.FSharp.Core.StructuralEqualityAttribute: Void .ctor() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String Value Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: System.String get_Value() Microsoft.FSharp.Core.StructuredFormatDisplayAttribute: Void .ctor(System.String) +Microsoft.FSharp.Core.TailCallAttribute: Void .ctor() Microsoft.FSharp.Core.Unit: Boolean Equals(System.Object) Microsoft.FSharp.Core.Unit: Int32 GetHashCode() Microsoft.FSharp.Core.UnverifiableAttribute: Void .ctor() From e2c1e52e24a84bae5ae0c5b6f9ce821f266c4cca Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 5 Jun 2023 12:17:14 +0200 Subject: [PATCH 10/77] warn for rec call in binding, still very WIP --- src/Compiler/Checking/PostInferenceChecks.fs | 34 +++++++++++++------ .../ErrorMessages/TailCallAttribute.fs | 24 ++++++------- 2 files changed, 34 insertions(+), 24 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index f221326febe..e4070a64482 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2140,16 +2140,30 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () - let _topValInfo, isVoidRet = - match bind.Var.ValReprInfo with - | Some info -> - let _tps, tau = destTopForallTy g info v.Type - let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range - info, isUnitTy g returnTy - | None -> - ValReprInfo.emptyValData, false - - let isTailCall = IsTailCall.AtMethodOrFunction isVoidRet + let isTailCall = + let isVoidRet = + match bind.Var.ValReprInfo with + | Some info -> + let _tps, tau = destTopForallTy g info v.Type + let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range + isUnitTy g returnTy + | None -> false + IsTailCall.AtMethodOrFunction isVoidRet + + match bindRhs with + | Expr.App(_funcExpr, _formalType, _typeArgs, _exprs, _range) -> + let rec checkTailCall expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if not isTop && env.mustTailCall.Contains valRef.Deref then // ToDo: tighter check needed for bindings inside of functions + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall funcExpr + exprs |> List.iter checkTailCall + | Expr.Link exprRef -> checkTailCall exprRef.Value + | _ -> () + checkTailCall _funcExpr + | _ -> () let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index c75e7d7e151..264c078b652 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -78,7 +78,7 @@ let rec fact n acc = match n with | 0 -> acc | _ -> - let r = (fact (n-1) (mul n acc)) + let r = fact (n-1) (mul n acc) r + 23 """ |> FSharp @@ -86,23 +86,16 @@ let rec fact n acc = |> shouldFail |> withResults [ { Error = Warning 3567 - Range = { StartLine = 8 - StartColumn = 13 - EndLine = 8 - EndColumn = 35 } - Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 - Range = { StartLine = 8 - StartColumn = 13 - EndLine = 8 - EndColumn = 17 } + Range = { StartLine = 9 + StartColumn = 17 + EndLine = 9 + EndColumn = 21 } Message = "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] - let ``Don't warn for valid tailcall`` () = + let ``Don't warn for valid tailcall and bind from toplevel`` () = """ let mul x y = x * y @@ -110,7 +103,10 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else (fact (n-1) (mul n acc)) + else fact (n-1) (mul n acc) + +let r = fact 100000 1 +r |> ignore """ |> FSharp |> typecheck From 969cd099a59baa5b220f8bc17b7d28d319cae080 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 6 Jun 2023 09:38:36 +0200 Subject: [PATCH 11/77] - improve check for problematic bindings to tailcall attributed functions - add tests --- src/Compiler/Checking/PostInferenceChecks.fs | 48 +++++++++++-------- .../ErrorMessages/TailCallAttribute.fs | 43 +++++++++++++++++ 2 files changed, 71 insertions(+), 20 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index e4070a64482..d5d32197534 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2150,21 +2150,6 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | None -> false IsTailCall.AtMethodOrFunction isVoidRet - match bindRhs with - | Expr.App(_funcExpr, _formalType, _typeArgs, _exprs, _range) -> - let rec checkTailCall expr = - match expr with - | Expr.Val(valRef, _valUseFlag, m) -> - if not isTop && env.mustTailCall.Contains valRef.Deref then // ToDo: tighter check needed for bindings inside of functions - warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - checkTailCall funcExpr - exprs |> List.iter checkTailCall - | Expr.Link exprRef -> checkTailCall exprRef.Value - | _ -> () - checkTailCall _funcExpr - | _ -> () - let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline @@ -2190,7 +2175,7 @@ and CheckBindings cenv env binds = CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore // Top binds introduce expression, check they are reraise free. -let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = +let CheckModuleBinding cenv env (isRec: bool) (TBind(v, e, _) as bind) = let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then @@ -2199,6 +2184,29 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) + match bind.Expr with + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + let rec checkTailCall (insideSubBinding: bool) expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall insideSubBinding funcExpr + exprs |> List.iter (checkTailCall insideSubBinding) + | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + checkTailCall insideSubBinding bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let(binding, bodyExpr, _range, _frees) -> + checkTailCall true binding.Expr + checkTailCall insideSubBinding bodyExpr + | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | _ -> () + checkTailCall false bodyExpr + | _ -> () + // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields not v.IsMutable && @@ -2668,10 +2676,10 @@ and CheckDefnInModule cenv env mdef = CheckNothingAfterEntryPoint cenv m if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) CheckEntityDefns cenv env tycons - List.iter (CheckModuleSpec cenv env) mspecs + List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m - CheckModuleBinding cenv env bind + CheckModuleBinding cenv env false bind BindVal cenv env bind.Var | TMDefOpens _ -> () @@ -2681,11 +2689,11 @@ and CheckDefnInModule cenv env mdef = CheckExprNoByrefs cenv env IsTailCall.No e | TMDefs defs -> CheckDefnsInModule cenv env defs -and CheckModuleSpec cenv env mbind = +and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> BindVals cenv env (valsOfBinds [bind]) - CheckModuleBinding cenv env bind + CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 264c078b652..016c435b8a0 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -236,3 +236,46 @@ type F () = Message = "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for valid tailcall and bind from nested bind`` () = + """ +let mul x y = x * y + +[] +let rec fact n acc = + if n = 0 + then acc + else fact (n-1) (mul n acc) + +let f () = + let r = fact 100000 1 + r |> ignore + """ + |> FSharp + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in seq expression`` () = + """ +[] +let rec f x : seq = + seq { + let r = f (x-1) // Warning: this call is not tail-recursive + let r2 = Seq.map (fun x -> x + 1) r + yield! r2 +} + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 17 + EndLine = 5 + EndColumn = 18 } + Message = + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] From f928d1a34b43bba1c7d0c85c4beb0fe6e3e5f7d8 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 6 Jun 2023 16:02:26 +0200 Subject: [PATCH 12/77] improve seq support --- src/Compiler/Checking/PostInferenceChecks.fs | 32 ++++++++------- .../ErrorMessages/TailCallAttribute.fs | 41 ++++++++++++++++++- 2 files changed, 58 insertions(+), 15 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index d5d32197534..68e0080dccc 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -197,8 +197,20 @@ type IsTailCall = | Yes of bool // true indicates "has unit return type and must return void" | No - static member AtMethodOrFunction isVoidRet = - IsTailCall.Yes isVoidRet + static member private IsVoidRet (g: TcGlobals) (v: Val) = + match v.ValReprInfo with + | Some info -> + let _tps, tau = destTopForallTy g info v.Type + let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm g info.ArgInfos tau v.Range + isUnitTy g returnTy + | None -> false + + static member fromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) + + static member fromExpr (g: TcGlobals) (expr: Expr) = + match expr with + | Expr.Val(valRef, _valUseFlag, _range) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) + | _ -> IsTailCall.Yes false member x.AtExprLambda = match x with @@ -1648,11 +1660,12 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = NoLimit | TOp.Coerce, [tgtTy;srcTy], [x] -> + let isTailCall = IsTailCall.fromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt IsTailCall.No + CheckExpr cenv env x ctxt isTailCall else CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env IsTailCall.No x + CheckExprNoByrefs cenv env isTailCall x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -2140,16 +2153,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () - let isTailCall = - let isVoidRet = - match bind.Var.ValReprInfo with - | Some info -> - let _tps, tau = destTopForallTy g info v.Type - let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g info.ArgInfos tau v.Range - isUnitTy g returnTy - | None -> false - IsTailCall.AtMethodOrFunction isVoidRet - + let isTailCall = IsTailCall.fromVal g bind.Var let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 016c435b8a0..48c5a39590c 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -257,7 +257,7 @@ let f () = |> shouldSucceed [] - let ``Warn for invalid tailcalls in seq expression`` () = + let ``Warn for invalid tailcalls in seq expression because of bind`` () = """ [] let rec f x : seq = @@ -279,3 +279,42 @@ let rec f x : seq = Message = "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Warn for invalid tailcalls in seq expression because of pipe`` () = + """ +[] +let rec f x : seq = + seq { + yield! f (x-1) |> Seq.map (fun x -> x + 1) +} + """ + |> FSharp + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 16 + EndLine = 5 + EndColumn = 23 } + Message = + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 5 + StartColumn = 16 + EndLine = 5 + EndColumn = 17 } + Message = + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + ] + + [] + let ``Don't warn for valid tailcalls in seq expression`` () = + """ +[] +let rec f x = seq { yield! f (x-1) } + """ + |> FSharp + |> typecheck + |> shouldSucceed From 05b0e117e83244cca461734c632df80be7cfa4bc Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 6 Jun 2023 17:09:35 +0200 Subject: [PATCH 13/77] add language version flag --- src/Compiler/Checking/PostInferenceChecks.fs | 131 +++++++++--------- src/Compiler/FSComp.txt | 1 + src/Compiler/Facilities/LanguageFeatures.fs | 3 + src/Compiler/Facilities/LanguageFeatures.fsi | 1 + src/Compiler/xlf/FSComp.txt.cs.xlf | 9 +- src/Compiler/xlf/FSComp.txt.de.xlf | 9 +- src/Compiler/xlf/FSComp.txt.es.xlf | 9 +- src/Compiler/xlf/FSComp.txt.fr.xlf | 9 +- src/Compiler/xlf/FSComp.txt.it.xlf | 9 +- src/Compiler/xlf/FSComp.txt.ja.xlf | 9 +- src/Compiler/xlf/FSComp.txt.ko.xlf | 9 +- src/Compiler/xlf/FSComp.txt.pl.xlf | 9 +- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 9 +- src/Compiler/xlf/FSComp.txt.ru.xlf | 9 +- src/Compiler/xlf/FSComp.txt.tr.xlf | 9 +- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 9 +- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 9 +- .../ErrorMessages/TailCallAttribute.fs | 40 ++++-- 18 files changed, 189 insertions(+), 104 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 68e0080dccc..6969e94442f 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -830,8 +830,9 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then - warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then + warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then CheckTypePermitAllByrefs cenv env m v.Type // we do checks for byrefs elsewhere @@ -929,46 +930,47 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i | _ -> () | _ -> () - match f with - | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - - let canTailCall = - match isTailCall with - | IsTailCall.No -> false - | IsTailCall.Yes isVoidRet -> - if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then - let topValInfo = vref.ValReprInfo.Value - let (nowArgs, laterArgs), returnTy = - let _tps, tau = destTopForallTy g topValInfo _fty - let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m - if argsl.Length >= curriedArgInfos.Length then - (List.splitAfter curriedArgInfos.Length argsl), returnTy - else - ([], argsl), returnTy - let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) - let isCCall = - match valUseFlags with - | PossibleConstrainedCall _ -> true - | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) - let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) - - not isNewObj && - not isSuperInit && - not isSelfInit && - not mustGenerateUnitAfterCall && - isNil laterArgs && - not (IsValRefIsDllImport cenv.g vref) && - not isCCall && - not hasByrefArg - else - true - - if not canTailCall then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - () - | _ -> () - | _ -> () + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match f with + | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> + + let canTailCall = + match isTailCall with + | IsTailCall.No -> false + | IsTailCall.Yes isVoidRet -> + if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then + let topValInfo = vref.ValReprInfo.Value + let (nowArgs, laterArgs), returnTy = + let _tps, tau = destTopForallTy g topValInfo _fty + let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m + if argsl.Length >= curriedArgInfos.Length then + (List.splitAfter curriedArgInfos.Length argsl), returnTy + else + ([], argsl), returnTy + let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) + let isCCall = + match valUseFlags with + | PossibleConstrainedCall _ -> true + | _ -> false + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) + let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + else + true + + if not canTailCall then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + () + | _ -> () + | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = let isReturnByref = isByrefTy cenv.g returnTy @@ -2188,28 +2190,29 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(v, e, _) as bind) = if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) - match bind.Expr with - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - let rec checkTailCall (insideSubBinding: bool) expr = - match expr with - | Expr.Val(valRef, _valUseFlag, m) -> - if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then - warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - checkTailCall insideSubBinding funcExpr - exprs |> List.iter (checkTailCall insideSubBinding) - | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - checkTailCall insideSubBinding bodyExpr - | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr - | Expr.Let(binding, bodyExpr, _range, _frees) -> - checkTailCall true binding.Expr - checkTailCall insideSubBinding bodyExpr - | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> - decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) - | _ -> () - checkTailCall false bodyExpr - | _ -> () + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match bind.Expr with + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + let rec checkTailCall (insideSubBinding: bool) expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall insideSubBinding funcExpr + exprs |> List.iter (checkTailCall insideSubBinding) + | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + checkTailCall insideSubBinding bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let(binding, bodyExpr, _range, _frees) -> + checkTailCall true binding.Expr + checkTailCall insideSubBinding bodyExpr + | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | _ -> () + checkTailCall false bodyExpr + | _ -> () // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 4963a12d9a9..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." 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/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index bd4c35f46c3..c95ba93baf4 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Povolit implicitní atribut Extension pro deklarující typy, moduly + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption využití člena výchozího rozhraní diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index a4807cf4acf..84660c3b83f 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Implizites Erweiterungsattribut für deklarierende Typen und Module zulassen + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption standardmäßige Schnittstellenmembernutzung diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index ae5df78558e..769b175806e 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Permitir atributo Extension implícito en tipos declarativo, módulos + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption consumo de miembros de interfaz predeterminados diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index df1ac5c2917..3fcf9e4f979 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Autoriser l’attribut implicite Extension lors de la déclaration des types, modules + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption consommation par défaut des membres d'interface diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 2846aa3ee2d..54b5d66292b 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Consentire l'attributo estensione implicito per i tipi dichiarabili, i moduli + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption utilizzo predefinito dei membri di interfaccia diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 33fd02862eb..1d8dbf2c659 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 型、モジュールの宣言で暗黙的な拡張属性を許可する + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 既定のインターフェイス メンバーの消費 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 9879986d75f..ef858689453 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 유형, 모듈 선언에 암시적 확장 속성 허용 + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 기본 인터페이스 멤버 사용 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 48f510bece4..edc9601a01b 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Zezwalaj na niejawny atrybut Rozszerzenie dla deklarujących typów, modułów + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption domyślne użycie składowej interfejsu diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index f483b56b8ce..03603414217 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Permitir atributo de Extensão implícito em tipos declarativos, módulos + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption consumo de membro da interface padrão diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 69591c60e4b..8ca7a0b8908 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Разрешить атрибут неявного расширения для объявляющих типов, модулей + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption использование элемента интерфейса по умолчанию diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 8fcac975c6c..f635562b788 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ Türler, modüller bildirirken örtük Extension özniteliğine izin ver + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption varsayılan arabirim üyesi tüketimi diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 7759137ab4c..b3f86482576 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 允许对声明类型、模块使用隐式扩展属性 + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 默认接口成员消耗 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 5759c1d906c..eda95e350e0 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. - The member or function '{0}' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. + The member or function '{0}' has the 'TailCall' attribute, but is not being used in a tail recursive way. @@ -212,6 +212,11 @@ 允許宣告類型、模組上的隱含擴充屬性 + + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + Raises warnings if a member or function has the 'TailCall' attribute, but is not being used in a tail recursive way. + + default interface member consumption 預設介面成員使用 diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 48c5a39590c..7b4e90e52ad 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -2,7 +2,6 @@ namespace FSharp.Compiler.ComponentTests.ErrorMessages open FSharp.Test.Compiler open FSharp.Test.Compiler.Assertions.StructuredResultsAsserts -open Xunit module ``TailCall Attribute`` = @@ -18,6 +17,7 @@ let rec fact n acc = else (fact (n-1) (mul n acc)) + 23 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -27,14 +27,14 @@ let rec fact n acc = EndLine = 8 EndColumn = 33 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 15 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -49,6 +49,7 @@ let rec fact n acc = | _ -> (fact (n-1) (mul n acc)) + 23 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -58,14 +59,14 @@ let rec fact n acc = EndLine = 8 EndColumn = 35 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 17 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -82,6 +83,7 @@ let rec fact n acc = r + 23 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -91,7 +93,7 @@ let rec fact n acc = EndLine = 9 EndColumn = 21 } Message = - "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -109,6 +111,7 @@ let r = fact 100000 1 r |> ignore """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -139,6 +142,7 @@ and [] baz x = bar (x - 1) // OK: tail-recursive call. """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -148,14 +152,14 @@ and [] baz x = EndLine = 13 EndColumn = 20 } Message = - "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 EndColumn = 12 } Message = - "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -166,6 +170,7 @@ type C () = member this.M1() = this.M1() + 1 """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -175,7 +180,7 @@ type C () = EndLine = 4 EndColumn = 33 } Message = - "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -186,6 +191,7 @@ type C () = member this.M1() = this.M1() """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -202,6 +208,7 @@ type C () = this.M1() // ok """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -218,6 +225,7 @@ type F () = this.M1() + 2 // should warn """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -227,14 +235,14 @@ type F () = EndLine = 5 EndColumn = 18 } Message = - "The member or function 'M2' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 9 StartColumn = 9 EndLine = 9 EndColumn = 18 } Message = - "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -253,6 +261,7 @@ let f () = r |> ignore """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed @@ -268,6 +277,7 @@ let rec f x : seq = } """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -277,7 +287,7 @@ let rec f x : seq = EndLine = 5 EndColumn = 18 } Message = - "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -290,6 +300,7 @@ let rec f x : seq = } """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldFail |> withResults [ @@ -299,14 +310,14 @@ let rec f x : seq = EndLine = 5 EndColumn = 23 } Message = - "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 EndColumn = 17 } Message = - "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -316,5 +327,6 @@ let rec f x : seq = let rec f x = seq { yield! f (x-1) } """ |> FSharp + |> withLangVersionPreview |> typecheck |> shouldSucceed From 1412beb07806c6c6a0f51894652e5ce2b64043c6 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 7 Jun 2023 09:30:09 +0200 Subject: [PATCH 14/77] improve tests a bit --- .../ErrorMessages/TailCallAttribute.fs | 46 ++++++++++++------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 7b4e90e52ad..4b4fec43620 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -14,7 +14,7 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else (fact (n-1) (mul n acc)) + 23 + else (fact (n - 1) (mul n acc)) + 23 """ |> FSharp |> withLangVersionPreview @@ -25,7 +25,7 @@ let rec fact n acc = Range = { StartLine = 8 StartColumn = 11 EndLine = 8 - EndColumn = 33 } + EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 @@ -46,7 +46,7 @@ let mul x y = x * y let rec fact n acc = match n with | 0 -> acc - | _ -> (fact (n-1) (mul n acc)) + 23 + | _ -> (fact (n - 1) (mul n acc)) + 23 """ |> FSharp |> withLangVersionPreview @@ -57,7 +57,7 @@ let rec fact n acc = Range = { StartLine = 8 StartColumn = 13 EndLine = 8 - EndColumn = 35 } + EndColumn = 37 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 @@ -79,7 +79,7 @@ let rec fact n acc = match n with | 0 -> acc | _ -> - let r = fact (n-1) (mul n acc) + let r = fact (n - 1) (mul n acc) r + 23 """ |> FSharp @@ -105,7 +105,9 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else fact (n-1) (mul n acc) + else + printfn "%A" n + fact (n - 1) (mul n acc) let r = fact 100000 1 r |> ignore @@ -188,7 +190,9 @@ type C () = """ type C () = [] - member this.M1() = this.M1() + member this.M1() = + printfn "M1 called" + this.M1() """ |> FSharp |> withLangVersionPreview @@ -201,10 +205,12 @@ type C () = type C () = [] member this.M1() = + printfn "M1 called" this.M2() // ok [] member this.M2() = + printfn "M2 called" this.M1() // ok """ |> FSharp @@ -218,10 +224,12 @@ type C () = type F () = [] member this.M1() = + printfn "M1 called" this.M2() + 1 // should warn [] member this.M2() = + printfn "M2 called" this.M1() + 2 // should warn """ |> FSharp @@ -230,16 +238,16 @@ type F () = |> shouldFail |> withResults [ { Error = Warning 3567 - Range = { StartLine = 5 + Range = { StartLine = 6 StartColumn = 9 - EndLine = 5 + EndLine = 6 EndColumn = 18 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 - Range = { StartLine = 9 + Range = { StartLine = 11 StartColumn = 9 - EndLine = 9 + EndLine = 11 EndColumn = 18 } Message = "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } @@ -254,7 +262,9 @@ let mul x y = x * y let rec fact n acc = if n = 0 then acc - else fact (n-1) (mul n acc) + else + printfn "%A" n + fact (n - 1) (mul n acc) let f () = let r = fact 100000 1 @@ -271,7 +281,7 @@ let f () = [] let rec f x : seq = seq { - let r = f (x-1) // Warning: this call is not tail-recursive + let r = f (x - 1) let r2 = Seq.map (fun x -> x + 1) r yield! r2 } @@ -296,7 +306,7 @@ let rec f x : seq = [] let rec f x : seq = seq { - yield! f (x-1) |> Seq.map (fun x -> x + 1) + yield! f (x - 1) |> Seq.map (fun x -> x + 1) } """ |> FSharp @@ -308,7 +318,7 @@ let rec f x : seq = Range = { StartLine = 5 StartColumn = 16 EndLine = 5 - EndColumn = 23 } + EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 @@ -324,7 +334,11 @@ let rec f x : seq = let ``Don't warn for valid tailcalls in seq expression`` () = """ [] -let rec f x = seq { yield! f (x-1) } +let rec f x = seq { + let y = x - 1 + let z = y - 1 + yield! f (z - 1) +} """ |> FSharp |> withLangVersionPreview From 247e06d1b2f3b347ff3035aaa84c7b465bded644 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 7 Jun 2023 12:36:24 +0200 Subject: [PATCH 15/77] add tests for async expressions --- src/Compiler/Checking/PostInferenceChecks.fs | 18 ++++---- .../ErrorMessages/TailCallAttribute.fs | 41 +++++++++++++++++++ 2 files changed, 50 insertions(+), 9 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 6969e94442f..e0f9f1872b4 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -205,9 +205,9 @@ type IsTailCall = isUnitTy g returnTy | None -> false - static member fromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) + static member YesFromVal (g: TcGlobals) (v: Val) = IsTailCall.Yes (IsTailCall.IsVoidRet g v) - static member fromExpr (g: TcGlobals) (expr: Expr) = + static member YesFromExpr (g: TcGlobals) (expr: Expr) = match expr with | Expr.Val(valRef, _valUseFlag, _range) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) | _ -> IsTailCall.Yes false @@ -1034,7 +1034,7 @@ and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = /// Check call arguments, including the return argument. and CheckCall cenv env m returnTy args ctxts ctxt = - let limitArgs = CheckExprs cenv env args ctxts + let limitArgs = CheckExprs cenv env args ctxts IsTailCall.No CheckCallLimitArgs cenv env m returnTy limitArgs ctxt /// Check call arguments, including the return argument. The receiver argument is handled differently. @@ -1050,7 +1050,7 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No let limitArgs = - let limitArgs = CheckExprs cenv env args ctxts + let limitArgs = CheckExprs cenv env args ctxts (IsTailCall.Yes false) // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike receiverLimit then // Scope is 1 to ensure any by-refs returned can only be prevented for out of scope of the function/method, not visibility. @@ -1383,7 +1383,7 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckTypeInstNoByrefs cenv env m tyargs CheckTypeNoInnerByrefs cenv env m returnTy - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = let g = cenv.g @@ -1662,7 +1662,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = NoLimit | TOp.Coerce, [tgtTy;srcTy], [x] -> - let isTailCall = IsTailCall.fromExpr cenv.g x + let isTailCall = IsTailCall.YesFromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then CheckExpr cenv env x ctxt isTailCall else @@ -1898,11 +1898,11 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT CheckNoReraise cenv None expr limit -and CheckExprs cenv env exprs ctxts : Limit = +and CheckExprs cenv env exprs ctxts isTailCall : Limit = let ctxts = Array.ofList ctxts let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No exprs - |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) IsTailCall.No) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) isTailCall) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = @@ -2155,7 +2155,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin | _ -> () - let isTailCall = IsTailCall.fromVal g bind.Var + let isTailCall = IsTailCall.YesFromVal g bind.Var let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData // If the method has ResumableCode argument or return type it must be inline diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 4b4fec43620..b0de56353e7 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -344,3 +344,44 @@ let rec f x = seq { |> withLangVersionPreview |> typecheck |> shouldSucceed + + [] + let ``Don't warn for valid tailcalls in async expression`` () = + """ +[] +let rec f x = async { return! f (x-1) } + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in async expression`` () = + """ +[] +let rec f x = async { + let! r = f (x - 1) + return r +} + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 14 + EndLine = 4 + EndColumn = 23 } + Message = + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 14 + EndLine = 4 + EndColumn = 15 } + Message = + "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From 41b1493364bd5f85ea557dd39b7277dc206fd427 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 8 Jun 2023 18:42:17 +0200 Subject: [PATCH 16/77] add tests for module rec --- .../ErrorMessages/TailCallAttribute.fs | 72 ++++++++++++++++++- 1 file changed, 71 insertions(+), 1 deletion(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index b0de56353e7..b0173bd7837 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -349,7 +349,11 @@ let rec f x = seq { let ``Don't warn for valid tailcalls in async expression`` () = """ [] -let rec f x = async { return! f (x-1) } +let rec f x = async { + let y = x - 1 + let z = y - 1 + return! f (z - 1) +} """ |> FSharp |> withLangVersionPreview @@ -385,3 +389,69 @@ let rec f x = async { Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for valid tailcalls in rec module`` () = + """ +module rec M = + + module M1 = + [] + let m1func() = M2.m2func() + + module M2 = + [] + let m2func() = M1.m1func() + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for invalid tailcalls in rec module`` () = + """ +module rec M = + + module M1 = + [] + let m1func() = 1 + M2.m2func() + + module M2 = + [] + let m2func() = 2 + M1.m1func() + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 6 + StartColumn = 28 + EndLine = 6 + EndColumn = 39 } + Message = + "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 6 + StartColumn = 28 + EndLine = 6 + EndColumn = 37 } + Message = + "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 10 + StartColumn = 28 + EndLine = 10 + EndColumn = 39 } + Message = + "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 10 + StartColumn = 28 + EndLine = 10 + EndColumn = 37 } + Message = + "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From faae5c8a6f8e4ca127599d742f06dd207ce83791 Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 12 Jun 2023 15:07:45 +0200 Subject: [PATCH 17/77] Improve handling of ModuleOrNamespaceContents.TMDefDo and extend testing --- src/Compiler/Checking/PostInferenceChecks.fs | 26 ++++++++++----- .../ErrorMessages/TailCallAttribute.fs | 33 +++++++++++++++++++ 2 files changed, 51 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index e0f9f1872b4..866f9ca9c25 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -193,6 +193,14 @@ let CombineLimits limits = (NoLimit, limits) ||> List.fold CombineTwoLimits +let (|ValUseAtApp|_|) e = + match e with + | InnerExprPat( + Expr.App( + InnerExprPat(Expr.Val(valRef = vref; flags = valUseFlags)),_,_,[],_) + | Expr.Val(valRef = vref; flags = valUseFlags)) -> Some (vref, valUseFlags) + | _ -> None + type IsTailCall = | Yes of bool // true indicates "has unit return type and must return void" | No @@ -209,7 +217,7 @@ type IsTailCall = static member YesFromExpr (g: TcGlobals) (expr: Expr) = match expr with - | Expr.Val(valRef, _valUseFlag, _range) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) + | ValUseAtApp(valRef, _) -> IsTailCall.Yes (IsTailCall.IsVoidRet g valRef.Deref) | _ -> IsTailCall.Yes false member x.AtExprLambda = @@ -221,11 +229,6 @@ type IsTailCall = let IsValRefIsDllImport g (vref:ValRef) = vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute -let (|ValUseAtApp|_|) e = - match e with - | InnerExprPat(Expr.App(InnerExprPat(Expr.Val(vref,valUseFlags,_)),_,_,[],_) | Expr.Val(vref,valUseFlags,_)) -> Some (vref, valUseFlags) - | _ -> None - type cenv = { boundVals: Dictionary // really a hash set @@ -952,7 +955,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i match valUseFlags with | PossibleConstrainedCall _ -> true | _ -> false - let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) + let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) // Todo: discuss if this is really enough to render a tail call invalid let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) not isNewObj && @@ -2693,7 +2696,14 @@ and CheckDefnInModule cenv env mdef = | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e - CheckExprNoByrefs cenv env IsTailCall.No e + let isTailCall = + match stripDebugPoints e with + | Expr.App(funcExpr = funcExpr) -> + match funcExpr with + | ValUseAtApp (vref, _valUseFlags) -> IsTailCall.YesFromVal cenv.g vref.Deref + | _ -> IsTailCall.No + | _ -> IsTailCall.No + CheckExprNoByrefs cenv env isTailCall e | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env isRec mbind = diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index b0173bd7837..f5c3953905a 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -193,6 +193,9 @@ type C () = member this.M1() = printfn "M1 called" this.M1() + +let c = C() +c.M1() """ |> FSharp |> withLangVersionPreview @@ -402,6 +405,8 @@ module rec M = module M2 = [] let m2func() = M1.m1func() + +M.M1.m1func() """ |> FSharp |> withLangVersionPreview @@ -455,3 +460,31 @@ module rec M = Message = "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Warn for byref parameters`` () = + """ +[] +let rec foo(x: int byref) = foo(&x) +let run() = let mutable x = 0 in foo(&x) + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withResults [ + { Error = Warning 3567 + Range = { StartLine = 3 + StartColumn = 29 + EndLine = 3 + EndColumn = 36 } + Message = + "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3567 + Range = { StartLine = 4 + StartColumn = 34 + EndLine = 4 + EndColumn = 41 } + Message = + "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From 9c2af465581f61e435c6e3d1025e1a087edc4b3e Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 13 Jun 2023 17:11:32 +0200 Subject: [PATCH 18/77] suppress some invalid warnings by keeping track of ranges that are annotated with [] --- src/Compiler/Checking/PostInferenceChecks.fs | 110 +++++++++++++----- .../ErrorMessages/TailCallAttribute.fs | 26 ++--- 2 files changed, 90 insertions(+), 46 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 866f9ca9c25..79c274e1b69 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -87,6 +87,8 @@ type env = /// Values in this recursive scope that have been marked [] mutable mustTailCall: Zset + + mutable mustTailCallRanges: Map /// Are we in a quotation? quote : bool @@ -335,13 +337,17 @@ let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit -let BindVal cenv env (v: Val) = +let BindVal cenv env (exprRange: Range option) (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then env.mustTailCall <- Zset.add v env.mustTailCall + match exprRange with + | Some r when not (env.mustTailCallRanges.ContainsKey v.LogicalName) -> + env.mustTailCallRanges <- Map.add v.LogicalName r env.mustTailCallRanges + | _ -> () let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = @@ -367,7 +373,10 @@ let BindVal cenv env (v: Val) = else warning (Error(FSComp.SR.chkUnusedValue v.DisplayName, v.Range)) -let BindVals cenv env vs = List.iter (BindVal cenv env) vs +let BindVals cenv env (exprRanges: Range option list) vs = + let zipped = List.zip exprRanges vs + zipped + |> List.iter (fun (exprRange, v) -> BindVal cenv env exprRange v) let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then @@ -810,6 +819,32 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | None -> () | Some e -> errorR(e) +let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = + env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) + +let rec allRangesOfModDef mdef = + seq { match mdef with + | TMDefRec(bindings = mbinds) -> + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + let r = + match (stripExpr bind.Expr) with + | Expr.Lambda _ -> bind.Expr.Range + | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range + | e -> e.Range + yield r + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allRangesOfModDef def + | TMDefLet(binding = bind) -> + let e = stripExpr bind.Expr + yield e.Range + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allRangesOfModDef def + } + /// Check an expression, where the expression is in a position where byrefs can be generated let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore @@ -834,7 +869,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) if env.isInAppExpr then @@ -937,9 +972,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i match f with | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - let canTailCall = + let canTailCall, noTailCallBlockers = match isTailCall with - | IsTailCall.No -> false + | IsTailCall.No -> + false, true | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value @@ -958,20 +994,24 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) // Todo: discuss if this is really enough to render a tail call invalid let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) - not isNewObj && - not isSuperInit && - not isSelfInit && - not mustGenerateUnitAfterCall && - isNil laterArgs && - not (IsValRefIsDllImport cenv.g vref) && - not isCCall && - not hasByrefArg + let noTailCallBlockers = + not isNewObj && + not isSuperInit && + not isSelfInit && + not mustGenerateUnitAfterCall && + isNil laterArgs && + not (IsValRefIsDllImport cenv.g vref) && + not isCCall && + not hasByrefArg + noTailCallBlockers, noTailCallBlockers else - true + true, true - if not canTailCall then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - () + if not canTailCall then + if not noTailCallBlockers then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + elif (env.mustTailCallRanges.Item vref.LogicalName |> fun recRange -> rangeContainsRange recRange _m) then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) | _ -> () | _ -> () @@ -1079,7 +1119,7 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf PermitByRefExpr.Yes let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind - BindVal cenv env v + BindVal cenv env None v LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall CheckExprLinear cenv env body ctxt contf isTailCall @@ -1124,7 +1164,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) CheckExprNoByrefs cenv env isTailCall noneBranchExpr - BindVal cenv env someVar + BindVal cenv env None someVar CheckExprNoByrefs cenv env isTailCall someBranchExpr true @@ -1154,7 +1194,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo | IntegerForLoopExpr (_sp1, _sp2, _style, e1, e2, v, e3, _m) -> CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 - BindVal cenv env v + BindVal cenv env None v CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 true @@ -1170,8 +1210,9 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo true | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> - targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> - BindVals cenv env vs + targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> + let exprRanges = List.replicate vs.Length None + BindVals cenv env exprRanges vs CheckExprNoByrefs cenv env isTailCall targetExpr) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree true @@ -1180,7 +1221,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo // Restriction: resumable code can't contain local constrained generic functions when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore - BindVal cenv env bind.Var + BindVal cenv env None bind.Var CheckExprNoByrefs cenv env isTailCall bodyExpr true @@ -1349,7 +1390,8 @@ and CheckStructStateMachineExpr cenv env expr info = if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) - BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] + let exprRanges = [None; None; None; None] + BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody @@ -1460,8 +1502,10 @@ and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = CheckDecisionTree cenv env dtree CheckDecisionTreeTargets cenv env targets ctxt isTailCall -and CheckLetRec cenv env (binds, bodyExpr) isTailCall = - BindVals cenv env (valsOfBinds binds) +and CheckLetRec cenv env (binds, bodyExpr) isTailCall = + let vals = valsOfBinds binds + let exprRanges = List.replicate (List.length binds) None + BindVals cenv env exprRanges vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr NoLimit @@ -1851,7 +1895,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT ) for arg in syntacticArgs do - BindVal cenv env arg + BindVal cenv env None arg // Check escapes in the body. Allow access to protected things within members. let freesOpt = CheckEscapes cenv memInfo.IsSome m syntacticArgs body @@ -1931,7 +1975,8 @@ and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = |> CombineLimits and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = - BindVals cenv env vs + let exprRanges = List.replicate vs.Length None + BindVals cenv env exprRanges vs for v in vs do CheckValSpec PermitByRefType.All cenv env v CheckExpr cenv env targetExpr ctxt isTailCall @@ -2684,13 +2729,15 @@ and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, tycons, mspecs, m) -> CheckNothingAfterEntryPoint cenv m - if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) + if isRec then + let ranges = allRangesOfModDef mdef |> Seq.toList |> List.map Some + BindVals cenv env ranges (allValsOfModDef mdef |> Seq.toList) CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m CheckModuleBinding cenv env false bind - BindVal cenv env bind.Var + BindVal cenv env (Some bind.Expr.Range) bind.Var | TMDefOpens _ -> () | TMDefDo(e, m) -> @@ -2709,7 +2756,7 @@ and CheckDefnInModule cenv env mdef = and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - BindVals cenv env (valsOfBinds [bind]) + BindVals cenv env [None] (valsOfBinds [bind]) CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec @@ -2759,6 +2806,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v boundTyparNames=[] argVals = ValMap.Empty mustTailCall = Zset.empty valOrder + mustTailCallRanges = Map.Empty boundTypars= TyparMap.Empty reflect=false external=false diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index f5c3953905a..d2e1cba418f 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -272,6 +272,8 @@ let rec fact n acc = let f () = let r = fact 100000 1 r |> ignore + +fact 100000 1 |> ignore """ |> FSharp |> withLangVersionPreview @@ -342,6 +344,8 @@ let rec f x = seq { let z = y - 1 yield! f (z - 1) } + +let a: seq = f 10 """ |> FSharp |> withLangVersionPreview @@ -357,6 +361,8 @@ let rec f x = async { let z = y - 1 return! f (z - 1) } + +let a: Async = f 10 """ |> FSharp |> withLangVersionPreview @@ -406,7 +412,11 @@ module rec M = [] let m2func() = M1.m1func() -M.M1.m1func() + let f () = + M1.m1func() |> ignore + +M.M1.m1func() |> ignore +M.M2.m2func() """ |> FSharp |> withLangVersionPreview @@ -431,13 +441,6 @@ module rec M = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 - Range = { StartLine = 6 - StartColumn = 28 - EndLine = 6 - EndColumn = 39 } - Message = - "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 6 StartColumn = 28 @@ -445,13 +448,6 @@ module rec M = EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 - Range = { StartLine = 10 - StartColumn = 28 - EndLine = 10 - EndColumn = 39 } - Message = - "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3567 Range = { StartLine = 10 StartColumn = 28 From 35b31e5b7408c4b646cff620bcdf71336763d218 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 13 Jun 2023 17:41:21 +0200 Subject: [PATCH 19/77] fix build --- src/Compiler/Checking/PostInferenceChecks.fs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 79c274e1b69..928e46f65f3 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -822,9 +822,14 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) -let rec allRangesOfModDef mdef = +let rec allRangesOfModDef mdef = + let abstractSlotRangesOfTycons (tycons: Tycon list) = + abstractSlotValRefsOfTycons tycons + |> List.map (fun v -> v.Deref.Range) + seq { match mdef with - | TMDefRec(bindings = mbinds) -> + | TMDefRec(tycons = tycons; bindings = mbinds) -> + yield! abstractSlotRangesOfTycons tycons for mbind in mbinds do match mbind with | ModuleOrNamespaceBinding.Binding bind -> @@ -1504,7 +1509,7 @@ and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = and CheckLetRec cenv env (binds, bodyExpr) isTailCall = let vals = valsOfBinds binds - let exprRanges = List.replicate (List.length binds) None + let exprRanges = List.replicate vals.Length None BindVals cenv env exprRanges vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr From 193c91f0d18a756f6f782eaff1a75995866b1b52 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 14 Jun 2023 08:35:07 +0200 Subject: [PATCH 20/77] use Stamp instead of LogicalName as the Map key --- src/Compiler/Checking/PostInferenceChecks.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 928e46f65f3..898bc4f3429 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -88,7 +88,7 @@ type env = /// Values in this recursive scope that have been marked [] mutable mustTailCall: Zset - mutable mustTailCallRanges: Map + mutable mustTailCallRanges: Map /// Are we in a quotation? quote : bool @@ -345,8 +345,8 @@ let BindVal cenv env (exprRange: Range option) (v: Val) = if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then env.mustTailCall <- Zset.add v env.mustTailCall match exprRange with - | Some r when not (env.mustTailCallRanges.ContainsKey v.LogicalName) -> - env.mustTailCallRanges <- Map.add v.LogicalName r env.mustTailCallRanges + | Some r when not (env.mustTailCallRanges.ContainsKey v.Stamp) -> + env.mustTailCallRanges <- Map.add v.Stamp r env.mustTailCallRanges | _ -> () let topLevelBindingHiddenBySignatureFile () = @@ -1015,7 +1015,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i if not canTailCall then if not noTailCallBlockers then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - elif (env.mustTailCallRanges.Item vref.LogicalName |> fun recRange -> rangeContainsRange recRange _m) then + elif (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange _m) then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) | _ -> () | _ -> () From e42c6e7b8fc40225b9e833b7af34ddf6f3a123f5 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 15 Jun 2023 14:32:28 +0200 Subject: [PATCH 21/77] fix error number after merge --- .../ErrorMessages/TailCallAttribute.fs | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index d2e1cba418f..3d556c9ab46 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -21,14 +21,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 @@ -53,14 +53,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 37 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 @@ -87,7 +87,7 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 9 StartColumn = 17 EndLine = 9 @@ -148,14 +148,14 @@ and [] baz x = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 EndColumn = 20 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 @@ -176,7 +176,7 @@ type C () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 24 EndLine = 4 @@ -240,14 +240,14 @@ type F () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 6 StartColumn = 9 EndLine = 6 EndColumn = 18 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 11 StartColumn = 9 EndLine = 11 @@ -296,7 +296,7 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 5 StartColumn = 17 EndLine = 5 @@ -319,14 +319,14 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 @@ -383,14 +383,14 @@ let rec f x = async { |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 EndColumn = 23 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 @@ -441,14 +441,14 @@ module rec M = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 6 StartColumn = 28 EndLine = 6 EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 10 StartColumn = 28 EndLine = 10 @@ -469,14 +469,14 @@ let run() = let mutable x = 0 in foo(&x) |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 3 StartColumn = 29 EndLine = 3 EndColumn = 36 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3567 + { Error = Warning 3568 Range = { StartLine = 4 StartColumn = 34 EndLine = 4 From f678196889bbe38434ffa3ed16bd7060a33f8849 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 14:26:32 +0200 Subject: [PATCH 22/77] remove TailCall check code from PostInferenceChecks.fs --- src/Compiler/Checking/PostInferenceChecks.fs | 436 ++++++------------- 1 file changed, 129 insertions(+), 307 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 898bc4f3429..145c7e0799c 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -85,11 +85,6 @@ type env = /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature sigToImplRemapInfo: (Remap * SignatureHidingInfo) list - /// Values in this recursive scope that have been marked [] - mutable mustTailCall: Zset - - mutable mustTailCallRanges: Map - /// Are we in a quotation? quote : bool @@ -195,42 +190,6 @@ 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 @@ -337,17 +296,10 @@ let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit -let BindVal cenv env (exprRange: Range option) (v: Val) = +let BindVal cenv env (v: Val) = //printfn "binding %s..." v.DisplayName let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals[v.Stamp] <- 1 - - if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then - env.mustTailCall <- Zset.add v env.mustTailCall - match exprRange with - | Some r when not (env.mustTailCallRanges.ContainsKey v.Stamp) -> - env.mustTailCallRanges <- Map.add v.Stamp r env.mustTailCallRanges - | _ -> () let topLevelBindingHiddenBySignatureFile () = let parentHasSignatureFile () = @@ -373,10 +325,7 @@ let BindVal cenv env (exprRange: Range option) (v: Val) = else warning (Error(FSComp.SR.chkUnusedValue v.DisplayName, v.Range)) -let BindVals cenv env (exprRanges: Range option list) vs = - let zipped = List.zip exprRanges vs - zipped - |> List.iter (fun (exprRange, v) -> BindVal cenv env exprRange v) +let BindVals cenv env vs = List.iter (BindVal cenv env) vs let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then @@ -819,43 +768,12 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | None -> () | Some e -> errorR(e) -let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = - env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) - -let rec allRangesOfModDef mdef = - let abstractSlotRangesOfTycons (tycons: Tycon list) = - abstractSlotValRefsOfTycons tycons - |> List.map (fun v -> v.Deref.Range) - - seq { match mdef with - | TMDefRec(tycons = tycons; bindings = mbinds) -> - yield! abstractSlotRangesOfTycons tycons - for mbind in mbinds do - match mbind with - | ModuleOrNamespaceBinding.Binding bind -> - let r = - match (stripExpr bind.Expr) with - | Expr.Lambda _ -> bind.Expr.Range - | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range - | e -> e.Range - yield r - | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allRangesOfModDef def - | TMDefLet(binding = bind) -> - let e = stripExpr bind.Expr - yield e.Range - | TMDefDo _ -> () - | TMDefOpens _ -> () - | TMDefs defs -> - for def in defs do - yield! allRangesOfModDef def - } - /// Check an expression, where the expression is in a position where byrefs can be generated -let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = - CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore +let rec CheckExprNoByrefs cenv env expr = + CheckExpr cenv env expr PermitByRefExpr.No |> ignore /// Check a value -and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = +and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = if cenv.reportErrors then if isSpliceOperator cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)) @@ -873,17 +791,13 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) (isTailCall: if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) - if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then - warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) - if env.isInAppExpr then 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) (isTailCall: IsTailCall) = +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) = let g = cenv.g @@ -928,12 +842,12 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB if isReturnOfStructThis then errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) - CheckValRef cenv env vref m ctxt isTailCall + CheckValRef cenv env vref m ctxt limit /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -972,53 +886,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i | None -> () | _ -> () | _ -> () - - if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - match f with - | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - - let canTailCall, noTailCallBlockers = - match isTailCall with - | IsTailCall.No -> - false, true - | 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) // Todo: discuss if this is really enough to render a tail call invalid - 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, noTailCallBlockers - else - true, true - - if not canTailCall then - if not noTailCallBlockers then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - elif (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange _m) then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - | _ -> () - | _ -> () + | _ -> () and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = let isReturnByref = isByrefTy cenv.g returnTy @@ -1082,7 +950,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 IsTailCall.No + let limitArgs = CheckExprs cenv env args ctxts CheckCallLimitArgs cenv env m returnTy limitArgs ctxt /// Check call arguments, including the return argument. The receiver argument is handled differently. @@ -1096,9 +964,9 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = | [] -> PermitByRefExpr.No, [] | ctxt :: ctxts -> ctxt, ctxts - let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No + let receiverLimit = CheckExpr cenv env receiverArg receiverContext let limitArgs = - let limitArgs = CheckExprs cenv env args ctxts (IsTailCall.Yes false) + let limitArgs = CheckExprs cenv env args ctxts // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. 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. @@ -1107,12 +975,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) (isTailCall: IsTailCall) = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> - CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env e1 // tailcall - CheckExprLinear cenv env e2 ctxt contf isTailCall + CheckExprLinear cenv env e2 ctxt contf | Expr.Let (TBind(v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type @@ -1124,34 +992,34 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf PermitByRefExpr.Yes let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind - BindVal cenv env None v + BindVal cenv env v LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall - CheckExprLinear cenv env body ctxt contf isTailCall + CheckExprLinear cenv env body ctxt contf | LinearOpExpr (_op, tyargs, argsHead, argLast, m) -> CheckTypeInstNoByrefs cenv env m tyargs - argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) + argsHead |> List.iter (CheckExprNoByrefs cenv env) // tailcall - CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) isTailCall + CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, m, ty) -> CheckTypeNoInnerByrefs cenv env m ty CheckDecisionTree cenv env dtree - let lim1 = CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 + let lim1 = CheckDecisionTreeTarget cenv env ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) isTailCall + CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) | Expr.DebugPoint (_, innerExpr) -> - CheckExprLinear cenv env innerExpr ctxt contf isTailCall + CheckExprLinear cenv env innerExpr ctxt contf | _ -> // not a linear expression - contf (CheckExpr cenv env expr ctxt isTailCall) + contf (CheckExpr cenv env expr ctxt) /// 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 (isTailCall: IsTailCall) : bool = +and TryCheckResumableCodeConstructs cenv env expr : bool = let g = cenv.g match env.resumableCode with @@ -1161,64 +1029,63 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo | Resumable.ResumableExpr allowed -> match expr with | IfUseResumableStateMachinesExpr g (thenExpr, elseExpr) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } isTailCall thenExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall elseExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } thenExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } elseExpr true | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, _rebuild) -> if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) - CheckExprNoByrefs cenv env isTailCall noneBranchExpr - BindVal cenv env None someVar - CheckExprNoByrefs cenv env isTailCall someBranchExpr + CheckExprNoByrefs cenv env noneBranchExpr + BindVal cenv env someVar + CheckExprNoByrefs cenv env someBranchExpr true | ResumeAtExpr g pcExpr -> if not allowed then errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumeAt"), expr.Range)) - CheckExprNoByrefs cenv env isTailCall pcExpr + CheckExprNoByrefs cenv env pcExpr true | ResumableCodeInvoke g (_, f, args, _, _) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall f + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } 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 } isTailCall e1 - CheckExprNoByrefs cenv env isTailCall e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr allowed }e1 + CheckExprNoByrefs cenv env e2 true | WhileExpr (_sp1, _sp2, guardExpr, bodyExpr, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall guardExpr - CheckExprNoByrefs cenv env isTailCall bodyExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } guardExpr + CheckExprNoByrefs cenv env 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 } isTailCall e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 - BindVal cenv env None v - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e2 + BindVal cenv env v + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e3 true | TryWithExpr (_spTry, _spWith, _resTy, bodyExpr, _filterVar, filterExpr, _handlerVar, handlerExpr, _m) -> - CheckExprNoByrefs cenv env isTailCall bodyExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall handlerExpr - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall filterExpr + CheckExprNoByrefs cenv env bodyExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } handlerExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } filterExpr true | TryFinallyExpr (_sp1, _sp2, _ty, e1, e2, _m) -> - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } e2 true | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> - targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> - let exprRanges = List.replicate vs.Length None - BindVals cenv env exprRanges vs - CheckExprNoByrefs cenv env isTailCall targetExpr) + targets |> Array.iter(fun (TTarget(vs, targetExpr, _)) -> + BindVals cenv env vs + CheckExprNoByrefs cenv env targetExpr) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree true @@ -1226,14 +1093,14 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo // Restriction: resumable code can't contain local constrained generic functions when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore - BindVal cenv env None bind.Var - CheckExprNoByrefs cenv env isTailCall bodyExpr + BindVal cenv env bind.Var + CheckExprNoByrefs cenv env 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 isTailCall bodyExpr + CheckExprNoByrefs cenv env bodyExpr true // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match @@ -1241,13 +1108,13 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo true | Expr.DebugPoint (_, innerExpr) -> - TryCheckResumableCodeConstructs cenv env innerExpr isTailCall + TryCheckResumableCodeConstructs cenv env innerExpr | _ -> false /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : Limit = +and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = // Guard the stack for deeply nested expressions cenv.stackGuard.Guard <| fun () -> @@ -1257,11 +1124,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall + CheckForOverAppliedExceptionRaisingPrimitive cenv origExpr let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr - match TryCheckResumableCodeConstructs cenv env expr isTailCall with + match TryCheckResumableCodeConstructs cenv env expr with | true -> // we've handled the special cases of resumable code and don't do other checks. NoLimit @@ -1276,11 +1143,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) | Expr.DebugPoint _ -> - CheckExprLinear cenv env expr ctxt id isTailCall + CheckExprLinear cenv env expr ctxt id | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs cenv env IsTailCall.No e1 - CheckExprNoByrefs cenv env IsTailCall.No e2 + CheckExprNoByrefs cenv env e1 + CheckExprNoByrefs cenv env e2 NoLimit | Expr.Const (_, m, ty) -> @@ -1288,7 +1155,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa NoLimit | Expr.Val (vref, vFlags, m) -> - CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall + CheckValUse cenv env (vref, vFlags, m) ctxt | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> CheckQuoteExpr cenv env (ast, savedConv, m, ty) @@ -1329,24 +1196,24 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa // Check an application | Expr.App (f, _fty, tyargs, argsl, m) -> - CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall + CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> - CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall + CheckLambda cenv env expr (argvs, m, bodyTy) | Expr.TyLambda (_, tps, _, m, bodyTy) -> - CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall + CheckTyLambda cenv env expr (tps, m, bodyTy) | Expr.TyChoose (tps, e1, _) -> let env = BindTypars g env tps - CheckExprNoByrefs cenv env isTailCall e1 + CheckExprNoByrefs cenv env e1 NoLimit | Expr.Match (_, _, dtree, targets, m, ty) -> - CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall + CheckMatch cenv env ctxt (dtree, targets, m, ty) | Expr.LetRec (binds, bodyExpr, _, _) -> - CheckLetRec cenv env (binds, bodyExpr) isTailCall + CheckLetRec cenv env (binds, bodyExpr) | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) @@ -1359,7 +1226,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa and CheckQuoteExpr cenv env (ast, savedConv, m, ty) = let g = cenv.g - CheckExprNoByrefs cenv {env with quote=true} IsTailCall.No ast + CheckExprNoByrefs cenv {env with quote=true} ast if cenv.reportErrors then cenv.usesQuotations <- true @@ -1395,16 +1262,15 @@ and CheckStructStateMachineExpr cenv env expr info = if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then error(Error(FSComp.SR.tcResumableCodeNotSupported(), expr.Range)) - let exprRanges = [None; None; None; None] - BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr - CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody - CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody + BindVals cenv env [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } moveNextExpr + CheckExprNoByrefs cenv env setStateMachineBody + CheckExprNoByrefs cenv env afterCodeBody NoLimit and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) = let g = cenv.g - CheckExprNoByrefs cenv env IsTailCall.No superInitCall + CheckExprNoByrefs cenv env superInitCall CheckMethods cenv env basev (ty, overrides) CheckInterfaceImpls cenv env basev iimpls CheckTypeNoByrefs cenv env m ty @@ -1429,11 +1295,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 IsTailCall.No - CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No + CheckValRef cenv env v m PermitByRefExpr.No + CheckValRef cenv env baseVal m PermitByRefExpr.No CheckTypeInstNoByrefs cenv env m tyargs CheckTypeNoInnerByrefs cenv env m returnTy - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = let g = cenv.g @@ -1455,15 +1321,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 IsTailCall.No + CheckValRef cenv env baseVal m PermitByRefExpr.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 IsTailCall.No arg + CheckExprNoByrefs cenv env arg NoLimit -and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt (isTailCall: IsTailCall) = +and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = let g = cenv.g match expr with | ResumableCodeInvoke g _ -> @@ -1479,7 +1345,7 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt (isTailCall: IsTai let env = { env with isInAppExpr = true } CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env isTailCall f + CheckExprNoByrefs cenv env f let hasReceiver = match f with @@ -1492,32 +1358,30 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt (isTailCall: IsTai else CheckCall cenv env m returnTy argsl ctxts ctxt -and CheckLambda cenv env expr (argvs, m, bodyTy) (isTailCall: IsTailCall) = +and CheckLambda cenv env expr (argvs, m, bodyTy) = let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in - CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) (isTailCall: IsTailCall) = +and CheckTyLambda cenv env expr (tps, m, bodyTy) = let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) let ty = mkForallTyIfNeeded tps bodyTy in - CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall = +and CheckMatch cenv env ctxt (dtree, targets, m, ty) = CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch CheckDecisionTree cenv env dtree - CheckDecisionTreeTargets cenv env targets ctxt isTailCall + CheckDecisionTreeTargets cenv env targets ctxt -and CheckLetRec cenv env (binds, bodyExpr) isTailCall = - let vals = valsOfBinds binds - let exprRanges = List.replicate vals.Length None - BindVals cenv env exprRanges vals +and CheckLetRec cenv env (binds, bodyExpr) = + BindVals cenv env (valsOfBinds binds) CheckBindings cenv env binds - CheckExprNoByrefs cenv env isTailCall bodyExpr + CheckExprNoByrefs cenv env bodyExpr NoLimit and CheckStaticOptimization cenv env (constraints, e2, e3, m) = - CheckExprNoByrefs cenv env IsTailCall.No e2 - CheckExprNoByrefs cenv env IsTailCall.No e3 + CheckExprNoByrefs cenv env e2 + CheckExprNoByrefs cenv env e3 constraints |> List.iter (function | TTyconEqualsTycon(ty1, ty2) -> CheckTypeNoByrefs cenv env m ty1 @@ -1544,7 +1408,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 IsTailCall.No |> ignore + CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal |> ignore and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -1581,8 +1445,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 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 + 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 limit | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> @@ -1591,9 +1455,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 IsTailCall.No // 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 // 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 IsTailCall.No // 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 // 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), _, _ -> @@ -1714,12 +1578,11 @@ 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 isTailCall + CheckExpr cenv env x ctxt else CheckTypeInstNoByrefs cenv env m tyargs - CheckExprNoByrefs cenv env isTailCall x + CheckExprNoByrefs cenv env x NoLimit | TOp.Reraise, [_ty1], [] -> @@ -1754,7 +1617,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 IsTailCall.No + CheckExpr cenv env obj ctxt | TOp.UnionCaseFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs @@ -1775,7 +1638,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 IsTailCall.No + CheckExpr cenv env obj ctxt | TOp.ILAsm (instrs, retTypes), _, _ -> CheckTypeInstNoInnerByrefs cenv env m retTypes @@ -1783,10 +1646,6 @@ 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 @@ -1812,7 +1671,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 IsTailCall.No + CheckExpr cenv env obj ctxt | [ I_ldelema (_, isNativePtr, _, _) ], lhsArray :: indices -> if ctxt.Disallow && cenv.reportErrors && not isNativePtr && isByrefLikeTy g m (tyOfExpr g expr) then @@ -1842,7 +1701,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 (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt = +and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwaysCheckNoReraise expr mOrig ety ctxt = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) @@ -1851,7 +1710,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT match stripDebugPoints expr with | Expr.TyChoose (tps, e1, m) -> let env = BindTypars g env tps - CheckLambdas isTop memberVal cenv env inlined valReprInfo isTailCall alwaysCheckNoReraise e1 m ety ctxt + CheckLambdas isTop memberVal cenv env inlined valReprInfo alwaysCheckNoReraise e1 m ety ctxt | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> @@ -1900,7 +1759,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT ) for arg in syntacticArgs do - BindVal cenv env None arg + BindVal cenv env arg // Check escapes in the body. Allow access to protected things within members. let freesOpt = CheckEscapes cenv memInfo.IsSome m syntacticArgs body @@ -1913,7 +1772,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT // allow byref to occur as return position for byref-typed top level function or method CheckExprPermitReturnableByRef cenv env body |> ignore else - CheckExprNoByrefs cenv env isTailCall body + CheckExprNoByrefs cenv env body // Check byref return types if cenv.reportErrors then @@ -1941,25 +1800,25 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT 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 isTailCall + CheckExpr cenv env expr ctxt else - CheckExprNoByrefs cenv env isTailCall expr + CheckExprNoByrefs cenv env expr NoLimit if alwaysCheckNoReraise then CheckNoReraise cenv None expr limit -and CheckExprs cenv env exprs ctxts isTailCall : Limit = +and CheckExprs cenv env exprs ctxts : Limit = let ctxts = Array.ofList ctxts let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No exprs - |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) isTailCall) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i)) |> CombineLimits and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do - CheckExprNoByrefs cenv env IsTailCall.No expr + CheckExprNoByrefs cenv env expr NoLimit and CheckExprsPermitByRefLike cenv env exprs : Limit = @@ -1968,23 +1827,22 @@ and CheckExprsPermitByRefLike cenv env exprs : Limit = |> CombineLimits and CheckExprPermitByRefLike cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No + CheckExpr cenv env expr PermitByRefExpr.Yes and CheckExprPermitReturnableByRef cenv env expr : Limit = - CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No + CheckExpr cenv env expr PermitByRefExpr.YesReturnable -and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = +and CheckDecisionTreeTargets cenv env targets ctxt = targets - |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) + |> Array.map (CheckDecisionTreeTarget cenv env ctxt) |> List.ofArray |> CombineLimits -and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = - let exprRanges = List.replicate vs.Length None - BindVals cenv env exprRanges vs +and CheckDecisionTreeTarget cenv env ctxt (TTarget(vs, targetExpr, _)) = + BindVals cenv env vs for v in vs do CheckValSpec PermitByRefType.All cenv env v - CheckExpr cenv env targetExpr ctxt isTailCall + CheckExpr cenv env targetExpr ctxt and CheckDecisionTree cenv env dtree = match dtree with @@ -2010,7 +1868,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 IsTailCall.No exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env exp | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = @@ -2020,8 +1878,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 IsTailCall.No expr - CheckExprNoByrefs cenv env IsTailCall.No vexpr + CheckExprNoByrefs cenv env expr + CheckExprNoByrefs cenv env vexpr CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr @@ -2207,8 +2065,7 @@ 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 @@ -2227,14 +2084,14 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin else env - CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo 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 (isRec: bool) (TBind(v, e, _) as bind) = +let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then @@ -2243,30 +2100,6 @@ let CheckModuleBinding cenv env (isRec: bool) (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.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - let rec checkTailCall (insideSubBinding: bool) expr = - match expr with - | Expr.Val(valRef, _valUseFlag, m) -> - if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then - warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> - checkTailCall insideSubBinding funcExpr - exprs |> List.iter (checkTailCall insideSubBinding) - | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - checkTailCall insideSubBinding bodyExpr - | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr - | Expr.Let(binding, bodyExpr, _range, _frees) -> - checkTailCall true binding.Expr - checkTailCall insideSubBinding bodyExpr - | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> - decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) - | _ -> () - checkTailCall false bodyExpr - | _ -> () - // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields not v.IsMutable && @@ -2734,35 +2567,26 @@ and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, tycons, mspecs, m) -> CheckNothingAfterEntryPoint cenv m - if isRec then - let ranges = allRangesOfModDef mdef |> Seq.toList |> List.map Some - BindVals cenv env ranges (allValsOfModDef mdef |> Seq.toList) + if isRec then BindVals cenv env (allValsOfModDef mdef |> Seq.toList) CheckEntityDefns cenv env tycons - List.iter (CheckModuleSpec cenv env isRec) mspecs + List.iter (CheckModuleSpec cenv env) mspecs | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m - CheckModuleBinding cenv env false bind - BindVal cenv env (Some bind.Expr.Range) bind.Var + CheckModuleBinding cenv env bind + BindVal cenv env bind.Var | TMDefOpens _ -> () | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None 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 + CheckExprNoByrefs cenv env e | TMDefs defs -> CheckDefnsInModule cenv env defs -and CheckModuleSpec cenv env isRec mbind = +and CheckModuleSpec cenv env mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - BindVals cenv env [None] (valsOfBinds [bind]) - CheckModuleBinding cenv env isRec bind + BindVals cenv env (valsOfBinds [bind]) + CheckModuleBinding cenv env 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 } @@ -2792,7 +2616,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. @@ -2810,8 +2634,6 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v quote=false boundTyparNames=[] argVals = ValMap.Empty - mustTailCall = Zset.empty valOrder - mustTailCallRanges = Map.Empty boundTypars= TyparMap.Empty reflect=false external=false From d5c4822cd7991a1e434104ee5e14352040092ee7 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 14:28:07 +0200 Subject: [PATCH 23/77] Add new file TailCallChecks.fs to focus on tail call checks --- src/Compiler/Checking/CheckDeclarations.fs | 10 +- src/Compiler/Checking/TailCallChecks.fs | 1423 +++++++++++++++++++ src/Compiler/FSharp.Compiler.Service.fsproj | 1 + 3 files changed, 1433 insertions(+), 1 deletion(-) create mode 100644 src/Compiler/Checking/TailCallChecks.fs diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 47606b18751..2e3fbbef71d 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5501,11 +5501,19 @@ let CheckOneImplFile try let reportErrors = not (checkForErrors()) let tcVal = LightweightTcValForUsingInBuildMethodCall g - PostTypeCheckSemanticChecks.CheckImplFile + let hasExplicitEntryPoint, anonRecdTypes = + PostTypeCheckSemanticChecks.CheckImplFile + (g, cenv.amap, reportErrors, cenv.infoReader, + env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, + implFileTy, implFileContents, extraAttribs, isLastCompiland, + isInternalTestSpanStackReferring) + TailCallChecks.CheckImplFile (g, cenv.amap, reportErrors, cenv.infoReader, env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) + |> ignore + hasExplicitEntryPoint, anonRecdTypes with exn -> errorRecovery exn m diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs new file mode 100644 index 00000000000..eb6702abbf8 --- /dev/null +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -0,0 +1,1423 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +/// Implements a set of checks on the TAST for a file that can only be performed after type inference +/// is complete. +module internal FSharp.Compiler.TailCallChecks + +open System +open System.Collections.Generic + +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.InfoReader +open FSharp.Compiler.Syntax +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.Text +open FSharp.Compiler.Text.Range +open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTreeBasics +open FSharp.Compiler.TypedTreeOps +open FSharp.Compiler.TypeRelations + +let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChecks" 50 + +//-------------------------------------------------------------------------- +// check environment +//-------------------------------------------------------------------------- + +[] +type Resumable = + | None + /// Indicates we are expecting resumable code (the body of a ResumableCode delegate or + /// the body of the MoveNextMethod for a state machine) + /// -- allowed: are we inside the 'then' branch of an 'if __useResumableCode then ...' + /// for a ResumableCode delegate. + | ResumableExpr of allowed: bool + +type env = + { + /// The bound type parameter names in scope + boundTyparNames: string list + + /// The bound type parameters in scope + boundTypars: TyparMap + + /// The set of arguments to this method/function + argVals: ValMap + + /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature + sigToImplRemapInfo: (Remap * SignatureHidingInfo) list + + /// Values in this recursive scope that have been marked [] + mutable mustTailCall: Zset + + mutable mustTailCallRanges: Map + + /// Are we in a quotation? + quote : bool + + /// Are we under []? + reflect : bool + + /// Are we in an extern declaration? + external : bool + + /// Current return scope of the expr. + returnScope : int + + /// Are we in an app expression (Expr.App)? + isInAppExpr: bool + + /// Are we expecting a resumable code block etc + resumableCode: Resumable + } + + override _.ToString() = "" + +let BindTypar env (tp: Typar) = + { env with + boundTyparNames = tp.Name :: env.boundTyparNames + boundTypars = env.boundTypars.Add (tp, ()) } + +let BindTypars g env (tps: Typar list) = + let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps + if isNil tps then env else + // Here we mutate to provide better names for generalized type parameters + let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps + PrettyTypes.AssignPrettyTyparNames tps nms + List.fold BindTypar env tps + +/// Set the set of vals which are arguments in the active lambda. We are allowed to return +/// byref arguments as byref returns. +let BindArgVals env (vs: Val list) = + { env with argVals = ValMap.OfList (List.map (fun v -> (v, ())) vs) } + +/// Limit flags represent a type(s) returned from checking an expression(s) that is interesting to impose rules on. +[] +type LimitFlags = + | None = 0b00000 + | ByRef = 0b00001 + | ByRefOfSpanLike = 0b00011 + | ByRefOfStackReferringSpanLike = 0b00101 + | SpanLike = 0b01000 + | StackReferringSpanLike = 0b10000 + +[] +type Limit = + { + scope: int + flags: LimitFlags + } + + member this.IsLocal = this.scope >= 1 + +/// Check if the limit has the target limit. +let inline HasLimitFlag targetLimit (limit: Limit) = + limit.flags &&& targetLimit = targetLimit + +let NoLimit = { scope = 0; flags = LimitFlags.None } + +// Combining two limits will result in both limit flags merged. +// If none of the limits are limited by a by-ref or a stack referring span-like +// the scope will be 0. +let CombineTwoLimits limit1 limit2 = + let isByRef1 = HasLimitFlag LimitFlags.ByRef limit1 + let isByRef2 = HasLimitFlag LimitFlags.ByRef limit2 + let isStackSpan1 = HasLimitFlag LimitFlags.StackReferringSpanLike limit1 + let isStackSpan2 = HasLimitFlag LimitFlags.StackReferringSpanLike limit2 + let isLimited1 = isByRef1 || isStackSpan1 + let isLimited2 = isByRef2 || isStackSpan2 + + // A limit that has a stack referring span-like but not a by-ref, + // we force the scope to 1. This is to handle call sites + // that return a by-ref and have stack referring span-likes as arguments. + // This is to ensure we can only prevent out of scope at the method level rather than visibility. + let limit1 = + if isStackSpan1 && not isByRef1 then + { limit1 with scope = 1 } + else + limit1 + + let limit2 = + if isStackSpan2 && not isByRef2 then + { limit2 with scope = 1 } + else + limit2 + + match isLimited1, isLimited2 with + | false, false -> + { scope = 0; flags = limit1.flags ||| limit2.flags } + | true, true -> + { scope = Math.Max(limit1.scope, limit2.scope); flags = limit1.flags ||| limit2.flags } + | true, false -> + { limit1 with flags = limit1.flags ||| limit2.flags } + | false, true -> + { limit2 with flags = limit1.flags ||| limit2.flags } + +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 + + limitVals: Dictionary + + mutable potentialUnboundUsesOfVals: StampMap + + mutable anonRecdTypes: StampMap + + stackGuard: StackGuard + + g: TcGlobals + + amap: Import.ImportMap + + /// For reading metadata + infoReader: InfoReader + + internalsVisibleToPaths : CompilationPath list + + denv: DisplayEnv + + viewCcu : CcuThunk + + reportErrors: bool + + isLastCompiland : bool*bool + + isInternalTestSpanStackReferring: bool + + // outputs + mutable usesQuotations: bool + + mutable entryPointGiven: bool + + /// Callback required for quotation generation + tcVal: ConstraintSolver.TcValF } + + override x.ToString() = "" + +/// Check if the value is an argument of a function +let IsValArgument env (v: Val) = + env.argVals.ContainsVal v + +/// Check if the value is a local, not an argument of a function. +let IsValLocal env (v: Val) = + v.ValReprInfo.IsNone && not (IsValArgument env v) + +/// Get the limit of the val. +let GetLimitVal cenv env m (v: Val) = + let limit = + match cenv.limitVals.TryGetValue v.Stamp with + | true, limit -> limit + | _ -> + if IsValLocal env v then + { scope = 1; flags = LimitFlags.None } + else + NoLimit + + if isSpanLikeTy cenv.g m v.Type then + // The value is a limited Span or might have become one through mutation + let isMutable = v.IsMutable && cenv.isInternalTestSpanStackReferring + let isLimited = HasLimitFlag LimitFlags.StackReferringSpanLike limit + + if isMutable || isLimited then + { limit with flags = LimitFlags.StackReferringSpanLike } + else + { limit with flags = LimitFlags.SpanLike } + + elif isByrefTy cenv.g v.Type then + let isByRefOfSpanLike = isSpanLikeTy cenv.g m (destByrefTy cenv.g v.Type) + + if isByRefOfSpanLike then + if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then + { limit with flags = LimitFlags.ByRefOfStackReferringSpanLike } + else + { limit with flags = LimitFlags.ByRefOfSpanLike } + else + { limit with flags = LimitFlags.ByRef } + + else + { limit with flags = LimitFlags.None } + +/// Get the limit of the val by reference. +let GetLimitValByRef cenv env m v = + let limit = GetLimitVal cenv env m v + + let scope = + // Getting the address of an argument will always be a scope of 1. + if IsValArgument env v then 1 + else limit.scope + + let flags = + if HasLimitFlag LimitFlags.StackReferringSpanLike limit then + LimitFlags.ByRefOfStackReferringSpanLike + elif HasLimitFlag LimitFlags.SpanLike limit then + LimitFlags.ByRefOfSpanLike + else + LimitFlags.ByRef + + { scope = scope; flags = flags } + +let LimitVal cenv (v: Val) limit = + if not v.IgnoresByrefScope then + cenv.limitVals[v.Stamp] <- limit + +let BindVal cenv env (exprRange: Range option) (v: Val) = + cenv.boundVals[v.Stamp] <- 1 + + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + env.mustTailCall <- Zset.add v env.mustTailCall + match exprRange with + | Some r when not (env.mustTailCallRanges.ContainsKey v.Stamp) -> + env.mustTailCallRanges <- Map.add v.Stamp r env.mustTailCallRanges + | _ -> () + +let BindVals cenv env (exprRanges: Range option list) vs = + let zipped = List.zip exprRanges vs + zipped + |> List.iter (fun (exprRange, v) -> BindVal cenv env exprRange v) + +//-------------------------------------------------------------------------- +// approx walk of type +//-------------------------------------------------------------------------- + +/// Indicates whether a byref or byref-like type is permitted at a particular location +// [] +// type PermitByRefType = +// /// Don't permit any byref or byref-like types +// | None +// +// /// Don't permit any byref or byref-like types on inner types. +// | NoInnerByRefLike +// +// /// Permit only a Span or IsByRefLike type +// | SpanLike +// +// /// Permit all byref and byref-like types +// | All + + +/// Indicates whether an address-of operation is permitted at a particular location +[] +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.Disallow = + match ctxt with + | PermitByRefExpr.Yes + | PermitByRefExpr.YesReturnable + | PermitByRefExpr.YesReturnableNonLocal -> false + | _ -> true + + member ctxt.PermitOnlyReturnable = + match ctxt with + | PermitByRefExpr.YesReturnable + | PermitByRefExpr.YesReturnableNonLocal -> true + | _ -> false + + member ctxt.PermitOnlyReturnableNonLocal = + match ctxt with + | 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 if a function is a quotation splice operator +let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.splice_raw_expr_vref + +let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = + env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) + +let rec allRangesOfModDef mdef = + let abstractSlotRangesOfTycons (tycons: Tycon list) = + abstractSlotValRefsOfTycons tycons + |> List.map (fun v -> v.Deref.Range) + + seq { match mdef with + | TMDefRec(tycons = tycons; bindings = mbinds) -> + yield! abstractSlotRangesOfTycons tycons + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + let r = + match (stripExpr bind.Expr) with + | Expr.Lambda _ -> bind.Expr.Range + | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range + | e -> e.Range + yield r + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allRangesOfModDef def + | TMDefLet(binding = bind) -> + let e = stripExpr bind.Expr + yield e.Range + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allRangesOfModDef def + } + +/// Check an expression, where the expression is in a position where byrefs can be generated +let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = + CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore + +/// Check a value +and CheckValRef (cenv: cenv) (env: env) (v: ValRef) m (_ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = + + if cenv.reportErrors then + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then + warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) + +/// Check a use of a value +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, _vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = + + let limit = GetLimitVal cenv env m vref.Deref + + CheckValRef cenv env vref m ctxt isTailCall + + limit + +/// Check an expression, given information about the position of the expression +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (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) -> + + if cenv.reportErrors then + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match f with + | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> + + let canTailCall, noTailCallBlockers = + match isTailCall with + | IsTailCall.No -> + false, true + | 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, noTailCallBlockers + else + true, true + + if not canTailCall then + if not noTailCallBlockers then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + elif (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange _m) then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + | _ -> () + | _ -> () + +and CheckCallLimitArgs cenv _env m returnTy limitArgs (_ctxt: PermitByRefExpr) = + let isReturnByref = isByrefTy cenv.g returnTy + let isReturnSpanLike = isSpanLikeTy cenv.g m returnTy + + // If return is a byref, and being used as a return, then a single argument cannot be a local-byref or a stack referring span-like. + let isReturnLimitedByRef = + isReturnByref && + (HasLimitFlag LimitFlags.ByRef limitArgs || + HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs) + + // If return is a byref, and being used as a return, then a single argument cannot be a stack referring span-like or a local-byref of a stack referring span-like. + let isReturnLimitedSpanLike = + isReturnSpanLike && + (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || + HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs) + + if isReturnLimitedByRef then + if isSpanLikeTy cenv.g m (destByrefTy cenv.g returnTy) then + let isStackReferring = + HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || + HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs + if isStackReferring then + { limitArgs with flags = LimitFlags.ByRefOfStackReferringSpanLike } + else + { limitArgs with flags = LimitFlags.ByRefOfSpanLike } + else + { limitArgs with flags = LimitFlags.ByRef } + + elif isReturnLimitedSpanLike then + { scope = 1; flags = LimitFlags.StackReferringSpanLike } + + elif isReturnByref then + if isSpanLikeTy cenv.g m (destByrefTy cenv.g returnTy) then + { limitArgs with flags = LimitFlags.ByRefOfSpanLike } + else + { limitArgs with flags = LimitFlags.ByRef } + + elif isReturnSpanLike then + { scope = 1; flags = LimitFlags.SpanLike } + + else + { scope = 1; flags = LimitFlags.None } + +/// Check call arguments, including the return argument. +and CheckCall cenv env m returnTy args ctxts ctxt = + 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. +and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = + match args with + | [] -> failwith "CheckCallWithReceiver: Argument list is empty." + | receiverArg :: args -> + + let receiverContext, ctxts = + match ctxts with + | [] -> PermitByRefExpr.No, [] + | ctxt :: ctxts -> ctxt, ctxts + + let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No + let limitArgs = + 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. + CombineTwoLimits limitArgs { receiverLimit with scope = 1 } + else + limitArgs + CheckCallLimitArgs cenv env m returnTy limitArgs ctxt + +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 IsTailCall.No e1 + // tailcall + CheckExprLinear cenv env e2 ctxt contf isTailCall + + | 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 + + let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind + BindVal cenv env None v + LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } + // tailcall + CheckExprLinear cenv env body ctxt contf isTailCall + + | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> + argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) + // tailcall + CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) isTailCall + + | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, _m, _ty) -> + CheckDecisionTree cenv env dtree + let lim1 = CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 + // tailcall + CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) isTailCall + + | Expr.DebugPoint (_, innerExpr) -> + CheckExprLinear cenv env innerExpr ctxt contf isTailCall + + | _ -> + // not a linear expression + 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 (isTailCall: IsTailCall) : bool = + let g = cenv.g + + match env.resumableCode with + | Resumable.None -> + false + | Resumable.ResumableExpr allowed -> + match expr with + | IfUseResumableStateMachinesExpr g (thenExpr, 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) -> + CheckExprNoByrefs cenv env isTailCall noneBranchExpr + BindVal cenv env None someVar + CheckExprNoByrefs cenv env isTailCall someBranchExpr + true + + | ResumeAtExpr g pcExpr -> + CheckExprNoByrefs cenv env isTailCall pcExpr + true + + | ResumableCodeInvoke g (_, f, args, _, _) -> + 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 } isTailCall e1 + CheckExprNoByrefs cenv env isTailCall e2 + true + + | WhileExpr (_sp1, _sp2, guardExpr, bodyExpr, _m) -> + 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 } isTailCall e1 + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 + BindVal cenv env None v + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 + true + + | TryWithExpr (_spTry, _spWith, _resTy, bodyExpr, _filterVar, filterExpr, _handlerVar, handlerExpr, _m) -> + 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 } 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, _)) -> + let exprRanges = List.replicate vs.Length None + BindVals cenv env exprRanges vs + CheckExprNoByrefs cenv env isTailCall targetExpr) + CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree + true + + | Expr.Let (bind, bodyExpr, _m, _) + // Restriction: resumable code can't contain local constrained generic functions + when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> + CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore + BindVal cenv env None bind.Var + 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 isTailCall bodyExpr + true + + // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match + | Expr.Const (Const.Zero, _, _) -> + true + + | Expr.DebugPoint (_, 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) (isTailCall: IsTailCall) : Limit = + + // 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 + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall + let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr + let expr = stripExpr expr + + match TryCheckResumableCodeConstructs cenv env expr isTailCall with + | true -> + // we've handled the special cases of resumable code and don't do other checks. + NoLimit + | false -> + + // Handle ResumableExpr --> other expression + let env = { env with resumableCode = Resumable.None } + + match expr with + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Let _ + | Expr.Sequential (_, _, NormalSeq, _) + | Expr.DebugPoint _ -> + CheckExprLinear cenv env expr ctxt id isTailCall + + | Expr.Sequential (e1, e2, ThenDoSeq, _) -> + CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env IsTailCall.No e2 + NoLimit + + | Expr.Const (_, _m, _ty) -> + NoLimit + + | Expr.Val (vref, vFlags, m) -> + CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall + + | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> + CheckQuoteExpr cenv env (ast, savedConv, m, ty) + + | StructStateMachineExpr g info -> + CheckStructStateMachineExpr cenv env expr info + + | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> + CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) + + // Allow base calls to F# methods + | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) + when ((match vFlags with VSlotDirectCall -> true | _ -> false) && + baseVal.IsBaseVal) -> + + CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) + + // 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 env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) + + | Expr.Op (op, tyargs, args, m) -> + CheckExprOp cenv env (op, tyargs, args, m) ctxt expr + + // Allow 'typeof' calls as a special case, the only accepted use of System.Void! + | TypeOfExpr g ty when isVoidTy g ty -> + NoLimit + + // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! + | TypeDefOfExpr g ty when isVoidTy g ty -> + NoLimit + + // Allow '%expr' in quotations + | Expr.App (Expr.Val (vref, _, _), _, tinst, [arg], m) when isSpliceOperator g vref && env.quote -> + CheckSpliceApplication cenv env (tinst, arg, m) + + // Check an application + | Expr.App (f, _fty, tyargs, argsl, m) -> + CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall + + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> + CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall + + | Expr.TyLambda (_, tps, _, m, bodyTy) -> + CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall + + | Expr.TyChoose (tps, e1, _) -> + let env = BindTypars g env tps + CheckExprNoByrefs cenv env isTailCall e1 + NoLimit + + | Expr.Match (_, _, dtree, targets, m, ty) -> + CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall + + | Expr.LetRec (binds, bodyExpr, _, _) -> + CheckLetRec cenv env (binds, bodyExpr) isTailCall + + | Expr.StaticOptimization (constraints, e2, e3, m) -> + CheckStaticOptimization cenv env (constraints, e2, e3, m) + + | Expr.WitnessArg _ -> + NoLimit + + | Expr.Link _ -> + failwith "Unexpected reclink" + +and CheckQuoteExpr cenv env (ast, _savedConv, _m, _ty) = + CheckExprNoByrefs cenv {env with quote=true} IsTailCall.No ast + NoLimit + +and CheckStructStateMachineExpr cenv env _expr info = + + let (_dataTy, + (moveNextThisVar, moveNextExpr), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), + (afterCodeThisVar, afterCodeBody)) = info + + let exprRanges = [None; None; None; None] + BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] + CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr + CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody + CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody + NoLimit + +and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, _m) = + CheckExprNoByrefs cenv env IsTailCall.No superInitCall + CheckMethods cenv env basev (ty, overrides) + CheckInterfaceImpls cenv env basev iimpls + + NoLimit + +and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) = + let memberInfo = Option.get v.MemberInfo + if memberInfo.MemberFlags.IsDispatchSlot then + NoLimit + else + let env = { env with isInAppExpr = true } + + CheckValRef cenv env v m PermitByRefExpr.No IsTailCall.No + CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No + +and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, baseVal, rest, m) = + CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No + CheckExprsPermitByRefLike cenv env rest + +and CheckSpliceApplication cenv env (_tinst, arg, _m) = + CheckExprNoByrefs cenv env IsTailCall.No arg + NoLimit + +and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) = + let g = cenv.g + + let returnTy = tyOfExpr g expr + + let env = { env with isInAppExpr = true } + + CheckExprNoByrefs cenv env isTailCall 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 env m returnTy argsl ctxts ctxt + else + CheckCall cenv env m returnTy argsl ctxts ctxt + +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 isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + +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 isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + +and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) isTailCall = + CheckDecisionTree cenv env dtree + CheckDecisionTreeTargets cenv env targets ctxt isTailCall + +and CheckLetRec cenv env (binds, bodyExpr) isTailCall = + let vals = valsOfBinds binds + let exprRanges = List.replicate vals.Length None + BindVals cenv env exprRanges vals + CheckBindings cenv env binds + CheckExprNoByrefs cenv env isTailCall bodyExpr + NoLimit + +and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = + CheckExprNoByrefs cenv env IsTailCall.No e2 + CheckExprNoByrefs cenv env IsTailCall.No e3 + NoLimit + +and CheckMethods cenv env baseValOpt (ty, methods) = + methods |> List.iter (CheckMethod cenv env baseValOpt ty) + +and CheckMethod cenv env _baseValOpt ty (TObjExprMethod(_, _, tps, vs, body, _m)) = + let env = BindTypars cenv.g env tps + let vs = List.concat vs + let env = BindArgVals env vs + let env = + // Body of ResumableCode delegate + if isResumableCodeTy cenv.g ty then + { env with resumableCode = Resumable.ResumableExpr false } + else + { env with resumableCode = Resumable.None } + 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) + +and CheckInterfaceImpl cenv env baseValOpt overrides = + CheckMethods cenv env baseValOpt overrides + +and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = + 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 env [e1;e2] + + | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], 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, _, _)] -> + CheckExprsNoByRefLike cenv env [e1;e2;e3] + + | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> + 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 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), _, _ -> + + let hasReceiver = + (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) && + not args.IsEmpty + + let returnTy = tyOfExpr g expr + + 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 env m returnTy args argContexts ctxt + else + CheckCall cenv env m returnTy args argContexts ctxt + | _ -> + if hasReceiver then + CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes + else + CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes + + | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> + match ctxt with + | PermitByRefExpr.YesTupleOfArgs nArity -> + if cenv.reportErrors then + if args.Length <> nArity then + errorR(InternalError("Tuple arity does not correspond to planned function argument arity", m)) + // This tuple should not be generated. The known function arity + // means it just bundles arguments. + CheckExprsPermitByRefLike cenv env args + | _ -> + CheckExprsNoByRefLike cenv env args + + | TOp.LValueOp (LAddrOf _, vref), _, _ -> + let limit1 = GetLimitValByRef cenv env m vref.Deref + let limit2 = CheckExprsNoByRefLike cenv env args + let limit = CombineTwoLimits limit1 limit2 + + limit + + | TOp.LValueOp (LByrefSet, _vref), _, [_arg] -> + NoLimit + + | TOp.LValueOp (LByrefGet, vref), _, [] -> + let limit = GetLimitVal cenv env m vref.Deref + if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then + { scope = 1; flags = LimitFlags.StackReferringSpanLike } + elif HasLimitFlag LimitFlags.ByRefOfSpanLike limit then + { scope = 1; flags = LimitFlags.SpanLike } + else + { scope = 1; flags = LimitFlags.None } + + | TOp.LValueOp (LSet, _vref), _, [_arg] -> + NoLimit + + | TOp.AnonRecdGet _, _, [arg1] + | TOp.TupleFieldGet _, _, [arg1] -> + CheckExprsPermitByRefLike cenv env [arg1] + + | TOp.ValFieldGet _rf, _, [arg1] -> + CheckExprsPermitByRefLike cenv env [arg1] + + | TOp.ValFieldSet _rf, _, [_arg1;_arg2] -> + 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 isTailCall + else + CheckExprNoByrefs cenv env isTailCall x + NoLimit + + | TOp.Reraise, [_ty1], [] -> + NoLimit + + // Check get of static field + | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [] -> + NoLimit + + // 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 env obj ctxt IsTailCall.No + + | TOp.UnionCaseFieldGet _, _, [arg1] -> + CheckExprPermitByRefLike cenv env arg1 + + | TOp.UnionCaseTagGet _, _, [arg1] -> + CheckExprPermitByRefLike cenv env 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 env obj ctxt IsTailCall.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 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 + + // Read a .NET instance field + | [ I_ldfld (_alignment, _vol, _fspec) ], _ -> + // permit byref for lhs lvalue + CheckExprsPermitByRefLike cenv env args + + // Read a .NET instance field + | [ I_ldfld (_alignment, _vol, _fspec); AI_nop ], _ -> + // permit byref for lhs lvalue of readonly value + CheckExprsPermitByRefLike cenv env args + + | [ I_ldsflda _fspec ], [] -> + NoLimit + + | [ I_ldflda _fspec ], [obj] -> + + // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable + CheckExpr cenv env obj ctxt IsTailCall.No + + | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> + // permit byref for lhs lvalue + let limit = CheckExprPermitByRefLike cenv env lhsArray + CheckExprsNoByRefLike cenv env indices |> ignore + limit + + | [ AI_conv _ ], _ -> + // permit byref for args to conv + CheckExprsPermitByRefLike cenv env args + + | _ -> + CheckExprsNoByRefLike cenv env args + + | TOp.TraitCall _, _, _ -> + // CheckTypeInstNoByrefs cenv env m tyargs + // allow args to be byref here + CheckExprsPermitByRefLike cenv env args + + | TOp.Recd _, _, _ -> + // CheckTypeInstNoByrefs cenv env m tyargs + CheckExprsPermitByRefLike cenv env args + + | _ -> + // CheckTypeInstNoByrefs cenv env m tyargs + CheckExprsNoByRefLike cenv env args + +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) + + // 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) -> + let env = BindTypars g env tps + CheckLambdas isTop memberVal cenv env inlined valReprInfo isTailCall 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) + let env = BindTypars g env tps + let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt + let restArgs = List.concat vsl + let syntacticArgs = thisAndBase @ restArgs + let env = BindArgVals env restArgs + + match memInfo with + | None -> () + | Some mi -> + // ctorThis and baseVal values are always considered used + for v in thisAndBase do v.SetHasBeenReferenced() + // instance method 'this' is always considered used + match mi.MemberFlags.IsInstance, restArgs with + | true, firstArg :: _ -> firstArg.SetHasBeenReferenced() + | _ -> () + // any byRef arguments are considered used, as they may be 'out's + for arg in restArgs do + if isByrefTy g arg.Type then + arg.SetHasBeenReferenced() + + for arg in syntacticArgs do + BindVal cenv env None arg + + // 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 env body |> ignore + else + CheckExprNoByrefs cenv env isTailCall body + + NoLimit + + // This path is for expression bindings that are not actually lambdas + | _ -> + let m = mOrig + + 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 isTailCall + else + CheckExprNoByrefs cenv env isTailCall expr + NoLimit + + limit + +and CheckExprs cenv env exprs ctxts isTailCall : Limit = + let ctxts = Array.ofList ctxts + let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No + exprs + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) isTailCall) + |> CombineLimits + +and CheckExprsNoByRefLike cenv env exprs : Limit = + for expr in exprs do + CheckExprNoByrefs cenv env IsTailCall.No expr + NoLimit + +and CheckExprsPermitByRefLike cenv env exprs : Limit = + exprs + |> List.map (CheckExprPermitByRefLike cenv env) + |> CombineLimits + +and CheckExprPermitByRefLike cenv env expr : Limit = + CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No + +and CheckExprPermitReturnableByRef cenv env expr : Limit = + CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No + +and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = + targets + |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) + |> List.ofArray + |> CombineLimits + +and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = + let exprRanges = List.replicate vs.Length None + BindVals cenv env exprRanges vs + CheckExpr cenv env targetExpr ctxt isTailCall + +and CheckDecisionTree cenv env dtree = + match dtree with + | TDSuccess (resultExprs, _) -> + CheckExprsNoByRefLike cenv env resultExprs |> ignore + | TDBind(bind, rest) -> + CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore + CheckDecisionTree cenv env rest + | TDSwitch (inpExpr, cases, dflt, m) -> + CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) + +and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = + CheckExprPermitByRefLike cenv env inpExpr |> ignore// can be byref for struct union switch + for (TCase(discrim, dtree)) in cases do + CheckDecisionTreeTest cenv env m discrim + CheckDecisionTree cenv env dtree + dflt |> Option.iter (CheckDecisionTree cenv env) + +and CheckDecisionTreeTest cenv env _m discrim = + match discrim with + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env IsTailCall.No exp + | _ -> () + +and CheckAttrib cenv env (Attrib(_tcref, _, args, props, _, _, _m)) = + props |> List.iter (fun (AttribNamedArg(_, _, _, expr)) -> CheckAttribExpr cenv env expr) + args |> List.iter (CheckAttribExpr cenv env) + +and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = + CheckExprNoByrefs cenv env IsTailCall.No expr + CheckExprNoByrefs cenv env IsTailCall.No vexpr + CheckAttribArgExpr cenv env vexpr + +and CheckAttribArgExpr cenv env expr = + let g = cenv.g + match expr with + + // Detect standard constants + | Expr.Const (_c, _m, _) -> + () + | Expr.Op (TOp.Array, [_elemTy], args, _m) -> + List.iter (CheckAttribArgExpr cenv env) args + | TypeOfExpr g _ -> + () + | TypeDefOfExpr g _ -> + () + | Expr.Op (TOp.Coerce, _, [arg], _) -> + CheckAttribArgExpr cenv env arg + | EnumExpr g arg1 -> + CheckAttribArgExpr cenv env arg1 + | AttribBitwiseOrExpr g (arg1, arg2) -> + CheckAttribArgExpr cenv env arg1 + CheckAttribArgExpr cenv env arg2 + | _ -> () + +and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : Limit = + let g = cenv.g + let isTop = Option.isSome bind.Var.ValReprInfo + //printfn "visiting %s..." v.DisplayName + + let env = { env with external = env.external || g.attrib_DllImportAttribute |> Option.exists (fun attr -> HasFSharpAttribute g attr v.Attribs) } + + if cenv.reportErrors then + + match v.PublicPath with + | None -> () + | _ -> + if + // Don't support implicit [] on generated members, except the implicit members + // for 'let' bound functions in classes. + (not v.IsCompilerGenerated || v.IsIncrClassGeneratedMember) && + + (// Check the attributes on any enclosing module + env.reflect || + // Check the attributes on the value + HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.Attribs || + // Also check the enclosing type for members - for historical reasons, in the TAST member values + // are stored in the entity that encloses the type, hence we will not have noticed the ReflectedDefinition + // on the enclosing type at this point. + HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then + + cenv.usesQuotations <- true + + // If we've already recorded a definition then skip this + match v.ReflectedDefinition with + | None -> v.SetValDefn bindRhs + | Some _ -> () + + let isTailCall = IsTailCall.YesFromVal g bind.Var + let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData + + let env = + if isReturnsResumableCodeTy g v.TauType then + { env with resumableCode = Resumable.ResumableExpr false } + else + env + + 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 (isRec: bool) (TBind(_v, _e, _) as bind) = + if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match bind.Expr with + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + let rec checkTailCall (insideSubBinding: bool) expr = + match expr with + | Expr.Val(valRef, _valUseFlag, m) -> + if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) + | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + checkTailCall insideSubBinding funcExpr + exprs |> List.iter (checkTailCall insideSubBinding) + | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value + | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + checkTailCall insideSubBinding bodyExpr + | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let(binding, bodyExpr, _range, _frees) -> + checkTailCall true binding.Expr + checkTailCall insideSubBinding bodyExpr + | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | _ -> () + checkTailCall false bodyExpr + | _ -> () + + CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore + +//-------------------------------------------------------------------------- +// check modules +//-------------------------------------------------------------------------- + +let rec CheckDefnsInModule cenv env mdefs = + for mdef in mdefs do + CheckDefnInModule cenv env mdef + +and CheckDefnInModule cenv env mdef = + match mdef with + | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> + if isRec then + let ranges = allRangesOfModDef mdef |> Seq.toList |> List.map Some + BindVals cenv env ranges (allValsOfModDef mdef |> Seq.toList) + List.iter (CheckModuleSpec cenv env isRec) mspecs + | TMDefLet(bind, _m) -> + CheckModuleBinding cenv env false bind + BindVal cenv env (Some bind.Expr.Range) bind.Var + | TMDefOpens _ -> + () + | TMDefDo(e, _m) -> + let isTailCall = + match stripDebugPoints e with + | Expr.App(funcExpr = funcExpr) -> + match funcExpr with + | ValUseAtApp (vref, _valUseFlags) -> IsTailCall.YesFromVal cenv.g vref.Deref + | _ -> IsTailCall.No + | _ -> IsTailCall.No + CheckExprNoByrefs cenv env isTailCall e + | TMDefs defs -> CheckDefnsInModule cenv env defs + +and CheckModuleSpec cenv env isRec mbind = + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> + BindVals cenv env [None] (valsOfBinds [bind]) + CheckModuleBinding cenv env isRec bind + | ModuleOrNamespaceBinding.Module (mspec, rhs) -> + let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } + CheckDefnInModule cenv env rhs + +let CheckImplFileContents cenv env implFileTy implFileContents = + let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy + let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } + CheckDefnInModule cenv env implFileContents + +let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, _extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = + let cenv = + { g = g + reportErrors = reportErrors + boundVals = Dictionary<_, _>(100, HashIdentity.Structural) + limitVals = Dictionary<_, _>(100, HashIdentity.Structural) + stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") + potentialUnboundUsesOfVals = Map.empty + anonRecdTypes = StampMap.Empty + usesQuotations = false + infoReader = infoReader + internalsVisibleToPaths = internalsVisibleToPaths + amap = amap + denv = denv + viewCcu = viewCcu + isLastCompiland = isLastCompiland + isInternalTestSpanStackReferring = isInternalTestSpanStackReferring + tcVal = tcValF + entryPointGiven = false } + + let env = + { sigToImplRemapInfo=[] + quote=false + boundTyparNames=[] + argVals = ValMap.Empty + mustTailCall = Zset.empty valOrder + mustTailCallRanges = Map.Empty + boundTypars= TyparMap.Empty + reflect=false + external=false + returnScope = 0 + isInAppExpr = false + resumableCode = Resumable.None } + + CheckImplFileContents cenv env implFileTy implFileContents + + cenv.entryPointGiven, cenv.anonRecdTypes diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 2ebec6942dd..f00dfae7ca0 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -337,6 +337,7 @@ + From 7693a615bb25b0f60a655debbe13f95ef2fb077a Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 15:38:40 +0200 Subject: [PATCH 24/77] first steps to remove limits calculations --- src/Compiler/Checking/TailCallChecks.fs | 228 ++++++------------------ 1 file changed, 57 insertions(+), 171 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index eb6702abbf8..351bb3e3487 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -247,60 +247,6 @@ let IsValArgument env (v: Val) = let IsValLocal env (v: Val) = v.ValReprInfo.IsNone && not (IsValArgument env v) -/// Get the limit of the val. -let GetLimitVal cenv env m (v: Val) = - let limit = - match cenv.limitVals.TryGetValue v.Stamp with - | true, limit -> limit - | _ -> - if IsValLocal env v then - { scope = 1; flags = LimitFlags.None } - else - NoLimit - - if isSpanLikeTy cenv.g m v.Type then - // The value is a limited Span or might have become one through mutation - let isMutable = v.IsMutable && cenv.isInternalTestSpanStackReferring - let isLimited = HasLimitFlag LimitFlags.StackReferringSpanLike limit - - if isMutable || isLimited then - { limit with flags = LimitFlags.StackReferringSpanLike } - else - { limit with flags = LimitFlags.SpanLike } - - elif isByrefTy cenv.g v.Type then - let isByRefOfSpanLike = isSpanLikeTy cenv.g m (destByrefTy cenv.g v.Type) - - if isByRefOfSpanLike then - if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then - { limit with flags = LimitFlags.ByRefOfStackReferringSpanLike } - else - { limit with flags = LimitFlags.ByRefOfSpanLike } - else - { limit with flags = LimitFlags.ByRef } - - else - { limit with flags = LimitFlags.None } - -/// Get the limit of the val by reference. -let GetLimitValByRef cenv env m v = - let limit = GetLimitVal cenv env m v - - let scope = - // Getting the address of an argument will always be a scope of 1. - if IsValArgument env v then 1 - else limit.scope - - let flags = - if HasLimitFlag LimitFlags.StackReferringSpanLike limit then - LimitFlags.ByRefOfStackReferringSpanLike - elif HasLimitFlag LimitFlags.SpanLike limit then - LimitFlags.ByRefOfSpanLike - else - LimitFlags.ByRef - - { scope = scope; flags = flags } - let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit @@ -324,22 +270,6 @@ let BindVals cenv env (exprRanges: Range option list) vs = // approx walk of type //-------------------------------------------------------------------------- -/// Indicates whether a byref or byref-like type is permitted at a particular location -// [] -// type PermitByRefType = -// /// Don't permit any byref or byref-like types -// | None -// -// /// Don't permit any byref or byref-like types on inner types. -// | NoInnerByRefLike -// -// /// Permit only a Span or IsByRefLike type -// | SpanLike -// -// /// Permit all byref and byref-like types -// | All - - /// Indicates whether an address-of operation is permitted at a particular location [] type PermitByRefExpr = @@ -451,13 +381,8 @@ and CheckValRef (cenv: cenv) (env: env) (v: ValRef) m (_ctxt: PermitByRefExpr) ( warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) /// Check a use of a value -and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, _vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = - - let limit = GetLimitVal cenv env m vref.Deref - +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, _vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = CheckValRef cenv env vref m ctxt isTailCall - - limit /// Check an expression, given information about the position of the expression and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = @@ -561,12 +486,11 @@ and CheckCallLimitArgs cenv _env m returnTy limitArgs (_ctxt: PermitByRefExpr) = { scope = 1; flags = LimitFlags.None } /// Check call arguments, including the return argument. -and CheckCall cenv env m returnTy args ctxts ctxt = - let limitArgs = CheckExprs cenv env args ctxts IsTailCall.No - CheckCallLimitArgs cenv env m returnTy limitArgs ctxt +and CheckCall cenv env _m _returnTy args ctxts _ctxt = + CheckExprs cenv env args ctxts IsTailCall.No /// Check call arguments, including the return argument. The receiver argument is handled differently. -and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = +and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = match args with | [] -> failwith "CheckCallWithReceiver: Argument list is empty." | receiverArg :: args -> @@ -576,18 +500,10 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = | [] -> PermitByRefExpr.No, [] | ctxt :: ctxts -> ctxt, ctxts - let receiverLimit = CheckExpr cenv env receiverArg receiverContext IsTailCall.No - let limitArgs = - 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. - CombineTwoLimits limitArgs { receiverLimit with scope = 1 } - else - limitArgs - CheckCallLimitArgs cenv env m returnTy limitArgs ctxt + CheckExpr cenv env receiverArg receiverContext IsTailCall.No + CheckExprs cenv env args ctxts (IsTailCall.Yes false) -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) (isTailCall: IsTailCall) = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) (isTailCall: IsTailCall) : unit = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> CheckExprNoByrefs cenv env IsTailCall.No e1 @@ -603,9 +519,8 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf else PermitByRefExpr.Yes - let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind + CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind BindVal cenv env None v - LimitVal cenv v { limit with scope = if isByRef then limit.scope else env.returnScope } // tailcall CheckExprLinear cenv env body ctxt contf isTailCall @@ -616,16 +531,16 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, _m, _ty) -> CheckDecisionTree cenv env dtree - let lim1 = CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 + CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) isTailCall + CheckExprLinear cenv env e2 ctxt id isTailCall | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt contf isTailCall | _ -> // not a linear expression - contf (CheckExpr cenv env expr ctxt isTailCall) + 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) @@ -698,7 +613,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo | Expr.Let (bind, bodyExpr, _m, _) // Restriction: resumable code can't contain local constrained generic functions when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> - CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind |> ignore + CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind BindVal cenv env None bind.Var CheckExprNoByrefs cenv env isTailCall bodyExpr true @@ -720,7 +635,7 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo false /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : Limit = +and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = // Guard the stack for deeply nested expressions cenv.stackGuard.Guard <| fun () -> @@ -737,7 +652,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa match TryCheckResumableCodeConstructs cenv env expr isTailCall with | true -> // we've handled the special cases of resumable code and don't do other checks. - NoLimit + () | false -> // Handle ResumableExpr --> other expression @@ -754,10 +669,9 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.Sequential (e1, e2, ThenDoSeq, _) -> CheckExprNoByrefs cenv env IsTailCall.No e1 CheckExprNoByrefs cenv env IsTailCall.No e2 - NoLimit | Expr.Const (_, _m, _ty) -> - NoLimit + () | Expr.Val (vref, vFlags, m) -> CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall @@ -789,11 +703,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa // Allow 'typeof' calls as a special case, the only accepted use of System.Void! | TypeOfExpr g ty when isVoidTy g ty -> - NoLimit + () // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! | TypeDefOfExpr g ty when isVoidTy g ty -> - NoLimit + () // Allow '%expr' in quotations | Expr.App (Expr.Val (vref, _, _), _, tinst, [arg], m) when isSpliceOperator g vref && env.quote -> @@ -812,7 +726,6 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.TyChoose (tps, e1, _) -> let env = BindTypars g env tps CheckExprNoByrefs cenv env isTailCall e1 - NoLimit | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall @@ -824,14 +737,13 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa CheckStaticOptimization cenv env (constraints, e2, e3, m) | Expr.WitnessArg _ -> - NoLimit + () | Expr.Link _ -> failwith "Unexpected reclink" and CheckQuoteExpr cenv env (ast, _savedConv, _m, _ty) = CheckExprNoByrefs cenv {env with quote=true} IsTailCall.No ast - NoLimit and CheckStructStateMachineExpr cenv env _expr info = @@ -845,19 +757,16 @@ and CheckStructStateMachineExpr cenv env _expr info = 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) = CheckExprNoByrefs cenv env IsTailCall.No superInitCall CheckMethods cenv env basev (ty, overrides) CheckInterfaceImpls cenv env basev iimpls - NoLimit - -and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) = +and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) : unit = let memberInfo = Option.get v.MemberInfo if memberInfo.MemberFlags.IsDispatchSlot then - NoLimit + () else let env = { env with isInAppExpr = true } @@ -865,15 +774,14 @@ and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) = CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No -and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, baseVal, rest, m) = +and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, baseVal, rest, m) : unit = CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprsPermitByRefLike cenv env rest and CheckSpliceApplication cenv env (_tinst, arg, _m) = CheckExprNoByrefs cenv env IsTailCall.No arg - NoLimit -and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) = +and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) : unit = let g = cenv.g let returnTy = tyOfExpr g expr @@ -913,13 +821,11 @@ and CheckLetRec cenv env (binds, bodyExpr) isTailCall = BindVals cenv env exprRanges vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr - NoLimit - + and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = CheckExprNoByrefs cenv env IsTailCall.No e2 CheckExprNoByrefs cenv env IsTailCall.No e3 - NoLimit - + and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty) @@ -941,7 +847,7 @@ and CheckInterfaceImpls cenv env baseValOpt l = and CheckInterfaceImpl cenv env baseValOpt overrides = CheckMethods cenv env baseValOpt overrides -and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = +and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = let g = cenv.g // Special cases @@ -951,18 +857,16 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckExprsNoByRefLike cenv env [e1;e2] | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], 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 + 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, _, _)] -> CheckExprsNoByRefLike cenv env [e1;e2;e3] | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> - 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 + 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 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 + 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 | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, _enclTypeInst, _methInst, retTypes), _, _ -> @@ -994,31 +898,21 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = errorR(InternalError("Tuple arity does not correspond to planned function argument arity", m)) // This tuple should not be generated. The known function arity // means it just bundles arguments. - CheckExprsPermitByRefLike cenv env args + CheckExprsPermitByRefLike cenv env args | _ -> CheckExprsNoByRefLike cenv env args - | TOp.LValueOp (LAddrOf _, vref), _, _ -> - let limit1 = GetLimitValByRef cenv env m vref.Deref - let limit2 = CheckExprsNoByRefLike cenv env args - let limit = CombineTwoLimits limit1 limit2 - - limit + | TOp.LValueOp (LAddrOf _, _vref), _, _ -> + CheckExprsNoByRefLike cenv env args | TOp.LValueOp (LByrefSet, _vref), _, [_arg] -> - NoLimit - - | TOp.LValueOp (LByrefGet, vref), _, [] -> - let limit = GetLimitVal cenv env m vref.Deref - if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then - { scope = 1; flags = LimitFlags.StackReferringSpanLike } - elif HasLimitFlag LimitFlags.ByRefOfSpanLike limit then - { scope = 1; flags = LimitFlags.SpanLike } - else - { scope = 1; flags = LimitFlags.None } + () + + | TOp.LValueOp (LByrefGet, _vref), _, [] -> + () | TOp.LValueOp (LSet, _vref), _, [_arg] -> - NoLimit + () | TOp.AnonRecdGet _, _, [arg1] | TOp.TupleFieldGet _, _, [arg1] -> @@ -1028,7 +922,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckExprsPermitByRefLike cenv env [arg1] | TOp.ValFieldSet _rf, _, [_arg1;_arg2] -> - NoLimit + () | TOp.Coerce, [tgtTy;srcTy], [x] -> let isTailCall = IsTailCall.YesFromExpr cenv.g x @@ -1036,14 +930,13 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckExpr cenv env x ctxt isTailCall else CheckExprNoByrefs cenv env isTailCall x - NoLimit | TOp.Reraise, [_ty1], [] -> - NoLimit + () // Check get of static field | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [] -> - NoLimit + () // Check get of instance field | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [obj] -> @@ -1083,7 +976,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckExprsPermitByRefLike cenv env args | [ I_ldsflda _fspec ], [] -> - NoLimit + () | [ I_ldflda _fspec ], [obj] -> @@ -1116,7 +1009,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 (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt = +and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt : unit = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) @@ -1159,53 +1052,47 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT CheckExprPermitReturnableByRef cenv env body |> ignore else CheckExprNoByrefs cenv env isTailCall body - - NoLimit // This path is for expression bindings that are not actually lambdas | _ -> let m = mOrig - 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 isTailCall - else - CheckExprNoByrefs cenv env isTailCall expr - NoLimit - - 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 isTailCall + else + CheckExprNoByrefs cenv env isTailCall expr + -and CheckExprs cenv env exprs ctxts isTailCall : Limit = +and CheckExprs cenv env exprs ctxts isTailCall : 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 env exp (argArity i) isTailCall) - |> CombineLimits + |> ignore -and CheckExprsNoByRefLike cenv env exprs : Limit = +and CheckExprsNoByRefLike cenv env exprs : unit = for expr in exprs do CheckExprNoByrefs cenv env IsTailCall.No expr - NoLimit -and CheckExprsPermitByRefLike cenv env exprs : Limit = +and CheckExprsPermitByRefLike cenv env exprs : unit = exprs |> List.map (CheckExprPermitByRefLike cenv env) - |> CombineLimits + |> ignore -and CheckExprPermitByRefLike cenv env expr : Limit = +and CheckExprPermitByRefLike cenv env expr : unit = CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No -and CheckExprPermitReturnableByRef cenv env expr : Limit = +and CheckExprPermitReturnableByRef cenv env expr : unit = CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = targets |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) |> List.ofArray - |> CombineLimits + |> ignore -and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) = +and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) : unit = let exprRanges = List.replicate vs.Length None BindVals cenv env exprRanges vs CheckExpr cenv env targetExpr ctxt isTailCall @@ -1263,10 +1150,9 @@ and CheckAttribArgExpr cenv env expr = CheckAttribArgExpr cenv env arg2 | _ -> () -and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : Limit = +and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : unit = let g = cenv.g let isTop = Option.isSome bind.Var.ValReprInfo - //printfn "visiting %s..." v.DisplayName let env = { env with external = env.external || g.attrib_DllImportAttribute |> Option.exists (fun attr -> HasFSharpAttribute g attr v.Attribs) } From ac772f2d2bb7ec07d5315113950ac5b204cffae9 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 15:47:03 +0200 Subject: [PATCH 25/77] remove last bits of limits --- src/Compiler/Checking/TailCallChecks.fs | 133 ++---------------------- 1 file changed, 8 insertions(+), 125 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 351bb3e3487..1847dea483a 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -97,72 +97,6 @@ let BindTypars g env (tps: Typar list) = let BindArgVals env (vs: Val list) = { env with argVals = ValMap.OfList (List.map (fun v -> (v, ())) vs) } -/// Limit flags represent a type(s) returned from checking an expression(s) that is interesting to impose rules on. -[] -type LimitFlags = - | None = 0b00000 - | ByRef = 0b00001 - | ByRefOfSpanLike = 0b00011 - | ByRefOfStackReferringSpanLike = 0b00101 - | SpanLike = 0b01000 - | StackReferringSpanLike = 0b10000 - -[] -type Limit = - { - scope: int - flags: LimitFlags - } - - member this.IsLocal = this.scope >= 1 - -/// Check if the limit has the target limit. -let inline HasLimitFlag targetLimit (limit: Limit) = - limit.flags &&& targetLimit = targetLimit - -let NoLimit = { scope = 0; flags = LimitFlags.None } - -// Combining two limits will result in both limit flags merged. -// If none of the limits are limited by a by-ref or a stack referring span-like -// the scope will be 0. -let CombineTwoLimits limit1 limit2 = - let isByRef1 = HasLimitFlag LimitFlags.ByRef limit1 - let isByRef2 = HasLimitFlag LimitFlags.ByRef limit2 - let isStackSpan1 = HasLimitFlag LimitFlags.StackReferringSpanLike limit1 - let isStackSpan2 = HasLimitFlag LimitFlags.StackReferringSpanLike limit2 - let isLimited1 = isByRef1 || isStackSpan1 - let isLimited2 = isByRef2 || isStackSpan2 - - // A limit that has a stack referring span-like but not a by-ref, - // we force the scope to 1. This is to handle call sites - // that return a by-ref and have stack referring span-likes as arguments. - // This is to ensure we can only prevent out of scope at the method level rather than visibility. - let limit1 = - if isStackSpan1 && not isByRef1 then - { limit1 with scope = 1 } - else - limit1 - - let limit2 = - if isStackSpan2 && not isByRef2 then - { limit2 with scope = 1 } - else - limit2 - - match isLimited1, isLimited2 with - | false, false -> - { scope = 0; flags = limit1.flags ||| limit2.flags } - | true, true -> - { scope = Math.Max(limit1.scope, limit2.scope); flags = limit1.flags ||| limit2.flags } - | true, false -> - { limit1 with flags = limit1.flags ||| limit2.flags } - | false, true -> - { limit2 with flags = limit1.flags ||| limit2.flags } - -let CombineLimits limits = - (NoLimit, limits) - ||> List.fold CombineTwoLimits - let (|ValUseAtApp|_|) e = match e with | InnerExprPat( @@ -202,8 +136,6 @@ let IsValRefIsDllImport g (vref:ValRef) = type cenv = { boundVals: Dictionary // really a hash set - limitVals: Dictionary - mutable potentialUnboundUsesOfVals: StampMap mutable anonRecdTypes: StampMap @@ -247,10 +179,6 @@ let IsValArgument env (v: Val) = let IsValLocal env (v: Val) = v.ValReprInfo.IsNone && not (IsValArgument env v) -let LimitVal cenv (v: Val) limit = - if not v.IgnoresByrefScope then - cenv.limitVals[v.Stamp] <- limit - let BindVal cenv env (exprRange: Range option) (v: Val) = cenv.boundVals[v.Stamp] <- 1 @@ -442,49 +370,6 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i | _ -> () | _ -> () -and CheckCallLimitArgs cenv _env m returnTy limitArgs (_ctxt: PermitByRefExpr) = - let isReturnByref = isByrefTy cenv.g returnTy - let isReturnSpanLike = isSpanLikeTy cenv.g m returnTy - - // If return is a byref, and being used as a return, then a single argument cannot be a local-byref or a stack referring span-like. - let isReturnLimitedByRef = - isReturnByref && - (HasLimitFlag LimitFlags.ByRef limitArgs || - HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs) - - // If return is a byref, and being used as a return, then a single argument cannot be a stack referring span-like or a local-byref of a stack referring span-like. - let isReturnLimitedSpanLike = - isReturnSpanLike && - (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || - HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs) - - if isReturnLimitedByRef then - if isSpanLikeTy cenv.g m (destByrefTy cenv.g returnTy) then - let isStackReferring = - HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || - HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs - if isStackReferring then - { limitArgs with flags = LimitFlags.ByRefOfStackReferringSpanLike } - else - { limitArgs with flags = LimitFlags.ByRefOfSpanLike } - else - { limitArgs with flags = LimitFlags.ByRef } - - elif isReturnLimitedSpanLike then - { scope = 1; flags = LimitFlags.StackReferringSpanLike } - - elif isReturnByref then - if isSpanLikeTy cenv.g m (destByrefTy cenv.g returnTy) then - { limitArgs with flags = LimitFlags.ByRefOfSpanLike } - else - { limitArgs with flags = LimitFlags.ByRef } - - elif isReturnSpanLike then - { scope = 1; flags = LimitFlags.SpanLike } - - else - { scope = 1; flags = LimitFlags.None } - /// Check call arguments, including the return argument. and CheckCall cenv env _m _returnTy args ctxts _ctxt = CheckExprs cenv env args ctxts IsTailCall.No @@ -503,12 +388,12 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = CheckExpr cenv env receiverArg receiverContext IsTailCall.No CheckExprs cenv env args ctxts (IsTailCall.Yes false) -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf : Limit -> Limit) (isTailCall: IsTailCall) : unit = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> CheckExprNoByrefs cenv env IsTailCall.No e1 // tailcall - CheckExprLinear cenv env e2 ctxt contf isTailCall + CheckExprLinear cenv env e2 ctxt isTailCall | Expr.Let (TBind(v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type @@ -522,21 +407,21 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind BindVal cenv env None v // tailcall - CheckExprLinear cenv env body ctxt contf isTailCall + CheckExprLinear cenv env body ctxt isTailCall | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) // tailcall - CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) isTailCall + CheckExprLinear cenv env argLast PermitByRefExpr.No isTailCall | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, _m, _ty) -> CheckDecisionTree cenv env dtree CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt id isTailCall + CheckExprLinear cenv env e2 ctxt isTailCall | Expr.DebugPoint (_, innerExpr) -> - CheckExprLinear cenv env innerExpr ctxt contf isTailCall + CheckExprLinear cenv env innerExpr ctxt isTailCall | _ -> // not a linear expression @@ -664,7 +549,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) | Expr.DebugPoint _ -> - CheckExprLinear cenv env expr ctxt id isTailCall + CheckExprLinear cenv env expr ctxt isTailCall | Expr.Sequential (e1, e2, ThenDoSeq, _) -> CheckExprNoByrefs cenv env IsTailCall.No e1 @@ -985,9 +870,8 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> // permit byref for lhs lvalue - let limit = CheckExprPermitByRefLike cenv env lhsArray + CheckExprPermitByRefLike cenv env lhsArray CheckExprsNoByRefLike cenv env indices |> ignore - limit | [ AI_conv _ ], _ -> // permit byref for args to conv @@ -1275,7 +1159,6 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v { g = g reportErrors = reportErrors boundVals = Dictionary<_, _>(100, HashIdentity.Structural) - limitVals = Dictionary<_, _>(100, HashIdentity.Structural) stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") potentialUnboundUsesOfVals = Map.empty anonRecdTypes = StampMap.Empty From 81e5b7e7b85a363f9de970dce9e9648799436775 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 15:51:02 +0200 Subject: [PATCH 26/77] don't bother with attribute checking here --- src/Compiler/Checking/TailCallChecks.fs | 31 ------------------------- 1 file changed, 31 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 1847dea483a..98588b6a4c5 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -1003,37 +1003,6 @@ and CheckDecisionTreeTest cenv env _m discrim = | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env IsTailCall.No exp | _ -> () -and CheckAttrib cenv env (Attrib(_tcref, _, args, props, _, _, _m)) = - props |> List.iter (fun (AttribNamedArg(_, _, _, expr)) -> CheckAttribExpr cenv env expr) - args |> List.iter (CheckAttribExpr cenv env) - -and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = - CheckExprNoByrefs cenv env IsTailCall.No expr - CheckExprNoByrefs cenv env IsTailCall.No vexpr - CheckAttribArgExpr cenv env vexpr - -and CheckAttribArgExpr cenv env expr = - let g = cenv.g - match expr with - - // Detect standard constants - | Expr.Const (_c, _m, _) -> - () - | Expr.Op (TOp.Array, [_elemTy], args, _m) -> - List.iter (CheckAttribArgExpr cenv env) args - | TypeOfExpr g _ -> - () - | TypeDefOfExpr g _ -> - () - | Expr.Op (TOp.Coerce, _, [arg], _) -> - CheckAttribArgExpr cenv env arg - | EnumExpr g arg1 -> - CheckAttribArgExpr cenv env arg1 - | AttribBitwiseOrExpr g (arg1, arg2) -> - CheckAttribArgExpr cenv env arg1 - CheckAttribArgExpr cenv env arg2 - | _ -> () - and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : unit = let g = cenv.g let isTop = Option.isSome bind.Var.ValReprInfo From 06717ce745c310438e256588b77f0f1557e217ae Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 18:12:03 +0200 Subject: [PATCH 27/77] remove more unneeded code --- src/Compiler/Checking/TailCallChecks.fs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 98588b6a4c5..59e4f4960a3 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -4,7 +4,6 @@ /// is complete. module internal FSharp.Compiler.TailCallChecks -open System open System.Collections.Generic open Internal.Utilities.Collections @@ -171,14 +170,6 @@ type cenv = override x.ToString() = "" -/// Check if the value is an argument of a function -let IsValArgument env (v: Val) = - env.argVals.ContainsVal v - -/// Check if the value is a local, not an argument of a function. -let IsValLocal env (v: Val) = - v.ValReprInfo.IsNone && not (IsValArgument env v) - let BindVal cenv env (exprRange: Range option) (v: Val) = cenv.boundVals[v.Stamp] <- 1 From 6e347c30644cc6f1e48e14aa9c603f7f7ea42af3 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 18:12:29 +0200 Subject: [PATCH 28/77] small optimization --- src/Compiler/Checking/TailCallChecks.fs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 59e4f4960a3..39939f67f17 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -259,14 +259,14 @@ let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.spl let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) -let rec allRangesOfModDef mdef = - let abstractSlotRangesOfTycons (tycons: Tycon list) = +let rec allValsAndRangesOfModDef mdef = + let abstractSlotValsAndRangesOfTycons (tycons: Tycon list) = abstractSlotValRefsOfTycons tycons - |> List.map (fun v -> v.Deref.Range) + |> List.map (fun v -> v.Deref, v.Deref.Range) seq { match mdef with | TMDefRec(tycons = tycons; bindings = mbinds) -> - yield! abstractSlotRangesOfTycons tycons + yield! abstractSlotValsAndRangesOfTycons tycons for mbind in mbinds do match mbind with | ModuleOrNamespaceBinding.Binding bind -> @@ -275,16 +275,16 @@ let rec allRangesOfModDef mdef = | Expr.Lambda _ -> bind.Expr.Range | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range | e -> e.Range - yield r - | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allRangesOfModDef def + yield bind.Var, r + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndRangesOfModDef def | TMDefLet(binding = bind) -> let e = stripExpr bind.Expr - yield e.Range + yield bind.Var, e.Range | TMDefDo _ -> () | TMDefOpens _ -> () | TMDefs defs -> for def in defs do - yield! allRangesOfModDef def + yield! allValsAndRangesOfModDef def } /// Check an expression, where the expression is in a position where byrefs can be generated @@ -1081,8 +1081,8 @@ and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> if isRec then - let ranges = allRangesOfModDef mdef |> Seq.toList |> List.map Some - BindVals cenv env ranges (allValsOfModDef mdef |> Seq.toList) + let valls, ranges = allValsAndRangesOfModDef mdef |> Seq.toList |> List.unzip + BindVals cenv env (ranges |> List.map Some) valls List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, _m) -> CheckModuleBinding cenv env false bind From 08e5e7f63d4585670d66b2d1633d353a9c72fcd9 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 18:29:08 +0200 Subject: [PATCH 29/77] Adjust error number after main merge --- .../ErrorMessages/TailCallAttribute.fs | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 3d556c9ab46..3b978cbc387 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -21,14 +21,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 EndColumn = 35 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 11 EndLine = 8 @@ -53,14 +53,14 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 EndColumn = 37 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 8 StartColumn = 13 EndLine = 8 @@ -87,7 +87,7 @@ let rec fact n acc = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 9 StartColumn = 17 EndLine = 9 @@ -148,14 +148,14 @@ and [] baz x = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 EndColumn = 20 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 13 StartColumn = 9 EndLine = 13 @@ -176,7 +176,7 @@ type C () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 24 EndLine = 4 @@ -240,14 +240,14 @@ type F () = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 6 StartColumn = 9 EndLine = 6 EndColumn = 18 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 11 StartColumn = 9 EndLine = 11 @@ -296,7 +296,7 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 5 StartColumn = 17 EndLine = 5 @@ -319,14 +319,14 @@ let rec f x : seq = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 5 StartColumn = 16 EndLine = 5 @@ -383,14 +383,14 @@ let rec f x = async { |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 EndColumn = 23 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 14 EndLine = 4 @@ -441,14 +441,14 @@ module rec M = |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 6 StartColumn = 28 EndLine = 6 EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 10 StartColumn = 28 EndLine = 10 @@ -469,14 +469,14 @@ let run() = let mutable x = 0 in foo(&x) |> typecheck |> shouldFail |> withResults [ - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 3 StartColumn = 29 EndLine = 3 EndColumn = 36 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3568 + { Error = Warning 3569 Range = { StartLine = 4 StartColumn = 34 EndLine = 4 From 51235339b86dea37b77d433e888ab615d6c54be3 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 27 Jun 2023 19:19:07 +0200 Subject: [PATCH 30/77] add TailCallChecks.fs to .fantomasignore --- .fantomasignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.fantomasignore b/.fantomasignore index 4830d0af77d..d08d12abd39 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -39,6 +39,7 @@ src/Compiler/Checking/PatternMatchCompilation.fs src/Compiler/Checking/PostInferenceChecks.fs src/Compiler/Checking/QuotationTranslator.fs src/Compiler/Checking/SignatureConformance.fs +src/Compiler/Checking/TailCallChecks.fs src/Compiler/Checking/TypeHierarchy.fs src/Compiler/Checking/TypeRelations.fs From 295e311655b79a63044ab3b5b84b25c907fef225 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 11:31:31 +0200 Subject: [PATCH 31/77] remove last non-tailrec error reporting from dedicated file --- src/Compiler/Checking/TailCallChecks.fs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 39939f67f17..20feb9d3395 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -496,7 +496,6 @@ and TryCheckResumableCodeConstructs cenv env expr (isTailCall: IsTailCall) : boo // 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 isTailCall bodyExpr true @@ -768,10 +767,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> match ctxt with - | PermitByRefExpr.YesTupleOfArgs nArity -> - if cenv.reportErrors then - if args.Length <> nArity then - errorR(InternalError("Tuple arity does not correspond to planned function argument arity", m)) + | PermitByRefExpr.YesTupleOfArgs _nArity -> // This tuple should not be generated. The known function arity // means it just bundles arguments. CheckExprsPermitByRefLike cenv env args From cf7f834c6edc4b9e473f420e8d2a8b11daac8e5a Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 14:54:55 +0200 Subject: [PATCH 32/77] - add fsi file - trim down some more --- src/Compiler/Checking/CheckDeclarations.fs | 10 +-- src/Compiler/Checking/TailCallChecks.fs | 84 +++------------------ src/Compiler/Checking/TailCallChecks.fsi | 13 ++++ src/Compiler/FSharp.Compiler.Service.fsproj | 1 + 4 files changed, 28 insertions(+), 80 deletions(-) create mode 100644 src/Compiler/Checking/TailCallChecks.fsi diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 2e3fbbef71d..9ad452d35c2 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5507,12 +5507,10 @@ let CheckOneImplFile env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) - TailCallChecks.CheckImplFile - (g, cenv.amap, reportErrors, cenv.infoReader, - env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, - implFileTy, implFileContents, extraAttribs, isLastCompiland, - isInternalTestSpanStackReferring) - |> ignore + TailCallChecks.CheckImplFile + (g, cenv.amap, reportErrors, + implFileContents, extraAttribs) + hasExplicitEntryPoint, anonRecdTypes with exn -> diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 20feb9d3395..8222f6e32d7 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -13,7 +13,6 @@ open FSharp.Compiler open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Features -open FSharp.Compiler.InfoReader open FSharp.Compiler.Syntax open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text @@ -43,15 +42,9 @@ type env = /// The bound type parameter names in scope boundTyparNames: string list - /// The bound type parameters in scope - boundTypars: TyparMap - /// The set of arguments to this method/function argVals: ValMap - /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature - sigToImplRemapInfo: (Remap * SignatureHidingInfo) list - /// Values in this recursive scope that have been marked [] mutable mustTailCall: Zset @@ -78,19 +71,6 @@ type env = override _.ToString() = "" -let BindTypar env (tp: Typar) = - { env with - boundTyparNames = tp.Name :: env.boundTyparNames - boundTypars = env.boundTypars.Add (tp, ()) } - -let BindTypars g env (tps: Typar list) = - let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps - if isNil tps then env else - // Here we mutate to provide better names for generalized type parameters - let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps - PrettyTypes.AssignPrettyTyparNames tps nms - List.fold BindTypar env tps - /// Set the set of vals which are arguments in the active lambda. We are allowed to return /// byref arguments as byref returns. let BindArgVals env (vs: Val list) = @@ -135,38 +115,16 @@ let IsValRefIsDllImport g (vref:ValRef) = type cenv = { boundVals: Dictionary // really a hash set - mutable potentialUnboundUsesOfVals: StampMap - - mutable anonRecdTypes: StampMap - stackGuard: StackGuard g: TcGlobals amap: Import.ImportMap - /// For reading metadata - infoReader: InfoReader - - internalsVisibleToPaths : CompilationPath list - - denv: DisplayEnv - - viewCcu : CcuThunk - reportErrors: bool - isLastCompiland : bool*bool - - isInternalTestSpanStackReferring: bool - // outputs - mutable usesQuotations: bool - - mutable entryPointGiven: bool - - /// Callback required for quotation generation - tcVal: ConstraintSolver.TcValF } + mutable usesQuotations: bool } override x.ToString() = "" @@ -598,8 +556,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall - | Expr.TyChoose (tps, e1, _) -> - let env = BindTypars g env tps + | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv env isTailCall e1 | Expr.Match (_, _, dtree, targets, m, ty) -> @@ -704,8 +661,7 @@ and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty) -and CheckMethod cenv env _baseValOpt ty (TObjExprMethod(_, _, tps, vs, body, _m)) = - let env = BindTypars cenv.g env tps +and CheckMethod cenv env _baseValOpt ty (TObjExprMethod(_, _, _tps, vs, body, _m)) = let vs = List.concat vs let env = BindArgVals env vs let env = @@ -873,11 +829,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = CheckExprsPermitByRefLike cenv env args | TOp.Recd _, _, _ -> - // CheckTypeInstNoByrefs cenv env m tyargs CheckExprsPermitByRefLike cenv env args | _ -> - // CheckTypeInstNoByrefs cenv env m tyargs CheckExprsNoByRefLike cenv env args and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt : unit = @@ -887,14 +841,12 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT // 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) -> - let env = BindTypars g env tps + | Expr.TyChoose (_tps, e1, m) -> CheckLambdas isTop memberVal cenv env inlined valReprInfo isTailCall 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) - let env = BindTypars g env tps + let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt let restArgs = List.concat vsl let syntacticArgs = thisAndBase @ restArgs @@ -1105,44 +1057,28 @@ and CheckModuleSpec cenv env isRec mbind = let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } CheckDefnInModule cenv env rhs -let CheckImplFileContents cenv env implFileTy implFileContents = - let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy - let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } +let CheckImplFileContents cenv env implFileContents = CheckDefnInModule cenv env implFileContents -let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, _extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = +let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = let cenv = { g = g reportErrors = reportErrors boundVals = Dictionary<_, _>(100, HashIdentity.Structural) stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") - potentialUnboundUsesOfVals = Map.empty - anonRecdTypes = StampMap.Empty usesQuotations = false - infoReader = infoReader - internalsVisibleToPaths = internalsVisibleToPaths - amap = amap - denv = denv - viewCcu = viewCcu - isLastCompiland = isLastCompiland - isInternalTestSpanStackReferring = isInternalTestSpanStackReferring - tcVal = tcValF - entryPointGiven = false } + amap = amap } let env = - { sigToImplRemapInfo=[] - quote=false + { quote=false boundTyparNames=[] argVals = ValMap.Empty mustTailCall = Zset.empty valOrder mustTailCallRanges = Map.Empty - boundTypars= TyparMap.Empty reflect=false external=false returnScope = 0 isInAppExpr = false resumableCode = Resumable.None } - CheckImplFileContents cenv env implFileTy implFileContents - - cenv.entryPointGiven, cenv.anonRecdTypes + CheckImplFileContents cenv env implFileContents diff --git a/src/Compiler/Checking/TailCallChecks.fsi b/src/Compiler/Checking/TailCallChecks.fsi new file mode 100644 index 00000000000..9e8b20d19d5 --- /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 + +val CheckImplFile: + g: TcGlobals * + amap: Import.ImportMap * + reportErrors: bool * + implFileContents: ModuleOrNamespaceContents * + _extraAttribs: 'a -> + unit diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index f00dfae7ca0..92276d105ec 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -337,6 +337,7 @@ + From f648155f426788187a9278383b0c96c602eca3fd Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 28 Jun 2023 18:30:46 +0200 Subject: [PATCH 33/77] simplify --- src/Compiler/Checking/TailCallChecks.fs | 38 +++++++++++-------- .../ErrorMessages/TailCallAttribute.fs | 7 ---- 2 files changed, 22 insertions(+), 23 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 8222f6e32d7..6282b49c296 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -45,10 +45,11 @@ type env = /// The set of arguments to this method/function argVals: ValMap - /// Values in this recursive scope that have been marked [] - mutable mustTailCall: Zset + /// Values in module that have been marked [] + mutable mustTailCall: Zset // mutable as this is updated in loops - mutable mustTailCallRanges: Map + /// Recursive scopes of [] attributed values + mutable mustTailCallRanges: Map // mutable as this is updated in loops /// Are we in a quotation? quote : bool @@ -251,7 +252,9 @@ let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = /// Check a value and CheckValRef (cenv: cenv) (env: env) (v: ValRef) m (_ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = - + // To warn for mutually recursive calls like in the following tests: + // ``Warn for invalid tailcalls in rec module`` + // ``Warn successfully for invalid tailcalls in type methods`` if cenv.reportErrors then if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then @@ -269,23 +272,23 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i // Some things are more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs match expr with - | Expr.App (f, _fty, _tyargs, argsl, _m) -> + | Expr.App (f, _fty, _tyargs, argsl, m) -> if cenv.reportErrors then if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then match f with | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - let canTailCall, noTailCallBlockers = + let canTailCall = match isTailCall with - | IsTailCall.No -> - false, true + | IsTailCall.No -> // an upper level has already decided that this is not in a tailcall position + false | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty - let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau _m + let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau m if argsl.Length >= curriedArgInfos.Length then (List.splitAfter curriedArgInfos.Length argsl), returnTy else @@ -307,15 +310,15 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i not (IsValRefIsDllImport cenv.g vref) && not isCCall && not hasByrefArg - noTailCallBlockers, noTailCallBlockers + noTailCallBlockers // blockers that will prevent the IL level from emmiting a tail instruction else - true, true + true - if not canTailCall then - if not noTailCallBlockers then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) - elif (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange _m) then - warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), _m)) + // warn if we call inside of recursive scope in non-tail-call manner or with tail blockers. See + // ``Warn successfully in match clause`` + // ``Warn for byref parameters`` + if not canTailCall && (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange m) then + warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), m)) | _ -> () | _ -> () @@ -991,6 +994,9 @@ and CheckBindings cenv env binds = // Top binds introduce expression, check they are reraise free. let CheckModuleBinding cenv env (isRec: bool) (TBind(_v, _e, _) 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.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 3b978cbc387..d6868feb2ac 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -476,11 +476,4 @@ let run() = let mutable x = 0 in foo(&x) EndColumn = 36 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - { Error = Warning 3569 - Range = { StartLine = 4 - StartColumn = 34 - EndLine = 4 - EndColumn = 41 } - Message = - "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] From fd5141ebfbfced94fb8f6f04f2e898b14d65f4a5 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 11:40:00 +0200 Subject: [PATCH 34/77] Remove resumable checks --- src/Compiler/Checking/TailCallChecks.fs | 132 +----------------------- 1 file changed, 3 insertions(+), 129 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 6282b49c296..bd3c9f522e7 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -28,15 +28,6 @@ let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChec // check environment //-------------------------------------------------------------------------- -[] -type Resumable = - | None - /// Indicates we are expecting resumable code (the body of a ResumableCode delegate or - /// the body of the MoveNextMethod for a state machine) - /// -- allowed: are we inside the 'then' branch of an 'if __useResumableCode then ...' - /// for a ResumableCode delegate. - | ResumableExpr of allowed: bool - type env = { /// The bound type parameter names in scope @@ -65,9 +56,6 @@ type env = /// Are we in an app expression (Expr.App)? isInAppExpr: bool - - /// Are we expecting a resumable code block etc - resumableCode: Resumable } override _.ToString() = "" @@ -379,97 +367,6 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail // not a linear expression 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 (isTailCall: IsTailCall) : bool = - let g = cenv.g - - match env.resumableCode with - | Resumable.None -> - false - | Resumable.ResumableExpr allowed -> - match expr with - | IfUseResumableStateMachinesExpr g (thenExpr, 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) -> - CheckExprNoByrefs cenv env isTailCall noneBranchExpr - BindVal cenv env None someVar - CheckExprNoByrefs cenv env isTailCall someBranchExpr - true - - | ResumeAtExpr g pcExpr -> - CheckExprNoByrefs cenv env isTailCall pcExpr - true - - | ResumableCodeInvoke g (_, f, args, _, _) -> - 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 } isTailCall e1 - CheckExprNoByrefs cenv env isTailCall e2 - true - - | WhileExpr (_sp1, _sp2, guardExpr, bodyExpr, _m) -> - 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 } isTailCall e1 - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e2 - BindVal cenv env None v - CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } isTailCall e3 - true - - | TryWithExpr (_spTry, _spWith, _resTy, bodyExpr, _filterVar, filterExpr, _handlerVar, handlerExpr, _m) -> - 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 } 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, _)) -> - let exprRanges = List.replicate vs.Length None - BindVals cenv env exprRanges vs - CheckExprNoByrefs cenv env isTailCall targetExpr) - CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree - true - - | Expr.Let (bind, bodyExpr, _m, _) - // Restriction: resumable code can't contain local constrained generic functions - when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> - CheckBinding cenv { env with resumableCode = Resumable.None } false PermitByRefExpr.Yes bind - BindVal cenv env None bind.Var - 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 -> - CheckExprNoByrefs cenv env isTailCall bodyExpr - true - - // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match - | Expr.Const (Const.Zero, _, _) -> - true - - | Expr.DebugPoint (_, 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) (isTailCall: IsTailCall) : unit = @@ -485,15 +382,6 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr - match TryCheckResumableCodeConstructs cenv env expr isTailCall with - | true -> - // we've handled the special cases of resumable code and don't do other checks. - () - | false -> - - // Handle ResumableExpr --> other expression - let env = { env with resumableCode = Resumable.None } - match expr with | LinearOpExpr _ | LinearMatchExpr _ @@ -589,7 +477,7 @@ and CheckStructStateMachineExpr cenv env _expr info = let exprRanges = [None; None; None; None] BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] - CheckExprNoByrefs cenv { env with resumableCode = Resumable.ResumableExpr true } IsTailCall.No moveNextExpr + CheckExprNoByrefs cenv env IsTailCall.No moveNextExpr CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody @@ -664,15 +552,9 @@ and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty) -and CheckMethod cenv env _baseValOpt ty (TObjExprMethod(_, _, _tps, vs, body, _m)) = +and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod(_, _, _tps, vs, body, _m)) = let vs = List.concat vs let env = BindArgVals env vs - let env = - // Body of ResumableCode delegate - if isResumableCodeTy cenv.g ty then - { env with resumableCode = Resumable.ResumableExpr false } - else - { env with resumableCode = Resumable.None } CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore and CheckInterfaceImpls cenv env baseValOpt l = @@ -979,13 +861,6 @@ 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 - - let env = - if isReturnsResumableCodeTy g v.TauType then - { env with resumableCode = Resumable.ResumableExpr false } - else - env - CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = @@ -1084,7 +959,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = reflect=false external=false returnScope = 0 - isInAppExpr = false - resumableCode = Resumable.None } + isInAppExpr = false } CheckImplFileContents cenv env implFileContents From cef701585a84d7815750aaa794a2ebd68d3f0c0e Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 11:44:48 +0200 Subject: [PATCH 35/77] remove external handling --- src/Compiler/Checking/TailCallChecks.fs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index bd3c9f522e7..037182c7f3f 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -48,9 +48,6 @@ type env = /// Are we under []? reflect : bool - /// Are we in an extern declaration? - external : bool - /// Current return scope of the expr. returnScope : int @@ -831,8 +828,6 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin let g = cenv.g let isTop = Option.isSome bind.Var.ValReprInfo - let env = { env with external = env.external || g.attrib_DllImportAttribute |> Option.exists (fun attr -> HasFSharpAttribute g attr v.Attribs) } - if cenv.reportErrors then match v.PublicPath with @@ -957,7 +952,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = mustTailCall = Zset.empty valOrder mustTailCallRanges = Map.Empty reflect=false - external=false returnScope = 0 isInAppExpr = false } From fd21b384a650438c6dc3381be094f1ec64c75b3d Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 11:48:42 +0200 Subject: [PATCH 36/77] remove isInAppExpr --- src/Compiler/Checking/TailCallChecks.fs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 037182c7f3f..994f4e5c51f 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -50,9 +50,6 @@ type env = /// Current return scope of the expr. returnScope : int - - /// Are we in an app expression (Expr.App)? - isInAppExpr: bool } override _.ToString() = "" @@ -488,8 +485,6 @@ and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) : if memberInfo.MemberFlags.IsDispatchSlot then () else - let env = { env with isInAppExpr = true } - CheckValRef cenv env v m PermitByRefExpr.No IsTailCall.No CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No @@ -505,9 +500,6 @@ and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTa let g = cenv.g let returnTy = tyOfExpr g expr - - let env = { env with isInAppExpr = true } - CheckExprNoByrefs cenv env isTailCall f let hasReceiver = @@ -952,7 +944,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = mustTailCall = Zset.empty valOrder mustTailCallRanges = Map.Empty reflect=false - returnScope = 0 - isInAppExpr = false } + returnScope = 0 } CheckImplFileContents cenv env implFileContents From a5648cc812c0d4d85a038200ca42ff2be07e2eb8 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 11:54:39 +0200 Subject: [PATCH 37/77] remove returnScope --- src/Compiler/Checking/TailCallChecks.fs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 994f4e5c51f..f9081d4c7ac 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -47,9 +47,6 @@ type env = /// Are we under []? reflect : bool - - /// Current return scope of the expr. - returnScope : int } override _.ToString() = "" @@ -338,7 +335,7 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail else PermitByRefExpr.Yes - CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind + CheckBinding cenv env false bindingContext bind BindVal cenv env None v // tailcall CheckExprLinear cenv env body ctxt isTailCall @@ -544,7 +541,7 @@ and CheckMethods cenv env baseValOpt (ty, methods) = and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod(_, _, _tps, vs, body, _m)) = let vs = List.concat vs let env = BindArgVals env vs - CheckExpr cenv { env with returnScope = env.returnScope + 1 } body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore + CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -883,7 +880,7 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(_v, _e, _) as bind) = checkTailCall false bodyExpr | _ -> () - CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore + CheckBinding cenv env true PermitByRefExpr.Yes bind |> ignore //-------------------------------------------------------------------------- // check modules @@ -943,7 +940,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = argVals = ValMap.Empty mustTailCall = Zset.empty valOrder mustTailCallRanges = Map.Empty - reflect=false - returnScope = 0 } + reflect=false } CheckImplFileContents cenv env implFileContents From be8f6a7d90c8e3f20c795c56b9720ea5a3da71b4 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 11:56:02 +0200 Subject: [PATCH 38/77] remove boundTyparNames --- src/Compiler/Checking/TailCallChecks.fs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index f9081d4c7ac..5a0b3836aee 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -30,9 +30,6 @@ let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChec type env = { - /// The bound type parameter names in scope - boundTyparNames: string list - /// The set of arguments to this method/function argVals: ValMap @@ -936,7 +933,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = let env = { quote=false - boundTyparNames=[] argVals = ValMap.Empty mustTailCall = Zset.empty valOrder mustTailCallRanges = Map.Empty From 176b8c609ab36b3fda3ac3661b61e883029fcb74 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 12:03:29 +0200 Subject: [PATCH 39/77] remove argVals from env --- src/Compiler/Checking/TailCallChecks.fs | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 5a0b3836aee..116d28e654f 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -30,9 +30,6 @@ let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChec type env = { - /// The set of arguments to this method/function - argVals: ValMap - /// Values in module that have been marked [] mutable mustTailCall: Zset // mutable as this is updated in loops @@ -48,11 +45,6 @@ type env = override _.ToString() = "" -/// Set the set of vals which are arguments in the active lambda. We are allowed to return -/// byref arguments as byref returns. -let BindArgVals env (vs: Val list) = - { env with argVals = ValMap.OfList (List.map (fun v -> (v, ())) vs) } - let (|ValUseAtApp|_|) e = match e with | InnerExprPat( @@ -535,9 +527,7 @@ and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty) -and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod(_, _, _tps, vs, body, _m)) = - let vs = List.concat vs - let env = BindArgVals env vs +and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod(_, _, _tps, _vs, body, _m)) = CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore and CheckInterfaceImpls cenv env baseValOpt l = @@ -718,7 +708,6 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt let restArgs = List.concat vsl let syntacticArgs = thisAndBase @ restArgs - let env = BindArgVals env restArgs match memInfo with | None -> () @@ -933,7 +922,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = let env = { quote=false - argVals = ValMap.Empty mustTailCall = Zset.empty valOrder mustTailCallRanges = Map.Empty reflect=false } From 927bcd083546a7a114084b651f824f2377b64b6f Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 14:16:01 +0200 Subject: [PATCH 40/77] let's drop quote and reflect, too, for now --- src/Compiler/Checking/TailCallChecks.fs | 59 +++---------------------- 1 file changed, 5 insertions(+), 54 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 116d28e654f..ccf24237084 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -35,12 +35,6 @@ type env = /// Recursive scopes of [] attributed values mutable mustTailCallRanges: Map // mutable as this is updated in loops - - /// Are we in a quotation? - quote : bool - - /// Are we under []? - reflect : bool } override _.ToString() = "" @@ -180,9 +174,6 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = | Expr.Op (TOp.Coerce, _, [f], _) -> mkArgsForAppliedExpr isBaseCall argsl f | _ -> [] -/// Check if a function is a quotation splice operator -let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.splice_raw_expr_vref - let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) @@ -380,8 +371,8 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.Val (vref, vFlags, m) -> CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall - | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> - CheckQuoteExpr cenv env (ast, savedConv, m, ty) + | Expr.Quote (_ast, _savedConv, _isFromQueryExpression, _m, _ty) -> + () | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv env expr info @@ -413,10 +404,6 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | TypeDefOfExpr g ty when isVoidTy g ty -> () - // Allow '%expr' in quotations - | Expr.App (Expr.Val (vref, _, _), _, tinst, [arg], m) when isSpliceOperator g vref && env.quote -> - CheckSpliceApplication cenv env (tinst, arg, m) - // Check an application | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall @@ -445,9 +432,6 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.Link _ -> failwith "Unexpected reclink" -and CheckQuoteExpr cenv env (ast, _savedConv, _m, _ty) = - CheckExprNoByrefs cenv {env with quote=true} IsTailCall.No ast - and CheckStructStateMachineExpr cenv env _expr info = let (_dataTy, @@ -479,9 +463,6 @@ and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _ CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprsPermitByRefLike cenv env rest -and CheckSpliceApplication cenv env (_tinst, arg, _m) = - CheckExprNoByrefs cenv env IsTailCall.No arg - and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) : unit = let g = cenv.g @@ -802,33 +783,6 @@ and CheckDecisionTreeTest cenv env _m discrim = and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : unit = let g = cenv.g let isTop = Option.isSome bind.Var.ValReprInfo - - if cenv.reportErrors then - - match v.PublicPath with - | None -> () - | _ -> - if - // Don't support implicit [] on generated members, except the implicit members - // for 'let' bound functions in classes. - (not v.IsCompilerGenerated || v.IsIncrClassGeneratedMember) && - - (// Check the attributes on any enclosing module - env.reflect || - // Check the attributes on the value - HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.Attribs || - // Also check the enclosing type for members - for historical reasons, in the TAST member values - // are stored in the entity that encloses the type, hence we will not have noticed the ReflectedDefinition - // on the enclosing type at this point. - HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then - - cenv.usesQuotations <- true - - // If we've already recorded a definition then skip this - match v.ReflectedDefinition with - | None -> v.SetValDefn bindRhs - | Some _ -> () - let isTailCall = IsTailCall.YesFromVal g bind.Var let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt @@ -904,8 +858,7 @@ and CheckModuleSpec cenv env isRec mbind = | ModuleOrNamespaceBinding.Binding bind -> BindVals cenv env [None] (valsOfBinds [bind]) CheckModuleBinding cenv env isRec bind - | ModuleOrNamespaceBinding.Module (mspec, rhs) -> - let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } + | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv env rhs let CheckImplFileContents cenv env implFileContents = @@ -921,9 +874,7 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = amap = amap } let env = - { quote=false - mustTailCall = Zset.empty valOrder - mustTailCallRanges = Map.Empty - reflect=false } + { mustTailCall = Zset.empty valOrder + mustTailCallRanges = Map.Empty } CheckImplFileContents cenv env implFileContents From 1473c953cdcc0b3367b76827873be88303beaf4e Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 15:42:21 +0200 Subject: [PATCH 41/77] remove usesQuotations --- src/Compiler/Checking/TailCallChecks.fs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index ccf24237084..47117e4dc77 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -84,10 +84,7 @@ type cenv = amap: Import.ImportMap - reportErrors: bool - - // outputs - mutable usesQuotations: bool } + reportErrors: bool } override x.ToString() = "" @@ -870,7 +867,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = reportErrors = reportErrors boundVals = Dictionary<_, _>(100, HashIdentity.Structural) stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") - usesQuotations = false amap = amap } let env = From 5473838fceb0a39caf0f384177eedc4434b35888 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 18:25:13 +0200 Subject: [PATCH 42/77] get rid of range-based approach, collect TailRec-attributed bindings upfront and just traverse these --- src/Compiler/Checking/TailCallChecks.fs | 126 ++++++++---------- .../ErrorMessages/TailCallAttribute.fs | 14 ++ 2 files changed, 69 insertions(+), 71 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 47117e4dc77..674f1cc7600 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -4,8 +4,6 @@ /// is complete. module internal FSharp.Compiler.TailCallChecks -open System.Collections.Generic - open Internal.Utilities.Collections open Internal.Utilities.Library open Internal.Utilities.Library.Extras @@ -15,8 +13,6 @@ open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Features open FSharp.Compiler.Syntax open FSharp.Compiler.TcGlobals -open FSharp.Compiler.Text -open FSharp.Compiler.Text.Range open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps @@ -34,7 +30,7 @@ type env = mutable mustTailCall: Zset // mutable as this is updated in loops /// Recursive scopes of [] attributed values - mutable mustTailCallRanges: Map // mutable as this is updated in loops + mutable mustTailCallExprs: Map // mutable as this is updated in loops } override _.ToString() = "" @@ -76,9 +72,7 @@ let IsValRefIsDllImport g (vref:ValRef) = vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute type cenv = - { boundVals: Dictionary // really a hash set - - stackGuard: StackGuard + { stackGuard: StackGuard g: TcGlobals @@ -88,21 +82,6 @@ type cenv = override x.ToString() = "" -let BindVal cenv env (exprRange: Range option) (v: Val) = - cenv.boundVals[v.Stamp] <- 1 - - if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then - env.mustTailCall <- Zset.add v env.mustTailCall - match exprRange with - | Some r when not (env.mustTailCallRanges.ContainsKey v.Stamp) -> - env.mustTailCallRanges <- Map.add v.Stamp r env.mustTailCallRanges - | _ -> () - -let BindVals cenv env (exprRanges: Range option list) vs = - let zipped = List.zip exprRanges vs - zipped - |> List.iter (fun (exprRange, v) -> BindVal cenv env exprRange v) - //-------------------------------------------------------------------------- // approx walk of type //-------------------------------------------------------------------------- @@ -171,35 +150,22 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = | Expr.Op (TOp.Coerce, _, [f], _) -> mkArgsForAppliedExpr isBaseCall argsl f | _ -> [] -let callRangeIsInAnyRecRange (env: env) (callingRange: Range) = - env.mustTailCallRanges.Values |> Seq.exists (fun recRange -> rangeContainsRange recRange callingRange) - -let rec allValsAndRangesOfModDef mdef = - let abstractSlotValsAndRangesOfTycons (tycons: Tycon list) = - abstractSlotValRefsOfTycons tycons - |> List.map (fun v -> v.Deref, v.Deref.Range) - +let rec allValsAndExprsOfModDef mdef = seq { match mdef with - | TMDefRec(tycons = tycons; bindings = mbinds) -> - yield! abstractSlotValsAndRangesOfTycons tycons + | TMDefRec(tycons = _tycons; bindings = mbinds) -> for mbind in mbinds do match mbind with | ModuleOrNamespaceBinding.Binding bind -> - let r = - match (stripExpr bind.Expr) with - | Expr.Lambda _ -> bind.Expr.Range - | Expr.TyLambda(bodyExpr = bodyExpr) -> bodyExpr.Range - | e -> e.Range - yield bind.Var, r - | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndRangesOfModDef def + yield bind.Var, bind.Expr + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> yield! allValsAndExprsOfModDef def | TMDefLet(binding = bind) -> let e = stripExpr bind.Expr - yield bind.Var, e.Range + yield bind.Var, e | TMDefDo _ -> () | TMDefOpens _ -> () | TMDefs defs -> for def in defs do - yield! allValsAndRangesOfModDef def + yield! allValsAndExprsOfModDef def } /// Check an expression, where the expression is in a position where byrefs can be generated @@ -213,7 +179,7 @@ and CheckValRef (cenv: cenv) (env: env) (v: ValRef) m (_ctxt: PermitByRefExpr) ( // ``Warn successfully for invalid tailcalls in type methods`` if cenv.reportErrors then if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No && callRangeIsInAnyRecRange env m then + if env.mustTailCall.Contains v.Deref && isTailCall = IsTailCall.No then warning(Error(FSComp.SR.chkNotTailRecursive(v.DisplayName), m)) /// Check a use of a value @@ -273,7 +239,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i // warn if we call inside of recursive scope in non-tail-call manner or with tail blockers. See // ``Warn successfully in match clause`` // ``Warn for byref parameters`` - if not canTailCall && (env.mustTailCallRanges.Item vref.Stamp |> fun recRange -> rangeContainsRange recRange m) then + if not canTailCall then warning(Error(FSComp.SR.chkNotTailRecursive(vref.DisplayName), m)) | _ -> () | _ -> () @@ -313,7 +279,6 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail PermitByRefExpr.Yes CheckBinding cenv env false bindingContext bind - BindVal cenv env None v // tailcall CheckExprLinear cenv env body ctxt isTailCall @@ -432,12 +397,10 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa and CheckStructStateMachineExpr cenv env _expr info = let (_dataTy, - (moveNextThisVar, moveNextExpr), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), - (afterCodeThisVar, afterCodeBody)) = info + (_moveNextThisVar, moveNextExpr), + (_setStateMachineThisVar, _setStateMachineStateVar, setStateMachineBody), + (_afterCodeThisVar, afterCodeBody)) = info - let exprRanges = [None; None; None; None] - BindVals cenv env exprRanges [moveNextThisVar; setStateMachineThisVar; setStateMachineStateVar; afterCodeThisVar] CheckExprNoByrefs cenv env IsTailCall.No moveNextExpr CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody @@ -492,9 +455,6 @@ and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) isTailCall = CheckDecisionTreeTargets cenv env targets ctxt isTailCall and CheckLetRec cenv env (binds, bodyExpr) isTailCall = - let vals = valsOfBinds binds - let exprRanges = List.replicate vals.Length None - BindVals cenv env exprRanges vals CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr @@ -685,7 +645,6 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt let restArgs = List.concat vsl - let syntacticArgs = thisAndBase @ restArgs match memInfo with | None -> () @@ -701,9 +660,6 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT if isByrefTy g arg.Type then arg.SetHasBeenReferenced() - for arg in syntacticArgs do - BindVal cenv env None arg - // 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 @@ -750,9 +706,7 @@ and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = |> List.ofArray |> ignore -and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(vs, targetExpr, _)) : unit = - let exprRanges = List.replicate vs.Length None - BindVals cenv env exprRanges vs +and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(_vs, targetExpr, _)) : unit = CheckExpr cenv env targetExpr ctxt isTailCall and CheckDecisionTree cenv env dtree = @@ -830,13 +784,9 @@ let rec CheckDefnsInModule cenv env mdefs = and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> - if isRec then - let valls, ranges = allValsAndRangesOfModDef mdef |> Seq.toList |> List.unzip - BindVals cenv env (ranges |> List.map Some) valls List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, _m) -> CheckModuleBinding cenv env false bind - BindVal cenv env (Some bind.Expr.Range) bind.Var | TMDefOpens _ -> () | TMDefDo(e, _m) -> @@ -853,24 +803,58 @@ and CheckDefnInModule cenv env mdef = and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - BindVals cenv env [None] (valsOfBinds [bind]) CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv env rhs -let CheckImplFileContents cenv env implFileContents = - CheckDefnInModule cenv env implFileContents - +let rec CollectCheckDefnsInModule cenv env mdefs = + for mdef in mdefs do + CollectCheckDefnInModule cenv env mdef + +and CollectCheckDefnInModule cenv env mdef = + match mdef with + | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> + if isRec then + let vallsAndExprs = allValsAndExprsOfModDef mdef + for (v, e) in vallsAndExprs do + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + env.mustTailCall <- Zset.add v env.mustTailCall + env.mustTailCallExprs <- Map.add v.Stamp e env.mustTailCallExprs + List.iter (CollectCheckModuleSpec cenv env isRec) mspecs + | TMDefLet(_bind, _m) -> + () + | TMDefOpens _ -> + () + | TMDefDo(_e, _m) -> + () + | TMDefs defs -> CollectCheckDefnsInModule cenv env defs + +and CollectCheckModuleSpec cenv env _isRec mbind = + match mbind with + | ModuleOrNamespaceBinding.Binding _bind -> + () + | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> + CollectCheckDefnInModule cenv env rhs + let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = let cenv = { g = g reportErrors = reportErrors - boundVals = Dictionary<_, _>(100, HashIdentity.Structural) stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") amap = amap } let env = { mustTailCall = Zset.empty valOrder - mustTailCallRanges = Map.Empty } + mustTailCallExprs = Map.Empty } - CheckImplFileContents cenv env implFileContents + CollectCheckDefnInModule cenv env implFileContents + + for v in env.mustTailCall do + let exprOfV = env.mustTailCallExprs[v.Stamp] + let freshCenv = + { g = g + reportErrors = reportErrors + stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") + amap = amap } + let binding = Binding.TBind(v, exprOfV, DebugPointAtBinding.NoneAtLet) + CheckModuleBinding freshCenv env true binding diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index d6868feb2ac..50cb40dec1a 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -441,6 +441,13 @@ module rec M = |> typecheck |> shouldFail |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 6 + StartColumn = 28 + EndLine = 6 + EndColumn = 39 } + Message = + "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 Range = { StartLine = 6 StartColumn = 28 @@ -448,6 +455,13 @@ module rec M = EndColumn = 37 } Message = "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 10 + StartColumn = 28 + EndLine = 10 + EndColumn = 39 } + Message = + "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 Range = { StartLine = 10 StartColumn = 28 From 5d22615b731fb1a0d88018ab20101d4adc9700d6 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 19:04:50 +0200 Subject: [PATCH 43/77] fold instead of mutate --- src/Compiler/Checking/CheckDeclarations.fs | 4 +- src/Compiler/Checking/TailCallChecks.fs | 82 ++++++++++++---------- src/Compiler/Checking/TailCallChecks.fsi | 3 +- 3 files changed, 48 insertions(+), 41 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 9ad452d35c2..212076d7149 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5507,9 +5507,7 @@ let CheckOneImplFile env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) - TailCallChecks.CheckImplFile - (g, cenv.amap, reportErrors, - implFileContents, extraAttribs) + TailCallChecks.CheckImplFile (g, cenv.amap, reportErrors, implFileContents) hasExplicitEntryPoint, anonRecdTypes diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 674f1cc7600..13b7d8ddab2 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -27,10 +27,10 @@ let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChec type env = { /// Values in module that have been marked [] - mutable mustTailCall: Zset // mutable as this is updated in loops + mustTailCall: Zset - /// Recursive scopes of [] attributed values - mutable mustTailCallExprs: Map // mutable as this is updated in loops + /// Recursive expressions of [] attributed values + mustTailCallExprs: Map } override _.ToString() = "" @@ -807,54 +807,64 @@ and CheckModuleSpec cenv env isRec mbind = | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv env rhs -let rec CollectCheckDefnsInModule cenv env mdefs = - for mdef in mdefs do - CollectCheckDefnInModule cenv env mdef - -and CollectCheckDefnInModule cenv env mdef = +let rec CollectCheckDefnsInModule cenv mdefs mustTailCall mustTailCallExpr = + List.fold (fun (mustTailCall, mustTailCallExpr) mdef -> + CollectCheckDefnInModule cenv mdef mustTailCall mustTailCallExpr + ) (mustTailCall, mustTailCallExpr) mdefs + +and CollectCheckDefnInModule cenv mdef (mustTailCall: Zset) (mustTailCallExpr: Map) = match mdef with - | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> - if isRec then - let vallsAndExprs = allValsAndExprsOfModDef mdef - for (v, e) in vallsAndExprs do - if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then - env.mustTailCall <- Zset.add v env.mustTailCall - env.mustTailCallExprs <- Map.add v.Stamp e env.mustTailCallExprs - List.iter (CollectCheckModuleSpec cenv env isRec) mspecs + | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> + let mustTailCall'', mustTailCallExprs'' = + if isRec then + let vallsAndExprs = allValsAndExprsOfModDef mdef + + let mustTailCall', mustTailCallExpr' = + Seq.fold (fun (mustTailCall, mustTailCallExpr) (v: Val, e) -> + if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then + let newSet = Zset.add v mustTailCall + let newMap = Map.add v.Stamp e mustTailCallExpr + (newSet, newMap) + else + (mustTailCall, mustTailCallExpr) + ) (mustTailCall, mustTailCallExpr) vallsAndExprs + + mustTailCall', mustTailCallExpr' + else + mustTailCall, mustTailCallExpr + + List.fold (fun (mustTailCall, mustTailCallExpr) mspec -> + CollectCheckModuleSpec cenv mspec mustTailCall mustTailCallExpr + ) (mustTailCall'', mustTailCallExprs'') mspecs | TMDefLet(_bind, _m) -> - () + mustTailCall, mustTailCallExpr | TMDefOpens _ -> - () + mustTailCall, mustTailCallExpr | TMDefDo(_e, _m) -> - () - | TMDefs defs -> CollectCheckDefnsInModule cenv env defs + mustTailCall, mustTailCallExpr + | TMDefs defs -> CollectCheckDefnsInModule cenv defs mustTailCall mustTailCallExpr -and CollectCheckModuleSpec cenv env _isRec mbind = +and CollectCheckModuleSpec cenv mbind mustTailCall mustTailCallExpr = match mbind with | ModuleOrNamespaceBinding.Binding _bind -> - () + mustTailCall, mustTailCallExpr | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> - CollectCheckDefnInModule cenv env rhs + CollectCheckDefnInModule cenv rhs mustTailCall mustTailCallExpr -let CheckImplFile (g, amap, reportErrors, implFileContents, _extraAttribs) = +let CheckImplFile (g, amap, reportErrors, implFileContents) = let cenv = { g = g reportErrors = reportErrors stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") amap = amap } + let mustTailCall, mustTailCallExprs = CollectCheckDefnInModule cenv implFileContents (Zset.empty valOrder) Map.Empty + let env = - { mustTailCall = Zset.empty valOrder - mustTailCallExprs = Map.Empty } - - CollectCheckDefnInModule cenv env implFileContents + { mustTailCall = mustTailCall + mustTailCallExprs = mustTailCallExprs } for v in env.mustTailCall do - let exprOfV = env.mustTailCallExprs[v.Stamp] - let freshCenv = - { g = g - reportErrors = reportErrors - stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") - amap = amap } - let binding = Binding.TBind(v, exprOfV, DebugPointAtBinding.NoneAtLet) - CheckModuleBinding freshCenv env true binding + let expr = env.mustTailCallExprs[v.Stamp] + let binding = Binding.TBind(v, expr, DebugPointAtBinding.NoneAtLet) + CheckModuleBinding cenv env true binding diff --git a/src/Compiler/Checking/TailCallChecks.fsi b/src/Compiler/Checking/TailCallChecks.fsi index 9e8b20d19d5..37acce919fc 100644 --- a/src/Compiler/Checking/TailCallChecks.fsi +++ b/src/Compiler/Checking/TailCallChecks.fsi @@ -8,6 +8,5 @@ val CheckImplFile: g: TcGlobals * amap: Import.ImportMap * reportErrors: bool * - implFileContents: ModuleOrNamespaceContents * - _extraAttribs: 'a -> + implFileContents: ModuleOrNamespaceContents -> unit From 98f71957d7442c1ce673f47313e925b52dc9c61c Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 29 Jun 2023 19:18:22 +0200 Subject: [PATCH 44/77] format --- src/Compiler/Checking/TailCallChecks.fsi | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fsi b/src/Compiler/Checking/TailCallChecks.fsi index 37acce919fc..126560420ad 100644 --- a/src/Compiler/Checking/TailCallChecks.fsi +++ b/src/Compiler/Checking/TailCallChecks.fsi @@ -5,8 +5,4 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.TypedTree val CheckImplFile: - g: TcGlobals * - amap: Import.ImportMap * - reportErrors: bool * - implFileContents: ModuleOrNamespaceContents -> - unit + g: TcGlobals * amap: Import.ImportMap * reportErrors: bool * implFileContents: ModuleOrNamespaceContents -> unit From 1bf7c7d8ffd8a7b5ac6df3fa7699398e82977e4f Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 3 Jul 2023 09:18:14 +0200 Subject: [PATCH 45/77] make tests more challenging --- .../ErrorMessages/TailCallAttribute.fs | 123 ++++++++++++++++++ 1 file changed, 123 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 50cb40dec1a..2047d048f59 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -491,3 +491,126 @@ let run() = let mutable x = 0 in foo(&x) Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] + + [] + let ``Don't warn for yield! in tail position`` () = + """ +type Bind = { Var: string; Expr: string } + +type ModuleOrNamespaceBinding = + | Binding of bind: Bind + | Module of moduleOrNamespaceContents: MDef + +and MDef = + | TMDefRec of tycons: string list * bindings: ModuleOrNamespaceBinding list + | TMDefLet of binding: Bind + | TMDefDo of expr: string + | TMDefOpens of expr: string + | TMDefs of defs: MDef list + +[] +let rec allValsAndExprsOfModDef mdef = + seq { + match mdef with + | TMDefRec(tycons = _tycons; bindings = mbinds) -> + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> yield bind.Var, bind.Expr + | ModuleOrNamespaceBinding.Module(moduleOrNamespaceContents = def) -> + yield! allValsAndExprsOfModDef def + | TMDefLet(binding = bind) -> yield bind.Var, bind.Expr + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allValsAndExprsOfModDef def + } + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + + [] + let ``Warn for calls in for and iter`` () = + """ +type Bind = { Var: string; Expr: string } + +type ModuleOrNamespaceBinding = + | Binding of bind: Bind + | Module of moduleOrNamespaceContents: MDef + +and MDef = + | TMDefRec of isRec: bool * tycons: string list * bindings: ModuleOrNamespaceBinding list + | TMDefLet of binding: Bind + | TMDefDo of expr: string + | TMDefOpens of expr: string + | TMDefs of defs: MDef list + +let someCheckFunc x = () + +[] +let rec CheckDefnsInModule cenv env mdefs = + for mdef in mdefs do + CheckDefnInModule cenv env mdef + +and CheckNothingAfterEntryPoint cenv = + if true then + printfn "foo" + +and [] CheckDefnInModule cenv env mdef = + match mdef with + | TMDefRec(isRec, tycons, mspecs) -> + CheckNothingAfterEntryPoint cenv + someCheckFunc tycons + List.iter (CheckModuleSpec cenv env isRec) mspecs + | TMDefLet bind -> + CheckNothingAfterEntryPoint cenv + someCheckFunc bind + | TMDefOpens _ -> () + | TMDefDo e -> + CheckNothingAfterEntryPoint cenv + let isTailCall = true + someCheckFunc isTailCall + | TMDefs defs -> CheckDefnsInModule cenv env defs + +and [] CheckModuleSpec cenv env isRec mbind = + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> someCheckFunc bind + | ModuleOrNamespaceBinding.Module mspec -> + someCheckFunc mspec + CheckDefnInModule cenv env mspec + """ + |> FSharp + |> withLangVersionPreview + |> typecheck + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 20 + StartColumn = 9 + EndLine = 20 + EndColumn = 40 } + Message = + "The member or function 'CheckDefnInModule' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 20 + StartColumn = 9 + EndLine = 20 + EndColumn = 26 } + Message = + "The member or function 'CheckDefnInModule' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 31 + StartColumn = 20 + EndLine = 31 + EndColumn = 50 } + Message = + "The member or function 'CheckModuleSpec' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + { Error = Warning 3569 + Range = { StartLine = 31 + StartColumn = 20 + EndLine = 31 + EndColumn = 35 } + Message = + "The member or function 'CheckModuleSpec' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] From 65b7d4e6b85fd6ec2e4b66e13fe9baa8b4013262 Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 3 Jul 2023 09:18:44 +0200 Subject: [PATCH 46/77] do the TailCall checks during the main traversal --- src/Compiler/Checking/TailCallChecks.fs | 111 +++++++++--------------- 1 file changed, 41 insertions(+), 70 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 13b7d8ddab2..ac71d9de88b 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -150,24 +150,6 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = | Expr.Op (TOp.Coerce, _, [f], _) -> mkArgsForAppliedExpr isBaseCall argsl f | _ -> [] -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 - } - /// Check an expression, where the expression is in a position where byrefs can be generated let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore @@ -777,6 +759,24 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(_v, _e, _) as bind) = // 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 @@ -784,6 +784,21 @@ let rec CheckDefnsInModule cenv env mdefs = and CheckDefnInModule cenv env mdef = match mdef with | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> + let env = + if isRec then + 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 List.iter (CheckModuleSpec cenv env isRec) mspecs | TMDefLet(bind, _m) -> CheckModuleBinding cenv env false bind @@ -803,54 +818,15 @@ and CheckDefnInModule cenv env mdef = and CheckModuleSpec cenv env isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> + let env = + if env.mustTailCall.Contains bind.Var then + env + else + { env with mustTailCall = Zset.empty valOrder; mustTailCallExprs = Map.empty } CheckModuleBinding cenv env isRec bind | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv env rhs -let rec CollectCheckDefnsInModule cenv mdefs mustTailCall mustTailCallExpr = - List.fold (fun (mustTailCall, mustTailCallExpr) mdef -> - CollectCheckDefnInModule cenv mdef mustTailCall mustTailCallExpr - ) (mustTailCall, mustTailCallExpr) mdefs - -and CollectCheckDefnInModule cenv mdef (mustTailCall: Zset) (mustTailCallExpr: Map) = - match mdef with - | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> - let mustTailCall'', mustTailCallExprs'' = - if isRec then - let vallsAndExprs = allValsAndExprsOfModDef mdef - - let mustTailCall', mustTailCallExpr' = - Seq.fold (fun (mustTailCall, mustTailCallExpr) (v: Val, e) -> - if HasFSharpAttribute cenv.g cenv.g.attrib_TailCallAttribute v.Attribs then - let newSet = Zset.add v mustTailCall - let newMap = Map.add v.Stamp e mustTailCallExpr - (newSet, newMap) - else - (mustTailCall, mustTailCallExpr) - ) (mustTailCall, mustTailCallExpr) vallsAndExprs - - mustTailCall', mustTailCallExpr' - else - mustTailCall, mustTailCallExpr - - List.fold (fun (mustTailCall, mustTailCallExpr) mspec -> - CollectCheckModuleSpec cenv mspec mustTailCall mustTailCallExpr - ) (mustTailCall'', mustTailCallExprs'') mspecs - | TMDefLet(_bind, _m) -> - mustTailCall, mustTailCallExpr - | TMDefOpens _ -> - mustTailCall, mustTailCallExpr - | TMDefDo(_e, _m) -> - mustTailCall, mustTailCallExpr - | TMDefs defs -> CollectCheckDefnsInModule cenv defs mustTailCall mustTailCallExpr - -and CollectCheckModuleSpec cenv mbind mustTailCall mustTailCallExpr = - match mbind with - | ModuleOrNamespaceBinding.Binding _bind -> - mustTailCall, mustTailCallExpr - | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> - CollectCheckDefnInModule cenv rhs mustTailCall mustTailCallExpr - let CheckImplFile (g, amap, reportErrors, implFileContents) = let cenv = { g = g @@ -858,13 +834,8 @@ let CheckImplFile (g, amap, reportErrors, implFileContents) = stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") amap = amap } - let mustTailCall, mustTailCallExprs = CollectCheckDefnInModule cenv implFileContents (Zset.empty valOrder) Map.Empty - let env = - { mustTailCall = mustTailCall - mustTailCallExprs = mustTailCallExprs } + { mustTailCall = Zset.empty valOrder + mustTailCallExprs = Map.Empty } - for v in env.mustTailCall do - let expr = env.mustTailCallExprs[v.Stamp] - let binding = Binding.TBind(v, expr, DebugPointAtBinding.NoneAtLet) - CheckModuleBinding cenv env true binding + CheckDefnInModule cenv env implFileContents From 9614cfb8c70022072ad654a824b1d5919d2ca576 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 12:56:26 +0200 Subject: [PATCH 47/77] WIP: move TailCallChecks into main3 after optimization --- src/Compiler/Checking/CheckDeclarations.fs | 14 +- src/Compiler/Driver/fsc.fs | 7 + .../ErrorMessages/TailCallAttribute.fs | 880 +++++++++++------- 3 files changed, 550 insertions(+), 351 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 212076d7149..47606b18751 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5501,15 +5501,11 @@ let CheckOneImplFile try let reportErrors = not (checkForErrors()) let tcVal = LightweightTcValForUsingInBuildMethodCall g - let hasExplicitEntryPoint, anonRecdTypes = - PostTypeCheckSemanticChecks.CheckImplFile - (g, cenv.amap, reportErrors, cenv.infoReader, - env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, - implFileTy, implFileContents, extraAttribs, isLastCompiland, - isInternalTestSpanStackReferring) - TailCallChecks.CheckImplFile (g, cenv.amap, reportErrors, implFileContents) - - hasExplicitEntryPoint, anonRecdTypes + PostTypeCheckSemanticChecks.CheckImplFile + (g, cenv.amap, reportErrors, cenv.infoReader, + env.eInternalsVisibleCompPaths, cenv.thisCcu, tcVal, envAtEnd.DisplayEnv, + implFileTy, implFileContents, extraAttribs, isLastCompiland, + isInternalTestSpanStackReferring) with exn -> errorRecovery exn m diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 1810681cd25..4f99da8697b 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,12 @@ let main3 optimizedImpls, EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) + if tcGlobals.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + match optimizedImpls with + | CheckedAssemblyAfterOptimization checkedImplFileAfterOptimizations -> + 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/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 2047d048f59..4ded69238a9 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -8,31 +8,36 @@ module ``TailCall Attribute`` = [] let ``Warn successfully in if-else`` () = """ -let mul x y = x * y +namespace N -[] -let rec fact n acc = - if n = 0 - then acc - else (fact (n - 1) (mul n acc)) + 23 + 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 - |> typecheck + // |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 8 - StartColumn = 11 - EndLine = 8 - EndColumn = 35 } + Range = { StartLine = 12 + StartColumn = 19 + EndLine = 12 + EndColumn = 43 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 - Range = { StartLine = 8 - StartColumn = 11 - EndLine = 8 - EndColumn = 15 } + Range = { StartLine = 12 + StartColumn = 19 + EndLine = 12 + EndColumn = 23 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -40,31 +45,35 @@ let rec fact n acc = [] let ``Warn successfully in match clause`` () = """ -let mul x y = x * y +namespace N + + module M = -[] -let rec fact n acc = - match n with - | 0 -> acc - | _ -> (fact (n - 1) (mul n acc)) + 23 + 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 + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 8 - StartColumn = 13 - EndLine = 8 - EndColumn = 37 } + Range = { StartLine = 12 + StartColumn = 21 + EndLine = 12 + EndColumn = 45 } 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 } + Range = { StartLine = 12 + StartColumn = 21 + EndLine = 12 + EndColumn = 25 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -72,26 +81,37 @@ let rec fact n acc = [] let ``Warn successfully for rec call in binding`` () = """ -let mul x y = x * y +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 + [] + let rec fact n acc = + match n with + | 0 -> acc + | _ -> + let r = fact (n - 1) (mul n acc) + r + 23 """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 9 - StartColumn = 17 - EndLine = 9 - EndColumn = 21 } + Range = { StartLine = 13 + StartColumn = 25 + EndLine = 13 + EndColumn = 49 } + 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 = 13 + StartColumn = 25 + EndLine = 13 + EndColumn = 29 } Message = "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -99,67 +119,75 @@ let rec fact n acc = [] let ``Don't warn for valid tailcall and bind from toplevel`` () = """ -let mul x y = x * y +namespace N -[] -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 + 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 - |> typecheck + |> compile |> shouldSucceed [] let ``Warn successfully for mutually recursive functions`` () = """ -let foo x = - printfn "Foo: %x" x +namespace N -[] -let rec bar x = - match x with - | 0 -> - foo x // OK: non-tail-recursive call to a function which doesn't share the current stack frame (i.e., 'bar' or 'baz'). - printfn "Zero" - - | 1 -> - bar (x - 1) // Warning: this call is not tail-recursive - printfn "Uno" - baz x // OK: tail-recursive call. - - | x -> - printfn "0x%08x" x - bar (x - 1) // OK: tail-recursive call. - -and [] baz x = - printfn "Baz!" - bar (x - 1) // OK: tail-recursive call. + module M = + + let 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 - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 13 - StartColumn = 9 - EndLine = 13 - EndColumn = 20 } + Range = { StartLine = 17 + StartColumn = 17 + EndLine = 17 + EndColumn = 28 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 - Range = { StartLine = 13 - StartColumn = 9 - EndLine = 13 - EndColumn = 12 } + Range = { StartLine = 17 + StartColumn = 17 + EndLine = 17 + EndColumn = 20 } Message = "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -167,20 +195,24 @@ and [] baz x = [] let ``Warn successfully for invalid tailcall in type method`` () = """ -type C () = - [] - member this.M1() = this.M1() + 1 +namespace N + + module M = + + type C () = + [] + member this.M1() = this.M1() + 1 """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 4 - StartColumn = 24 - EndLine = 4 - EndColumn = 33 } + Range = { StartLine = 8 + StartColumn = 32 + EndLine = 8 + EndColumn = 41 } Message = "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -188,119 +220,150 @@ type C () = [] let ``Don't warn for valid tailcall in type method`` () = """ -type C () = - [] - member this.M1() = - printfn "M1 called" - this.M1() +namespace N -let c = C() -c.M1() + module M = + + type C () = + [] + member this.M1() = + printfn "M1 called" + this.M1() + + let c = C() + c.M1() """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldSucceed [] let ``Don't warn for valid tailcalls in type methods`` () = """ -type C () = - [] - member this.M1() = - printfn "M1 called" - this.M2() // ok +namespace N + + module M = - [] - member this.M2() = - printfn "M2 called" - this.M1() // ok + type C () = + [] + member this.M1() = + printfn "M1 called" + this.M2() // ok + + [] + member this.M2() = + printfn "M2 called" + this.M1() // ok """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldSucceed [] let ``Warn successfully for invalid tailcalls in type methods`` () = """ -type F () = - [] - member this.M1() = - printfn "M1 called" - this.M2() + 1 // should warn +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 + [] + member this.M2() = + printfn "M2 called" + this.M1() + 2 // should warn """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 6 - StartColumn = 9 - EndLine = 6 - EndColumn = 18 } + Range = { StartLine = 10 + StartColumn = 17 + EndLine = 10 + EndColumn = 26 } Message = "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } { Error = Warning 3569 - Range = { StartLine = 11 - StartColumn = 9 - EndLine = 11 - EndColumn = 18 } + Range = { StartLine = 15 + StartColumn = 17 + EndLine = 15 + EndColumn = 26 } Message = +#if Debug + "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } +#else "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } +#endif ] [] let ``Don't warn for valid tailcall and bind from nested bind`` () = """ -let mul x y = x * y +namespace N -[] -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 + 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 - |> typecheck + |> compile |> 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 -} +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 - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 5 - StartColumn = 17 - EndLine = 5 - EndColumn = 18 } + Range = { StartLine = 9 + StartColumn = 25 + EndLine = 9 + EndColumn = 34 } + 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 = 9 + StartColumn = 25 + EndLine = 9 + EndColumn = 26 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -308,29 +371,33 @@ let rec f x : seq = [] 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) -} +namespace N + + module M = + + [] + let rec f x : seq = + seq { + yield! f (x - 1) |> Seq.map (fun x -> x + 1) + } """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 5 - StartColumn = 16 - EndLine = 5 - EndColumn = 25 } + Range = { StartLine = 9 + StartColumn = 24 + EndLine = 9 + EndColumn = 33 } 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 } + Range = { StartLine = 9 + StartColumn = 24 + EndLine = 9 + EndColumn = 25 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -338,63 +405,75 @@ let rec f x : seq = [] 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) -} +namespace N + + module M = -let a: seq = f 10 + [] + 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 + |> compile |> 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) -} +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 + let a: Async = f 10 """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldSucceed [] let ``Warn for invalid tailcalls in async expression`` () = """ -[] -let rec f x = async { - let! r = f (x - 1) - return r -} +namespace N + + module M = + + [] + let rec f x = async { + let! r = f (x - 1) + return r + } """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 4 - StartColumn = 14 - EndLine = 4 - EndColumn = 23 } + Range = { StartLine = 8 + StartColumn = 22 + EndLine = 8 + EndColumn = 31 } 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 } + Range = { StartLine = 8 + StartColumn = 22 + EndLine = 8 + EndColumn = 23 } Message = "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -402,92 +481,95 @@ let rec f x = async { [] let ``Don't warn for valid tailcalls in rec module`` () = """ -module rec M = +namespace N - module M1 = - [] - let m1func() = M2.m2func() + module rec M = + module M1 = + [] + let m1func() = M2.m2func() + + module M2 = + [] + let m2func() = M1.m1func() + + let f () = + M1.m1func() |> ignore + module M2 = - [] - let m2func() = M1.m1func() - - let f () = - M1.m1func() |> ignore -M.M1.m1func() |> ignore -M.M2.m2func() + M.M1.m1func() |> ignore + M.M2.m2func() """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldSucceed [] let ``Warn for invalid tailcalls in rec module`` () = """ -module rec M = +namespace N - module M1 = - [] - let m1func() = 1 + M2.m2func() + module rec M = - module M2 = - [] - let m2func() = 2 + M1.m1func() + module M1 = + [] + let m1func() = 1 + M2.m2func() + + module M2 = + [] + let m2func() = 2 + M1.m1func() """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 6 - StartColumn = 28 - EndLine = 6 - EndColumn = 39 } + Range = { StartLine = 8 + StartColumn = 32 + EndLine = 8 + EndColumn = 43 } 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 } + Range = { StartLine = 8 + StartColumn = 32 + EndLine = 8 + EndColumn = 41 } 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 } + Range = { StartLine = 12 + StartColumn = 32 + EndLine = 12 + EndColumn = 43 } Message = - "The member or function 'm1func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'm2func' 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) +namespace N + + module M = + + [] + let rec foo(x: int byref) = foo(&x) + let run() = let mutable x = 0 in foo(&x) """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 3 - StartColumn = 29 - EndLine = 3 - EndColumn = 36 } + Range = { StartLine = 7 + StartColumn = 37 + EndLine = 7 + EndColumn = 44 } Message = "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] @@ -495,122 +577,236 @@ let run() = let mutable x = 0 in foo(&x) [] 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 - } +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 + } """ |> FSharp |> withLangVersionPreview - |> typecheck + |> compile |> 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 +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 - |> typecheck + |> compile + |> shouldFail |> withResults [ { Error = Warning 3569 - Range = { StartLine = 20 - StartColumn = 9 - EndLine = 20 - EndColumn = 40 } + Range = { StartLine = 24 + StartColumn = 17 + EndLine = 24 + EndColumn = 48 } 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 } + Range = { StartLine = 24 + StartColumn = 17 + EndLine = 24 + EndColumn = 34 } 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 } + Range = { StartLine = 35 + StartColumn = 17 + EndLine = 35 + EndColumn = 66 } 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`` () = + """ +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 = 31 - StartColumn = 20 - EndLine = 31 + Range = { StartLine = 21 + StartColumn = 27 + EndLine = 21 EndColumn = 35 } Message = - "The member or function 'CheckModuleSpec' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 = 32 + EndLine = 17 + EndColumn = 77 } + 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`` () = + """ +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 'TailCall' 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 'TailCall' 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 From af2e5be7976dcd59a5cd5d74fa2295de0a5689cb Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 12:57:55 +0200 Subject: [PATCH 48/77] format --- src/Compiler/Driver/fsc.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 4f99da8697b..d9422421726 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -879,11 +879,11 @@ let main3 optimizedImpls, EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) - if tcGlobals.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then + if tcGlobals.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then match optimizedImpls with | CheckedAssemblyAfterOptimization checkedImplFileAfterOptimizations -> for f in checkedImplFileAfterOptimizations do - TailCallChecks.CheckImplFile (tcGlobals, tcImports.GetImportMap(), true, f.ImplFile.Contents) + TailCallChecks.CheckImplFile(tcGlobals, tcImports.GetImportMap(), true, f.ImplFile.Contents) let refAssemblySignatureHash = match tcConfig.emitMetadataAssembly with From 48e02617aeec859eb7add64f4484098b7091cbb6 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 13:57:55 +0200 Subject: [PATCH 49/77] let TailCallChecks.fs be formatted --- .fantomasignore | 1 - src/Compiler/Checking/TailCallChecks.fs | 765 +++++++++++++----------- 2 files changed, 404 insertions(+), 362 deletions(-) diff --git a/.fantomasignore b/.fantomasignore index d08d12abd39..4830d0af77d 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -39,7 +39,6 @@ src/Compiler/Checking/PatternMatchCompilation.fs src/Compiler/Checking/PostInferenceChecks.fs src/Compiler/Checking/QuotationTranslator.fs src/Compiler/Checking/SignatureConformance.fs -src/Compiler/Checking/TailCallChecks.fs src/Compiler/Checking/TypeHierarchy.fs src/Compiler/Checking/TypeRelations.fs diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index ac71d9de88b..6365302ccee 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -18,67 +18,73 @@ open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TypeRelations -let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChecks" 50 +let PostInferenceChecksStackGuardDepth = + GetEnvInteger "FSHARP_PostInferenceChecks" 50 //-------------------------------------------------------------------------- // check environment //-------------------------------------------------------------------------- -type env = - { - /// Values in module that have been marked [] - mustTailCall: Zset - - /// Recursive expressions of [] attributed values - mustTailCallExprs: Map - } +type env = + { + /// Values in module that have been marked [] + mustTailCall: Zset + + /// Recursive expressions of [] attributed values + mustTailCallExprs: Map + } override _.ToString() = "" -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 +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 = +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 + match v.ValReprInfo with | Some info -> let _tps, tau = destTopForallTy g info v.Type - let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm g info.ArgInfos tau v.Range + + 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 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) + | ValUseAtApp (valRef, _) -> IsTailCall.Yes(IsTailCall.IsVoidRet g valRef.Deref) | _ -> IsTailCall.Yes false - member x.AtExprLambda = - match x with + member x.AtExprLambda = + match x with // Inside a lambda that is considered an expression, we must always return "unit" not "void" | IsTailCall.Yes _ -> IsTailCall.Yes false | IsTailCall.No -> IsTailCall.No -let IsValRefIsDllImport g (vref:ValRef) = - vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute +let IsValRefIsDllImport g (vref: ValRef) = + vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute -type cenv = - { stackGuard: StackGuard +type cenv = + { + stackGuard: StackGuard - g: TcGlobals + g: TcGlobals - amap: Import.ImportMap + amap: Import.ImportMap - reportErrors: bool } + reportErrors: bool + } override x.ToString() = "" @@ -88,11 +94,11 @@ type cenv = /// Indicates whether an address-of operation is permitted at a particular location [] -type PermitByRefExpr = +type PermitByRefExpr = /// Permit a tuple of arguments where elements can be byrefs - | YesTupleOfArgs of int + | YesTupleOfArgs of int - /// Context allows for byref typed expr. + /// Context allows for byref typed expr. | Yes /// Context allows for byref typed expr, but the byref must be returnable @@ -101,19 +107,19 @@ type PermitByRefExpr = /// 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 + /// General (address-of expr and byref values not allowed) + | No - member ctxt.Disallow = - match ctxt with - | PermitByRefExpr.Yes - | PermitByRefExpr.YesReturnable - | PermitByRefExpr.YesReturnableNonLocal -> false + member ctxt.Disallow = + match ctxt with + | PermitByRefExpr.Yes + | PermitByRefExpr.YesReturnable + | PermitByRefExpr.YesReturnableNonLocal -> false | _ -> true - member ctxt.PermitOnlyReturnable = - match ctxt with - | PermitByRefExpr.YesReturnable + member ctxt.PermitOnlyReturnable = + match ctxt with + | PermitByRefExpr.YesReturnable | PermitByRefExpr.YesReturnableNonLocal -> true | _ -> false @@ -122,54 +128,61 @@ type PermitByRefExpr = | PermitByRefExpr.YesReturnableNonLocal -> true | _ -> false -let mkArgsPermit n = - if n=1 then PermitByRefExpr.Yes - else PermitByRefExpr.YesTupleOfArgs n +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 = +let mkArgsForAppliedVal isBaseCall (vref: ValRef) argsl = match vref.ValReprInfo with - | Some valReprInfo -> + | Some valReprInfo -> let argArities = valReprInfo.AritiesOfArgs - let argArities = if isBaseCall && argArities.Length >= 1 then List.tail argArities else argArities + + 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 + if List.length argsl >= argArities.Length then List.map mkArgsPermit argArities else [] - | None -> [] + | 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 + 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 - | _ -> [] + // 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 env (isTailCall: IsTailCall) expr = CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore /// Check a value -and CheckValRef (cenv: cenv) (env: env) (v: ValRef) m (_ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = +and CheckValRef (cenv: cenv) (env: env) (v: ValRef) m (_ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = // To warn for mutually recursive calls like in the following tests: // ``Warn for invalid tailcalls in rec module`` // ``Warn successfully for invalid tailcalls in type methods`` - if cenv.reportErrors then + if cenv.reportErrors then 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)) + warning (Error(FSComp.SR.chkNotTailRecursive (v.DisplayName), m)) /// Check a use of a value -and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, _vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, _vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = CheckValRef cenv env vref m ctxt isTailCall - + /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -180,49 +193,58 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i if cenv.reportErrors then if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then - match f with + match f with | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> - let canTailCall = - match isTailCall with - | IsTailCall.No -> // an upper level has already decided that this is not in a tailcall position + let canTailCall = + match isTailCall with + | IsTailCall.No -> // an upper level has already decided that this is not in a tailcall position false - | IsTailCall.Yes isVoidRet -> + | IsTailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value - let (nowArgs, laterArgs), returnTy = + + let (nowArgs, laterArgs), returnTy = let _tps, tau = destTopForallTy g topValInfo _fty - let curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau m + + let curriedArgInfos, returnTy = + GetTopTauTypeInFSharpForm cenv.g topValInfo.ArgInfos tau m + if argsl.Length >= curriedArgInfos.Length then (List.splitAfter curriedArgInfos.Length argsl), returnTy else ([], argsl), returnTy - let _,_,isNewObj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) - let isCCall = + + let _, _, isNewObj, isSuperInit, isSelfInit, _, _, _ = + GetMemberCallInfo cenv.g (vref, valUseFlags) + + let isCCall = match valUseFlags with - | PossibleConstrainedCall _ -> true + | 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 // blockers that will prevent the IL level from emmiting a tail instruction - else + 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 or 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)) + warning (Error(FSComp.SR.chkNotTailRecursive (vref.DisplayName), m)) | _ -> () | _ -> () @@ -244,14 +266,14 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = CheckExpr cenv env receiverArg receiverContext IsTailCall.No CheckExprs cenv env args ctxts (IsTailCall.Yes false) -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = match expr with - | Expr.Sequential (e1, e2, NormalSeq, _) -> + | Expr.Sequential (e1, e2, NormalSeq, _) -> CheckExprNoByrefs cenv env IsTailCall.No e1 // tailcall CheckExprLinear cenv env e2 ctxt isTailCall - | Expr.Let (TBind(v, _bindRhs, _) as bind, body, _, _) -> + | Expr.Let (TBind (v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type let bindingContext = @@ -260,12 +282,12 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail else PermitByRefExpr.Yes - CheckBinding cenv env false bindingContext bind + CheckBinding cenv env false bindingContext bind // tailcall CheckExprLinear cenv env body ctxt isTailCall | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> - argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) + argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) // tailcall CheckExprLinear cenv env argLast PermitByRefExpr.No isTailCall @@ -275,113 +297,102 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail // tailcall CheckExprLinear cenv env e2 ctxt isTailCall - | Expr.DebugPoint (_, innerExpr) -> - CheckExprLinear cenv env innerExpr ctxt isTailCall + | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt isTailCall - | _ -> + | _ -> // not a linear expression CheckExpr cenv env expr ctxt isTailCall /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = - +and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = + // Guard the stack for deeply nested expressions - cenv.stackGuard.Guard <| fun () -> - - let g = cenv.g + cenv.stackGuard.Guard + <| fun () -> - let origExpr = stripExpr origExpr + let g = cenv.g - // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall - let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr - let expr = stripExpr expr + let origExpr = stripExpr origExpr - match expr with - | LinearOpExpr _ - | LinearMatchExpr _ - | Expr.Let _ - | Expr.Sequential (_, _, NormalSeq, _) - | Expr.DebugPoint _ -> - CheckExprLinear cenv env expr ctxt isTailCall - - | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs cenv env IsTailCall.No e1 - CheckExprNoByrefs cenv env IsTailCall.No e2 + // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall + let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr + let expr = stripExpr expr - | Expr.Const (_, _m, _ty) -> - () - - | Expr.Val (vref, vFlags, m) -> - CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall - - | Expr.Quote (_ast, _savedConv, _isFromQueryExpression, _m, _ty) -> - () + match expr with + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Let _ + | Expr.Sequential (_, _, NormalSeq, _) + | Expr.DebugPoint _ -> CheckExprLinear cenv env expr ctxt isTailCall - | StructStateMachineExpr g info -> - CheckStructStateMachineExpr cenv env expr info + | Expr.Sequential (e1, e2, ThenDoSeq, _) -> + CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env IsTailCall.No e2 - | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) + | Expr.Const (_, _m, _ty) -> () - // 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) -> + | Expr.Val (vref, vFlags, m) -> CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall - CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) + | Expr.Quote (_ast, _savedConv, _isFromQueryExpression, _m, _ty) -> () - // 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 env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) + | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv env expr info - | Expr.Op (op, tyargs, args, m) -> - CheckExprOp cenv env (op, tyargs, args, m) ctxt expr + | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> + CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) - // Allow 'typeof' calls as a special case, the only accepted use of System.Void! - | TypeOfExpr g ty when isVoidTy g ty -> - () + // 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) + -> - // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! - | TypeDefOfExpr g ty when isVoidTy g ty -> - () + CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) - // Check an application - | Expr.App (f, _fty, tyargs, argsl, m) -> - CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall + // 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 -> - | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> - CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall + CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) - | Expr.TyLambda (_, tps, _, m, bodyTy) -> - CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall + | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv env (op, tyargs, args, m) ctxt expr - | Expr.TyChoose (_tps, e1, _) -> - CheckExprNoByrefs cenv env isTailCall e1 + // Allow 'typeof' calls as a special case, the only accepted use of System.Void! + | TypeOfExpr g ty when isVoidTy g ty -> () - | Expr.Match (_, _, dtree, targets, m, ty) -> - CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall + // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! + | TypeDefOfExpr g ty when isVoidTy g ty -> () - | Expr.LetRec (binds, bodyExpr, _, _) -> - CheckLetRec cenv env (binds, bodyExpr) isTailCall + // Check an application + | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall - | Expr.StaticOptimization (constraints, e2, e3, m) -> - CheckStaticOptimization cenv env (constraints, e2, e3, m) + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall - | Expr.WitnessArg _ -> - () + | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall + + | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv env isTailCall e1 + + | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall + + | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv env (binds, bodyExpr) isTailCall + + | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) - | Expr.Link _ -> - failwith "Unexpected reclink" + | Expr.WitnessArg _ -> () + + | Expr.Link _ -> failwith "Unexpected reclink" and CheckStructStateMachineExpr cenv env _expr info = - let (_dataTy, - (_moveNextThisVar, moveNextExpr), - (_setStateMachineThisVar, _setStateMachineStateVar, setStateMachineBody), - (_afterCodeThisVar, afterCodeBody)) = info + let (_dataTy, + (_moveNextThisVar, moveNextExpr), + (_setStateMachineThisVar, _setStateMachineStateVar, setStateMachineBody), + (_afterCodeThisVar, afterCodeBody)) = + info CheckExprNoByrefs cenv env IsTailCall.No moveNextExpr CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody @@ -394,18 +405,19 @@ and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, _m) = and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) : unit = let memberInfo = Option.get v.MemberInfo + if memberInfo.MemberFlags.IsDispatchSlot then () - else + else CheckValRef cenv env v m PermitByRefExpr.No IsTailCall.No CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No -and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, baseVal, rest, m) : unit = +and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, baseVal, rest, m) : unit = CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprsPermitByRefLike cenv env rest -and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) : unit = +and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) : unit = let g = cenv.g let returnTy = tyOfExpr g expr @@ -417,222 +429,232 @@ and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTa | _ -> false let ctxts = mkArgsForAppliedExpr false argsl f + if hasReceiver then CheckCallWithReceiver cenv env m returnTy argsl ctxts ctxt else CheckCall cenv env m returnTy argsl ctxts ctxt -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 +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 isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) (isTailCall: IsTailCall) = - let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - let ty = mkForallTyIfNeeded tps bodyTy in +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 isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) isTailCall = +and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) isTailCall = CheckDecisionTree cenv env dtree CheckDecisionTreeTargets cenv env targets ctxt isTailCall and CheckLetRec cenv env (binds, bodyExpr) isTailCall = CheckBindings cenv env binds CheckExprNoByrefs cenv env isTailCall bodyExpr - -and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = + +and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = CheckExprNoByrefs cenv env IsTailCall.No e2 CheckExprNoByrefs cenv env IsTailCall.No e3 - -and CheckMethods cenv env baseValOpt (ty, methods) = - methods |> List.iter (CheckMethod cenv env baseValOpt ty) -and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod(_, _, _tps, _vs, body, _m)) = - CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No |> ignore +and CheckMethods cenv env baseValOpt (ty, methods) = + methods |> List.iter (CheckMethod cenv env baseValOpt ty) + +and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = + CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No + |> ignore -and CheckInterfaceImpls cenv env baseValOpt l = +and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) - -and CheckInterfaceImpl cenv env baseValOpt overrides = - CheckMethods cenv env baseValOpt overrides + +and CheckInterfaceImpl cenv env baseValOpt overrides = + CheckMethods cenv env baseValOpt overrides and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : 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 env [e1;e2] + 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 env [ e1; e2 ] - | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> - 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 + | TOp.TryFinally _, [ _ ], [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _) ] -> + 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 - | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> - CheckExprsNoByRefLike cenv env [e1;e2;e3] + | TOp.IntegerForLoop _, + _, + [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _); Expr.Lambda (_, _, _, [ _ ], e3, _, _) ] -> + CheckExprsNoByRefLike cenv env [ e1; e2; e3 ] - | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> + | TOp.TryWith _, + [ _ ], + [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], _e2, _, _); Expr.Lambda (_, _, _, [ _ ], e3, _, _) ] -> 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] 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 - + | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, _enclTypeInst, _methInst, retTypes), _, _ -> - let hasReceiver = - (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) && - not args.IsEmpty + let hasReceiver = + (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) + && not args.IsEmpty let returnTy = tyOfExpr g expr let argContexts = List.init args.Length (fun _ -> PermitByRefExpr.Yes) match retTypes with - | [ty] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> + | [ ty ] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts ctxt else CheckCall cenv env m returnTy args argContexts ctxt - | _ -> + | _ -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes else CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes - | 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. + | 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 env args - | _ -> - CheckExprsNoByRefLike cenv env args + | _ -> CheckExprsNoByRefLike cenv env args - | TOp.LValueOp (LAddrOf _, _vref), _, _ -> - CheckExprsNoByRefLike cenv env args + | TOp.LValueOp (LAddrOf _, _vref), _, _ -> CheckExprsNoByRefLike cenv env args - | TOp.LValueOp (LByrefSet, _vref), _, [_arg] -> - () + | TOp.LValueOp (LByrefSet, _vref), _, [ _arg ] -> () - | TOp.LValueOp (LByrefGet, _vref), _, [] -> - () + | TOp.LValueOp (LByrefGet, _vref), _, [] -> () - | TOp.LValueOp (LSet, _vref), _, [_arg] -> - () + | TOp.LValueOp (LSet, _vref), _, [ _arg ] -> () - | TOp.AnonRecdGet _, _, [arg1] - | TOp.TupleFieldGet _, _, [arg1] -> - CheckExprsPermitByRefLike cenv env [arg1] + | TOp.AnonRecdGet _, _, [ arg1 ] + | TOp.TupleFieldGet _, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv env [ arg1 ] - | TOp.ValFieldGet _rf, _, [arg1] -> - CheckExprsPermitByRefLike cenv env [arg1] + | TOp.ValFieldGet _rf, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv env [ arg1 ] - | TOp.ValFieldSet _rf, _, [_arg1;_arg2] -> - () + | TOp.ValFieldSet _rf, _, [ _arg1; _arg2 ] -> () - | TOp.Coerce, [tgtTy;srcTy], [x] -> + | 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 isTailCall else CheckExprNoByrefs cenv env isTailCall x - | TOp.Reraise, [_ty1], [] -> - () + | TOp.Reraise, [ _ty1 ], [] -> () // Check get of static field - | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [] -> - () + | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [] -> () // Check get of instance field - | TOp.ValFieldGetAddr (_rfref, _readonly), _tyargs, [obj] -> + | 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 env obj ctxt IsTailCall.No - | TOp.UnionCaseFieldGet _, _, [arg1] -> - CheckExprPermitByRefLike cenv env arg1 + | TOp.UnionCaseFieldGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv env arg1 - | TOp.UnionCaseTagGet _, _, [arg1] -> - CheckExprPermitByRefLike cenv env arg1 // allow byref - it may be address-of-struct + | TOp.UnionCaseTagGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv env arg1 // allow byref - it may be address-of-struct - | TOp.UnionCaseFieldGetAddr (_uref, _idx, _readonly), _tyargs, [obj] -> + | 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 env obj ctxt IsTailCall.No - | TOp.ILAsm (instrs, _retTypes), _, _ -> + | TOp.ILAsm (instrs, _retTypes), _, _ -> 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 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 // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec) ], _ -> - // permit byref for lhs lvalue + // permit byref for lhs lvalue CheckExprsPermitByRefLike cenv env args // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec); AI_nop ], _ -> - // permit byref for lhs lvalue of readonly value + // permit byref for lhs lvalue of readonly value CheckExprsPermitByRefLike cenv env args - | [ I_ldsflda _fspec ], [] -> - () + | [ I_ldsflda _fspec ], [] -> () - | [ I_ldflda _fspec ], [obj] -> + | [ I_ldflda _fspec ], [ obj ] -> // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable CheckExpr cenv env obj ctxt IsTailCall.No | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> - // permit byref for lhs lvalue + // permit byref for lhs lvalue CheckExprPermitByRefLike cenv env lhsArray CheckExprsNoByRefLike cenv env indices |> ignore | [ AI_conv _ ], _ -> - // permit byref for args to conv - CheckExprsPermitByRefLike cenv env args + // permit byref for args to conv + CheckExprsPermitByRefLike cenv env args - | _ -> - CheckExprsNoByRefLike cenv env args + | _ -> CheckExprsNoByRefLike cenv env args | TOp.TraitCall _, _, _ -> // CheckTypeInstNoByrefs cenv env m tyargs - // allow args to be byref here + // allow args to be byref here CheckExprsPermitByRefLike cenv env args - - | TOp.Recd _, _, _ -> - CheckExprsPermitByRefLike cenv env args - - | _ -> - CheckExprsNoByRefLike cenv env args -and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isTailCall: IsTailCall) alwaysCheckNoReraise expr mOrig ety ctxt : unit = + | TOp.Recd _, _, _ -> CheckExprsPermitByRefLike cenv env args + + | _ -> CheckExprsNoByRefLike cenv env args + +and CheckLambdas + isTop + (memberVal: Val option) + cenv + env + inlined + valReprInfo + (isTailCall: IsTailCall) + alwaysCheckNoReraise + expr + mOrig + ety + ctxt + : unit = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) - // The valReprInfo here says we are _guaranteeing_ to compile a function value - // as a .NET method with precisely the corresponding argument counts. + // 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 env inlined valReprInfo isTailCall alwaysCheckNoReraise e1 m ety ctxt + | Expr.TyChoose (_tps, e1, m) -> CheckLambdas isTop memberVal cenv env inlined valReprInfo isTailCall alwaysCheckNoReraise e1 m ety ctxt - | Expr.Lambda (_, _, _, _, _, m, _) + | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> - let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) + let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = + destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) + let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt let restArgs = List.concat vsl - match memInfo with + match memInfo with | None -> () - | Some mi -> + | Some mi -> // ctorThis and baseVal values are always considered used - for v in thisAndBase do v.SetHasBeenReferenced() + for v in thisAndBase do + v.SetHasBeenReferenced() // instance method 'this' is always considered used match mi.MemberFlags.IsInstance, restArgs with | true, firstArg :: _ -> firstArg.SetHasBeenReferenced() @@ -648,108 +670,115 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo (isT CheckExprPermitReturnableByRef cenv env body |> ignore else CheckExprNoByrefs cenv env isTailCall body - + // 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. + // allow byref to occur as RHS of byref binding. CheckExpr cenv env expr ctxt isTailCall - else + else CheckExprNoByrefs cenv env isTailCall expr - and CheckExprs cenv env exprs ctxts isTailCall : 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 env exp (argArity i) isTailCall) + let ctxts = Array.ofList ctxts + + let argArity i = + if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No + + exprs + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) isTailCall) |> ignore -and CheckExprsNoByRefLike cenv env exprs : unit = +and CheckExprsNoByRefLike cenv env exprs : unit = for expr in exprs do CheckExprNoByrefs cenv env IsTailCall.No expr -and CheckExprsPermitByRefLike cenv env exprs : unit = - exprs - |> List.map (CheckExprPermitByRefLike cenv env) - |> ignore +and CheckExprsPermitByRefLike cenv env exprs : unit = + exprs |> List.map (CheckExprPermitByRefLike cenv env) |> ignore -and CheckExprPermitByRefLike cenv env expr : unit = +and CheckExprPermitByRefLike cenv env expr : unit = CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No -and CheckExprPermitReturnableByRef cenv env expr : unit = +and CheckExprPermitReturnableByRef cenv env expr : unit = CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No -and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = - targets - |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) +and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = + targets + |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) |> List.ofArray |> ignore -and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget(_vs, targetExpr, _)) : unit = +and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget (_vs, targetExpr, _)) : unit = CheckExpr cenv env targetExpr ctxt isTailCall and CheckDecisionTree cenv env dtree = - match dtree with - | TDSuccess (resultExprs, _) -> - CheckExprsNoByRefLike cenv env resultExprs |> ignore - | TDBind(bind, rest) -> + match dtree with + | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv env resultExprs |> ignore + | TDBind (bind, rest) -> CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore - CheckDecisionTree cenv env rest - | TDSwitch (inpExpr, cases, dflt, m) -> - CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) + CheckDecisionTree cenv env rest + | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = - CheckExprPermitByRefLike cenv env inpExpr |> ignore// can be byref for struct union switch - for (TCase(discrim, dtree)) in cases do + CheckExprPermitByRefLike cenv env inpExpr |> ignore // can be byref for struct union switch + + for (TCase (discrim, dtree)) in cases do CheckDecisionTreeTest cenv env m discrim CheckDecisionTree cenv env dtree - dflt |> Option.iter (CheckDecisionTree cenv env) + + dflt |> Option.iter (CheckDecisionTree cenv env) and CheckDecisionTreeTest cenv env _m discrim = match discrim with | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env IsTailCall.No exp | _ -> () -and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : unit = +and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind (v, bindRhs, _) as bind) : unit = let g = cenv.g let isTop = Option.isSome bind.Var.ValReprInfo let isTailCall = IsTailCall.YesFromVal g bind.Var - let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData + + let valReprInfo = + match bind.Var.ValReprInfo with + | Some info -> info + | _ -> ValReprInfo.emptyValData + CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt -and CheckBindings cenv env binds = +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 (isRec: bool) (TBind(_v, _e, _) as bind) = +let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) 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.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + | Expr.Lambda (_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> let rec checkTailCall (insideSubBinding: bool) expr = match expr with - | Expr.Val(valRef, _valUseFlag, m) -> + | Expr.Val (valRef, _valUseFlag, m) -> if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then - warning(Error(FSComp.SR.chkNotTailRecursive(valRef.DisplayName), m)) - | Expr.App(funcExpr, _formalType, _typeArgs, exprs, _range) -> + warning (Error(FSComp.SR.chkNotTailRecursive (valRef.DisplayName), m)) + | Expr.App (funcExpr, _formalType, _typeArgs, exprs, _range) -> checkTailCall insideSubBinding funcExpr exprs |> List.iter (checkTailCall insideSubBinding) | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value - | Expr.Lambda(_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + | Expr.Lambda (_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> checkTailCall insideSubBinding bodyExpr - | Expr.DebugPoint(_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr - | Expr.Let(binding, bodyExpr, _range, _frees) -> + | Expr.DebugPoint (_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr + | Expr.Let (binding, bodyExpr, _range, _frees) -> checkTailCall true binding.Expr checkTailCall insideSubBinding bodyExpr - | Expr.Match(_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> - decisionTreeTargets |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) + | Expr.Match (_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + decisionTreeTargets + |> Array.iter (fun target -> checkTailCall insideSubBinding target.TargetExpression) | _ -> () + checkTailCall false bodyExpr | _ -> () @@ -760,82 +789,96 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind(_v, _e, _) as bind) = //-------------------------------------------------------------------------- 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 + 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 = +let rec CheckDefnsInModule cenv env mdefs = for mdef in mdefs do CheckDefnInModule cenv env mdef -and CheckDefnInModule cenv env mdef = - match mdef with - | TMDefRec(isRec, _opens, _tycons, mspecs, _m) -> +and CheckDefnInModule cenv env mdef = + match mdef with + | TMDefRec (isRec, _opens, _tycons, mspecs, _m) -> let env = if isRec then 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 } + 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 + List.iter (CheckModuleSpec cenv env isRec) mspecs - | TMDefLet(bind, _m) -> - CheckModuleBinding cenv env false bind - | TMDefOpens _ -> - () - | TMDefDo(e, _m) -> + | TMDefLet (bind, _m) -> CheckModuleBinding cenv env false bind + | TMDefOpens _ -> () + | TMDefDo (e, _m) -> let isTailCall = match stripDebugPoints e with - | Expr.App(funcExpr = funcExpr) -> - match funcExpr 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 + | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env isRec mbind = - match mbind with + 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 } + { env with + mustTailCall = Zset.empty valOrder + mustTailCallExprs = Map.empty + } + CheckModuleBinding cenv env isRec bind - | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> - CheckDefnInModule cenv env rhs + | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv env rhs let CheckImplFile (g, amap, reportErrors, implFileContents) = - let cenv = - { g = g - reportErrors = reportErrors - stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") - amap = amap } - - let env = - { mustTailCall = Zset.empty valOrder - mustTailCallExprs = Map.Empty } - + let cenv = + { + g = g + reportErrors = reportErrors + stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") + amap = amap + } + + let env = + { + mustTailCall = Zset.empty valOrder + mustTailCallExprs = Map.Empty + } + CheckDefnInModule cenv env implFileContents From e0e0acafc4a92b31bec5b5362f5c7c19a13c7e52 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 14:19:16 +0200 Subject: [PATCH 50/77] bring over support for TyLambda bodies from other branch --- src/Compiler/Checking/TailCallChecks.fs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 6365302ccee..b38a0ee29d5 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -758,25 +758,26 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = // 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.Lambda (_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> + | Expr.TyLambda (bodyExpr = bodyExpr) + | Expr.Lambda (bodyExpr = bodyExpr) -> let rec checkTailCall (insideSubBinding: bool) expr = match expr with - | Expr.Val (valRef, _valUseFlag, m) -> + | Expr.Val (valRef = valRef; range = m) -> if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then warning (Error(FSComp.SR.chkNotTailRecursive (valRef.DisplayName), m)) - | Expr.App (funcExpr, _formalType, _typeArgs, exprs, _range) -> + | Expr.App (funcExpr = funcExpr; args = argExprs) -> checkTailCall insideSubBinding funcExpr - exprs |> List.iter (checkTailCall insideSubBinding) + argExprs |> List.iter (checkTailCall insideSubBinding) | Expr.Link exprRef -> checkTailCall insideSubBinding exprRef.Value - | Expr.Lambda (_unique, _ctorThisValOpt, _baseValOpt, _valParams, bodyExpr, _range, _overallType) -> - checkTailCall insideSubBinding bodyExpr + | Expr.Lambda (bodyExpr = bodyExpr) -> checkTailCall insideSubBinding bodyExpr | Expr.DebugPoint (_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr - | Expr.Let (binding, bodyExpr, _range, _frees) -> + | Expr.Let (binding = binding; bodyExpr = bodyExpr) -> checkTailCall true binding.Expr checkTailCall insideSubBinding bodyExpr - | Expr.Match (_debugPointAtBinding, _inputRange, _decisionTree, decisionTreeTargets, _fullRange, _exprType) -> + | 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 From 00717673e9090bc16c288a6691f470f51c1aaffa Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 14:48:51 +0200 Subject: [PATCH 51/77] adjust expected errors --- .../ErrorMessages/TailCallAttribute.fs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 4ded69238a9..f04efb9ca8c 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -462,13 +462,6 @@ namespace N |> compile |> shouldFail |> withResults [ - { Error = Warning 3569 - Range = { StartLine = 8 - StartColumn = 22 - EndLine = 8 - EndColumn = 31 } - 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 = 8 StartColumn = 22 From 5b6ef3416a70b14ee980be3d6a548b25327ba600 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 16:15:00 +0200 Subject: [PATCH 52/77] fix the doubled error messages --- src/Compiler/Checking/TailCallChecks.fs | 27 ++------- .../ErrorMessages/TailCallAttribute.fs | 56 ------------------- 2 files changed, 4 insertions(+), 79 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index b38a0ee29d5..c0d30471a25 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -1,7 +1,5 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -/// Implements a set of checks on the TAST for a file that can only be performed after type inference -/// is complete. module internal FSharp.Compiler.TailCallChecks open Internal.Utilities.Collections @@ -167,20 +165,6 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = 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: ValRef) m (_ctxt: PermitByRefExpr) (isTailCall: IsTailCall) = - // To warn for mutually recursive calls like in the following tests: - // ``Warn for invalid tailcalls in rec module`` - // ``Warn successfully for invalid tailcalls in type methods`` - if cenv.reportErrors then - 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)) - -/// Check a use of a value -and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, _vFlags, m) (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = - CheckValRef cenv env vref m ctxt isTailCall - /// Check an expression, given information about the position of the expression and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = let g = cenv.g @@ -240,7 +224,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i else true - // warn if we call inside of recursive scope in non-tail-call manner or with tail blockers. See + // 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 @@ -332,7 +316,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | Expr.Const (_, _m, _ty) -> () - | Expr.Val (vref, vFlags, m) -> CheckValUse cenv env (vref, vFlags, m) ctxt isTailCall + | Expr.Val (_vref, _vFlags, _m) -> () | Expr.Quote (_ast, _savedConv, _isFromQueryExpression, _m, _ty) -> () @@ -403,18 +387,15 @@ and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, _m) = CheckMethods cenv env basev (ty, overrides) CheckInterfaceImpls cenv env basev iimpls -and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, baseVal, rest, m) : unit = +and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) : unit = let memberInfo = Option.get v.MemberInfo if memberInfo.MemberFlags.IsDispatchSlot then () else - CheckValRef cenv env v m PermitByRefExpr.No IsTailCall.No - CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No -and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, baseVal, rest, m) : unit = - CheckValRef cenv env baseVal m PermitByRefExpr.No IsTailCall.No +and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = CheckExprsPermitByRefLike cenv env rest and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) : unit = diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index f04efb9ca8c..9a68845f0c1 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -33,13 +33,6 @@ namespace N EndColumn = 43 } 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 = 12 - StartColumn = 19 - EndLine = 12 - EndColumn = 23 } - Message = - "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -69,13 +62,6 @@ namespace N EndColumn = 45 } 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 = 12 - StartColumn = 21 - EndLine = 12 - EndColumn = 25 } - Message = - "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -107,13 +93,6 @@ namespace N EndColumn = 49 } 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 = 13 - StartColumn = 25 - EndLine = 13 - EndColumn = 29 } - Message = - "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -183,13 +162,6 @@ namespace N EndColumn = 28 } 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 = 17 - StartColumn = 17 - EndLine = 17 - EndColumn = 20 } - Message = - "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -359,13 +331,6 @@ namespace N EndColumn = 34 } 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 = 9 - StartColumn = 25 - EndLine = 9 - EndColumn = 26 } - Message = - "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -393,13 +358,6 @@ namespace N EndColumn = 33 } 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 = 9 - StartColumn = 24 - EndLine = 9 - EndColumn = 25 } - Message = - "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] @@ -526,13 +484,6 @@ namespace N EndColumn = 43 } 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 = 8 - StartColumn = 32 - EndLine = 8 - EndColumn = 41 } - 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 = 12 StartColumn = 32 @@ -676,13 +627,6 @@ namespace N EndColumn = 48 } 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 = 24 - StartColumn = 17 - EndLine = 24 - EndColumn = 34 } - 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 = 35 StartColumn = 17 From bcf5cb393e79fd003d710620d5afda9cb98328fe Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 17:04:55 +0200 Subject: [PATCH 53/77] fix seq analysis --- src/Compiler/Checking/TailCallChecks.fs | 6 +++--- .../ErrorMessages/TailCallAttribute.fs | 13 +++++++++++-- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index c0d30471a25..58c2aa2b343 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -36,8 +36,8 @@ type env = let (|ValUseAtApp|_|) e = match e with - | InnerExprPat (Expr.App (InnerExprPat (Expr.Val (valRef = vref; flags = valUseFlags)), _, _, [], _) | Expr.Val (valRef = vref - flags = valUseFlags)) -> + | InnerExprPat (Expr.App (funcExpr = InnerExprPat (Expr.Val (valRef = vref; flags = valUseFlags))) | Expr.Val (valRef = vref + flags = valUseFlags)) -> Some(vref, valUseFlags) | _ -> None @@ -285,7 +285,7 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail | _ -> // not a linear expression - CheckExpr cenv env expr ctxt isTailCall + CheckExpr cenv env expr ctxt (IsTailCall.YesFromExpr cenv.g expr) /// Check an expression, given information about the position of the expression and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 9a68845f0c1..7d5741251aa 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -553,13 +553,22 @@ namespace N | TMDefOpens _ -> () | TMDefs defs -> for def in defs do - yield! allValsAndExprsOfModDef def + yield! allValsAndExprsOfModDef def // ToDo: okay to warn here? } """ |> FSharp |> withLangVersionPreview |> compile - |> shouldSucceed + |> shouldFail + |> withResults [ + { Error = Warning 3569 + Range = { StartLine = 34 + StartColumn = 32 + EndLine = 34 + EndColumn = 59 } + Message = + "The member or function 'allValsAndExprsOfModDef' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + ] [] let ``Warn for calls in for and iter`` () = From 2d30a429c26b96ef7b3f2f74fb8626fd8e2d5c4f Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 4 Jul 2023 17:20:55 +0200 Subject: [PATCH 54/77] cleanup --- src/Compiler/Checking/TailCallChecks.fs | 38 +++++++++++-------------- 1 file changed, 17 insertions(+), 21 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 58c2aa2b343..47fabbaff96 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -16,8 +16,7 @@ open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TypeRelations -let PostInferenceChecksStackGuardDepth = - GetEnvInteger "FSHARP_PostInferenceChecks" 50 +let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_TailCallChecks" 50 //-------------------------------------------------------------------------- // check environment @@ -36,8 +35,8 @@ type env = let (|ValUseAtApp|_|) e = match e with - | InnerExprPat (Expr.App (funcExpr = InnerExprPat (Expr.Val (valRef = vref; flags = valUseFlags))) | Expr.Val (valRef = vref - flags = valUseFlags)) -> + | InnerExprPat (Expr.App(funcExpr = InnerExprPat (Expr.Val (valRef = vref; flags = valUseFlags))) | Expr.Val (valRef = vref + flags = valUseFlags)) -> Some(vref, valUseFlags) | _ -> None @@ -163,7 +162,7 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = /// Check an expression, where the expression is in a position where byrefs can be generated let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = - CheckExpr cenv env expr PermitByRefExpr.No isTailCall |> ignore + CheckExpr cenv env expr PermitByRefExpr.No isTailCall /// Check an expression, given information about the position of the expression and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = @@ -228,7 +227,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i // ``Warn successfully in match clause`` // ``Warn for byref parameters`` if not canTailCall then - warning (Error(FSComp.SR.chkNotTailRecursive (vref.DisplayName), m)) + warning (Error(FSComp.SR.chkNotTailRecursive vref.DisplayName, m)) | _ -> () | _ -> () @@ -314,11 +313,9 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa CheckExprNoByrefs cenv env IsTailCall.No e1 CheckExprNoByrefs cenv env IsTailCall.No e2 - | Expr.Const (_, _m, _ty) -> () - - | Expr.Val (_vref, _vFlags, _m) -> () - - | Expr.Quote (_ast, _savedConv, _isFromQueryExpression, _m, _ty) -> () + | Expr.Const _ + | Expr.Val _ + | Expr.Quote _ -> () | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv env expr info @@ -447,7 +444,6 @@ and CheckMethods cenv env baseValOpt (ty, methods) = and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No - |> ignore and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -583,7 +579,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> // permit byref for lhs lvalue CheckExprPermitByRefLike cenv env lhsArray - CheckExprsNoByRefLike cenv env indices |> ignore + CheckExprsNoByRefLike cenv env indices | [ AI_conv _ ], _ -> // permit byref for args to conv @@ -648,7 +644,7 @@ and CheckLambdas // 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 env body |> ignore + CheckExprPermitReturnableByRef cenv env body else CheckExprNoByrefs cenv env isTailCall body @@ -696,16 +692,16 @@ and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget (_vs and CheckDecisionTree cenv env dtree = match dtree with - | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv env resultExprs |> ignore + | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv env resultExprs | TDBind (bind, rest) -> - CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore + CheckBinding cenv env false PermitByRefExpr.Yes bind CheckDecisionTree cenv env rest | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = - CheckExprPermitByRefLike cenv env inpExpr |> ignore // can be byref for struct union switch + CheckExprPermitByRefLike cenv env inpExpr // can be byref for struct union switch - for (TCase (discrim, dtree)) in cases do + for TCase (discrim, dtree) in cases do CheckDecisionTreeTest cenv env m discrim CheckDecisionTree cenv env dtree @@ -730,7 +726,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind (v, bindRhs, _) as bi and CheckBindings cenv env binds = for bind in binds do - CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore + CheckBinding cenv env false PermitByRefExpr.Yes bind // Top binds introduce expression, check they are reraise free. let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = @@ -745,7 +741,7 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = 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)) + warning (Error(FSComp.SR.chkNotTailRecursive valRef.DisplayName, m)) | Expr.App (funcExpr = funcExpr; args = argExprs) -> checkTailCall insideSubBinding funcExpr argExprs |> List.iter (checkTailCall insideSubBinding) @@ -764,7 +760,7 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = checkTailCall false bodyExpr | _ -> () - CheckBinding cenv env true PermitByRefExpr.Yes bind |> ignore + CheckBinding cenv env true PermitByRefExpr.Yes bind //-------------------------------------------------------------------------- // check modules From 85c83cdcb0c4499f1e9e7effe9a2c9e877d9d009 Mon Sep 17 00:00:00 2001 From: dawe Date: Wed, 5 Jul 2023 18:05:51 +0200 Subject: [PATCH 55/77] cover some more rec constructs --- src/Compiler/Checking/TailCallChecks.fs | 10 ++- .../ErrorMessages/TailCallAttribute.fs | 75 +++++++++++++++++++ 2 files changed, 83 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 47fabbaff96..cf279b4cb3a 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -750,11 +750,17 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = | Expr.DebugPoint (_debugPointAtLeafExpr, expr) -> checkTailCall insideSubBinding expr | Expr.Let (binding = binding; bodyExpr = bodyExpr) -> checkTailCall true binding.Expr - checkTailCall insideSubBinding bodyExpr + + 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 (op = TOp.Coerce; args = exprs) -> exprs |> Seq.iter (checkTailCall insideSubBinding) + | Expr.Op (args = exprs) -> exprs |> Seq.iter (checkTailCall insideSubBinding) | _ -> () checkTailCall false bodyExpr diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 7d5741251aa..6a47bf339d9 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -756,3 +756,78 @@ namespace N |> 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 'TailCall' 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 'TailCall' 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 From e278ed5bc58fd45fd26ed3cc5fa86d0c6cccf5ae Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 6 Jul 2023 15:25:33 +0200 Subject: [PATCH 56/77] remove commented code from tests --- .../ErrorMessages/TailCallAttribute.fs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 6a47bf339d9..3627689c453 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -22,7 +22,6 @@ namespace N """ |> FSharp |> withLangVersionPreview - // |> typecheck |> compile |> shouldFail |> withResults [ @@ -815,7 +814,7 @@ namespace N ] [] - let ``Don't warn for ColonColon as arg of valid tail call `` () = + let ``Don't warn for ColonColon as arg of valid tail call`` () = """ namespace N From d80f74e438d4a190ab904aeff7f2f19166fdeb74 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 6 Jul 2023 15:41:50 +0200 Subject: [PATCH 57/77] Rename the type "IsTailCall" to "TailCall" --- src/Compiler/Checking/TailCallChecks.fs | 175 ++++++++++++------------ 1 file changed, 87 insertions(+), 88 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index cf279b4cb3a..35b618b5311 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -40,7 +40,7 @@ let (|ValUseAtApp|_|) e = Some(vref, valUseFlags) | _ -> None -type IsTailCall = +type TailCall = | Yes of bool // true indicates "has unit return type and must return void" | No @@ -55,19 +55,18 @@ type IsTailCall = isUnitTy g returnTy | None -> false - static member YesFromVal (g: TcGlobals) (v: Val) = - IsTailCall.Yes(IsTailCall.IsVoidRet g v) + 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, _) -> IsTailCall.Yes(IsTailCall.IsVoidRet g valRef.Deref) - | _ -> IsTailCall.Yes false + | ValUseAtApp (valRef, _) -> TailCall.Yes(TailCall.IsVoidRet g valRef.Deref) + | _ -> TailCall.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 + | TailCall.Yes _ -> TailCall.Yes false + | TailCall.No -> TailCall.No let IsValRefIsDllImport g (vref: ValRef) = vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute @@ -161,11 +160,11 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = | _ -> [] /// Check an expression, where the expression is in a position where byrefs can be generated -let rec CheckExprNoByrefs cenv env (isTailCall: IsTailCall) expr = - CheckExpr cenv env expr PermitByRefExpr.No isTailCall +let rec CheckExprNoByrefs cenv env (tailCall: TailCall) expr = + CheckExpr cenv env expr PermitByRefExpr.No tailCall /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (isTailCall: IsTailCall) = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (tailCall: TailCall) = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -180,10 +179,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> let canTailCall = - match isTailCall with - | IsTailCall.No -> // an upper level has already decided that this is not in a tailcall position + match tailCall with + | TailCall.No -> // an upper level has already decided that this is not in a tailcall position false - | IsTailCall.Yes isVoidRet -> + | TailCall.Yes isVoidRet -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value @@ -233,7 +232,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (i /// Check call arguments, including the return argument. and CheckCall cenv env _m _returnTy args ctxts _ctxt = - CheckExprs cenv env args ctxts IsTailCall.No + CheckExprs cenv env args ctxts TailCall.No /// Check call arguments, including the return argument. The receiver argument is handled differently. and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = @@ -246,15 +245,15 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = | [] -> PermitByRefExpr.No, [] | ctxt :: ctxts -> ctxt, ctxts - CheckExpr cenv env receiverArg receiverContext IsTailCall.No - CheckExprs cenv env args ctxts (IsTailCall.Yes false) + CheckExpr cenv env receiverArg receiverContext TailCall.No + CheckExprs cenv env args ctxts (TailCall.Yes false) -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = +and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> - CheckExprNoByrefs cenv env IsTailCall.No e1 + CheckExprNoByrefs cenv env TailCall.No e1 // tailcall - CheckExprLinear cenv env e2 ctxt isTailCall + CheckExprLinear cenv env e2 ctxt tailCall | Expr.Let (TBind (v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type @@ -267,27 +266,27 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (isTail CheckBinding cenv env false bindingContext bind // tailcall - CheckExprLinear cenv env body ctxt isTailCall + CheckExprLinear cenv env body ctxt tailCall | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> - argsHead |> List.iter (CheckExprNoByrefs cenv env isTailCall) + argsHead |> List.iter (CheckExprNoByrefs cenv env tailCall) // tailcall - CheckExprLinear cenv env argLast PermitByRefExpr.No isTailCall + CheckExprLinear cenv env argLast PermitByRefExpr.No tailCall | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, _m, _ty) -> CheckDecisionTree cenv env dtree - CheckDecisionTreeTarget cenv env isTailCall ctxt tg1 + CheckDecisionTreeTarget cenv env tailCall ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt isTailCall + CheckExprLinear cenv env e2 ctxt tailCall - | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt isTailCall + | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt tailCall | _ -> // not a linear expression - CheckExpr cenv env expr ctxt (IsTailCall.YesFromExpr cenv.g expr) + CheckExpr cenv env expr ctxt (TailCall.YesFromExpr cenv.g expr) /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCall: IsTailCall) : unit = +and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = // Guard the stack for deeply nested expressions cenv.stackGuard.Guard @@ -298,7 +297,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr isTailCall + CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr tailCall let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr @@ -307,11 +306,11 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | LinearMatchExpr _ | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) - | Expr.DebugPoint _ -> CheckExprLinear cenv env expr ctxt isTailCall + | Expr.DebugPoint _ -> CheckExprLinear cenv env expr ctxt tailCall | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs cenv env IsTailCall.No e1 - CheckExprNoByrefs cenv env IsTailCall.No e2 + CheckExprNoByrefs cenv env TailCall.No e1 + CheckExprNoByrefs cenv env TailCall.No e2 | Expr.Const _ | Expr.Val _ @@ -349,17 +348,17 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (isTailCa | TypeDefOfExpr g ty when isVoidTy g ty -> () // Check an application - | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt isTailCall + | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt tailCall - | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv env expr (argvs, m, bodyTy) isTailCall + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv env expr (argvs, m, bodyTy) tailCall - | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) isTailCall + | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) tailCall - | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv env isTailCall e1 + | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv env tailCall e1 - | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) isTailCall + | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) tailCall - | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv env (binds, bodyExpr) isTailCall + | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv env (binds, bodyExpr) tailCall | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) @@ -375,12 +374,12 @@ and CheckStructStateMachineExpr cenv env _expr info = (_afterCodeThisVar, afterCodeBody)) = info - CheckExprNoByrefs cenv env IsTailCall.No moveNextExpr - CheckExprNoByrefs cenv env IsTailCall.No setStateMachineBody - CheckExprNoByrefs cenv env IsTailCall.No afterCodeBody + CheckExprNoByrefs cenv env TailCall.No moveNextExpr + CheckExprNoByrefs cenv env TailCall.No setStateMachineBody + CheckExprNoByrefs cenv env TailCall.No afterCodeBody and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, _m) = - CheckExprNoByrefs cenv env IsTailCall.No superInitCall + CheckExprNoByrefs cenv env TailCall.No superInitCall CheckMethods cenv env basev (ty, overrides) CheckInterfaceImpls cenv env basev iimpls @@ -390,16 +389,16 @@ and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) if memberInfo.MemberFlags.IsDispatchSlot then () else - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) IsTailCall.No + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) TailCall.No and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = CheckExprsPermitByRefLike cenv env rest -and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTailCall) : unit = +and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCall) : unit = let g = cenv.g let returnTy = tyOfExpr g expr - CheckExprNoByrefs cenv env isTailCall f + CheckExprNoByrefs cenv env tailCall f let hasReceiver = match f with @@ -413,37 +412,37 @@ and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (isTailCall: IsTa else CheckCall cenv env m returnTy argsl ctxts ctxt -and CheckLambda cenv env expr (argvs, m, bodyTy) (isTailCall: IsTailCall) = +and CheckLambda cenv env 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 env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) (isTailCall: IsTailCall) = +and CheckTyLambda cenv env expr (tps, m, bodyTy) (tailCall: TailCall) = let valReprInfo = ValReprInfo(ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) let ty = mkForallTyIfNeeded tps bodyTy in - CheckLambdas false None cenv env false valReprInfo isTailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv env false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) isTailCall = +and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) tailCall = CheckDecisionTree cenv env dtree - CheckDecisionTreeTargets cenv env targets ctxt isTailCall + CheckDecisionTreeTargets cenv env targets ctxt tailCall -and CheckLetRec cenv env (binds, bodyExpr) isTailCall = +and CheckLetRec cenv env (binds, bodyExpr) tailCall = CheckBindings cenv env binds - CheckExprNoByrefs cenv env isTailCall bodyExpr + CheckExprNoByrefs cenv env tailCall bodyExpr and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = - CheckExprNoByrefs cenv env IsTailCall.No e2 - CheckExprNoByrefs cenv env IsTailCall.No e3 + CheckExprNoByrefs cenv env TailCall.No e2 + CheckExprNoByrefs cenv env TailCall.No e3 and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty) and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = - CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal IsTailCall.No + CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal TailCall.No and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -461,8 +460,8 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = CheckExprsNoByRefLike cenv env [ e1; e2 ] | TOp.TryFinally _, [ _ ], [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _) ] -> - 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 + CheckExpr cenv env 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 env TailCall.No e2 | TOp.IntegerForLoop _, _, @@ -472,9 +471,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | TOp.TryWith _, [ _ ], [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], _e2, _, _); Expr.Lambda (_, _, _, [ _ ], e3, _, _) ] -> - 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 + CheckExpr cenv env 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 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 + CheckExpr cenv env 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), _, _ -> @@ -522,12 +521,12 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | TOp.ValFieldSet _rf, _, [ _arg1; _arg2 ] -> () | TOp.Coerce, [ tgtTy; srcTy ], [ x ] -> - let isTailCall = IsTailCall.YesFromExpr cenv.g x + let tailCall = TailCall.YesFromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt isTailCall + CheckExpr cenv env x ctxt tailCall else - CheckExprNoByrefs cenv env isTailCall x + CheckExprNoByrefs cenv env tailCall x | TOp.Reraise, [ _ty1 ], [] -> () @@ -537,7 +536,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = // 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 env obj ctxt IsTailCall.No + CheckExpr cenv env obj ctxt TailCall.No | TOp.UnionCaseFieldGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv env arg1 @@ -545,14 +544,14 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | 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 env obj ctxt IsTailCall.No + CheckExpr cenv env 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 env IsTailCall.No rhs + | [ _; rhs ] -> CheckExprNoByrefs cenv env TailCall.No rhs | _ -> () // permit byref for lhs lvalue @@ -574,7 +573,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | [ I_ldflda _fspec ], [ obj ] -> // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable - CheckExpr cenv env obj ctxt IsTailCall.No + CheckExpr cenv env obj ctxt TailCall.No | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> // permit byref for lhs lvalue @@ -603,7 +602,7 @@ and CheckLambdas env inlined valReprInfo - (isTailCall: IsTailCall) + (tailCall: TailCall) alwaysCheckNoReraise expr mOrig @@ -616,7 +615,7 @@ and CheckLambdas // 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 env inlined valReprInfo isTailCall alwaysCheckNoReraise e1 m ety ctxt + | Expr.TyChoose (_tps, e1, m) -> CheckLambdas isTop memberVal cenv env inlined valReprInfo tailCall alwaysCheckNoReraise e1 m ety ctxt | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> @@ -646,7 +645,7 @@ and CheckLambdas // allow byref to occur as return position for byref-typed top level function or method CheckExprPermitReturnableByRef cenv env body else - CheckExprNoByrefs cenv env isTailCall body + CheckExprNoByrefs cenv env tailCall body // This path is for expression bindings that are not actually lambdas | _ -> @@ -654,41 +653,41 @@ and CheckLambdas 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 isTailCall + CheckExpr cenv env expr ctxt tailCall else - CheckExprNoByrefs cenv env isTailCall expr + CheckExprNoByrefs cenv env tailCall expr -and CheckExprs cenv env exprs ctxts isTailCall : unit = +and CheckExprs cenv env exprs ctxts 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 env exp (argArity i) isTailCall) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) tailCall) |> ignore and CheckExprsNoByRefLike cenv env exprs : unit = for expr in exprs do - CheckExprNoByrefs cenv env IsTailCall.No expr + CheckExprNoByrefs cenv env TailCall.No expr and CheckExprsPermitByRefLike cenv env exprs : unit = exprs |> List.map (CheckExprPermitByRefLike cenv env) |> ignore and CheckExprPermitByRefLike cenv env expr : unit = - CheckExpr cenv env expr PermitByRefExpr.Yes IsTailCall.No + CheckExpr cenv env expr PermitByRefExpr.Yes TailCall.No and CheckExprPermitReturnableByRef cenv env expr : unit = - CheckExpr cenv env expr PermitByRefExpr.YesReturnable IsTailCall.No + CheckExpr cenv env expr PermitByRefExpr.YesReturnable TailCall.No -and CheckDecisionTreeTargets cenv env targets ctxt (isTailCall: IsTailCall) = +and CheckDecisionTreeTargets cenv env targets ctxt (tailCall: TailCall) = targets - |> Array.map (CheckDecisionTreeTarget cenv env isTailCall ctxt) + |> Array.map (CheckDecisionTreeTarget cenv env tailCall ctxt) |> List.ofArray |> ignore -and CheckDecisionTreeTarget cenv env (isTailCall: IsTailCall) ctxt (TTarget (_vs, targetExpr, _)) : unit = - CheckExpr cenv env targetExpr ctxt isTailCall +and CheckDecisionTreeTarget cenv env (tailCall: TailCall) ctxt (TTarget (_vs, targetExpr, _)) : unit = + CheckExpr cenv env targetExpr ctxt tailCall and CheckDecisionTree cenv env dtree = match dtree with @@ -709,20 +708,20 @@ and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = and CheckDecisionTreeTest cenv env _m discrim = match discrim with - | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env IsTailCall.No exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env TailCall.No exp | _ -> () and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind (v, bindRhs, _) as bind) : unit = let g = cenv.g let isTop = Option.isSome bind.Var.ValReprInfo - let isTailCall = IsTailCall.YesFromVal g bind.Var + let tailCall = TailCall.YesFromVal g bind.Var let valReprInfo = match bind.Var.ValReprInfo with | Some info -> info | _ -> ValReprInfo.emptyValData - CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo isTailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo tailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt and CheckBindings cenv env binds = for bind in binds do @@ -824,15 +823,15 @@ and CheckDefnInModule cenv env mdef = | TMDefLet (bind, _m) -> CheckModuleBinding cenv env false bind | TMDefOpens _ -> () | TMDefDo (e, _m) -> - let isTailCall = + let tailCall = match stripDebugPoints e with | Expr.App (funcExpr = funcExpr) -> match funcExpr with - | ValUseAtApp (vref, _valUseFlags) -> IsTailCall.YesFromVal cenv.g vref.Deref - | _ -> IsTailCall.No - | _ -> IsTailCall.No + | ValUseAtApp (vref, _valUseFlags) -> TailCall.YesFromVal cenv.g vref.Deref + | _ -> TailCall.No + | _ -> TailCall.No - CheckExprNoByrefs cenv env isTailCall e + CheckExprNoByrefs cenv env tailCall e | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env isRec mbind = From bd8a90027a35ebf86a76a4208449e49773844b7a Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 6 Jul 2023 16:36:32 +0200 Subject: [PATCH 58/77] model boolean as dedicated type "TailCallReturnType" --- src/Compiler/Checking/TailCallChecks.fs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 35b618b5311..c5f7818db61 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -40,8 +40,12 @@ let (|ValUseAtApp|_|) e = Some(vref, valUseFlags) | _ -> None +type TailCallReturnType = + | MustReturnVoid // indicates "has unit return type and must return void" + | NonVoid + type TailCall = - | Yes of bool // true indicates "has unit return type and must return void" + | Yes of TailCallReturnType | No static member private IsVoidRet (g: TcGlobals) (v: Val) = @@ -52,20 +56,23 @@ type TailCall = let _curriedArgInfos, returnTy = GetTopTauTypeInFSharpForm g info.ArgInfos tau v.Range - isUnitTy g returnTy - | None -> false + 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 false + | _ -> 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 false + | TailCall.Yes _ -> TailCall.Yes TailCallReturnType.NonVoid | TailCall.No -> TailCall.No let IsValRefIsDllImport g (vref: ValRef) = @@ -182,7 +189,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (t match tailCall with | TailCall.No -> // an upper level has already decided that this is not in a tailcall position false - | TailCall.Yes isVoidRet -> + | TailCall.Yes returnType -> if vref.IsMemberOrModuleBinding && vref.ValReprInfo.IsSome then let topValInfo = vref.ValReprInfo.Value @@ -206,7 +213,9 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (t | _ -> false let hasByrefArg = nowArgs |> List.exists (tyOfExpr cenv.g >> isByrefTy cenv.g) - let mustGenerateUnitAfterCall = (isUnitTy g returnTy && not isVoidRet) + + let mustGenerateUnitAfterCall = + (isUnitTy g returnTy && returnType <> TailCallReturnType.MustReturnVoid) let noTailCallBlockers = not isNewObj @@ -246,7 +255,7 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = | ctxt :: ctxts -> ctxt, ctxts CheckExpr cenv env receiverArg receiverContext TailCall.No - CheckExprs cenv env args ctxts (TailCall.Yes false) + CheckExprs cenv env args ctxts (TailCall.Yes TailCallReturnType.NonVoid) and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = match expr with From 48989649c24d5bf80187ba725f7d23f415048e13 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 6 Jul 2023 16:53:24 +0200 Subject: [PATCH 59/77] remove unused members of type "PermitByRefExpr" --- src/Compiler/Checking/TailCallChecks.fs | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index c5f7818db61..aa4560b978e 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -113,24 +113,12 @@ type PermitByRefExpr = /// General (address-of expr and byref values not allowed) | No - member ctxt.Disallow = - match ctxt with - | PermitByRefExpr.Yes - | PermitByRefExpr.YesReturnable - | PermitByRefExpr.YesReturnableNonLocal -> false - | _ -> true - member ctxt.PermitOnlyReturnable = match ctxt with | PermitByRefExpr.YesReturnable | PermitByRefExpr.YesReturnableNonLocal -> true | _ -> false - member ctxt.PermitOnlyReturnableNonLocal = - match ctxt with - | PermitByRefExpr.YesReturnableNonLocal -> true - | _ -> false - let mkArgsPermit n = if n = 1 then PermitByRefExpr.Yes From cc93eea2702e5e2896173666f6bd99175682c1f3 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 7 Jul 2023 00:52:01 +0200 Subject: [PATCH 60/77] remove unused mustTailCallExprs from env --- src/Compiler/Checking/TailCallChecks.fs | 48 +++++-------------------- 1 file changed, 9 insertions(+), 39 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index aa4560b978e..9f574c03d1a 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -26,9 +26,6 @@ type env = { /// Values in module that have been marked [] mustTailCall: Zset - - /// Recursive expressions of [] attributed values - mustTailCallExprs: Map } override _.ToString() = "" @@ -768,24 +765,6 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = // 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 @@ -795,24 +774,20 @@ and CheckDefnInModule cenv env mdef = | TMDefRec (isRec, _opens, _tycons, mspecs, _m) -> let env = if isRec then - let vallsAndExprs = allValsAndExprsOfModDef mdef + let vals = allValsOfModDef mdef - let mustTailCall, mustTailCallExprs = + let mustTailCall = Seq.fold - (fun (mustTailCall, mustTailCallExpr) (v: Val, e) -> + (fun mustTailCall (v: Val) -> 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) + newSet else - (mustTailCall, mustTailCallExpr)) - (env.mustTailCall, env.mustTailCallExprs) - vallsAndExprs + mustTailCall) + env.mustTailCall + vals - { env with - mustTailCall = mustTailCall - mustTailCallExprs = mustTailCallExprs - } + { env with mustTailCall = mustTailCall } else env @@ -840,7 +815,6 @@ and CheckModuleSpec cenv env isRec mbind = else { env with mustTailCall = Zset.empty valOrder - mustTailCallExprs = Map.empty } CheckModuleBinding cenv env isRec bind @@ -855,10 +829,6 @@ let CheckImplFile (g, amap, reportErrors, implFileContents) = amap = amap } - let env = - { - mustTailCall = Zset.empty valOrder - mustTailCallExprs = Map.Empty - } + let env = { mustTailCall = Zset.empty valOrder } CheckDefnInModule cenv env implFileContents From 444be5ecb5360272dff39edab26d0143cc85e517 Mon Sep 17 00:00:00 2001 From: dawe Date: Sat, 8 Jul 2023 23:22:22 +0200 Subject: [PATCH 61/77] add comment to explain origin of PermitByRefExpr --- src/Compiler/Checking/TailCallChecks.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 9f574c03d1a..a9fb03db2b0 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -93,6 +93,7 @@ type cenv = //-------------------------------------------------------------------------- /// 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 From 63c1ac701df7e200fd4d507d312e964a5946d49c Mon Sep 17 00:00:00 2001 From: dawe Date: Sat, 8 Jul 2023 23:32:41 +0200 Subject: [PATCH 62/77] First stab at support for continuation-passing-style --- src/Compiler/Checking/TailCallChecks.fs | 48 ++++-- .../ErrorMessages/TailCallAttribute.fs | 138 ++++++++++++++++++ 2 files changed, 177 insertions(+), 9 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index a9fb03db2b0..e8d82f6255a 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -226,8 +226,8 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (t | _ -> () /// Check call arguments, including the return argument. -and CheckCall cenv env _m _returnTy args ctxts _ctxt = - CheckExprs cenv env args ctxts TailCall.No +and CheckCall cenv env _m _returnTy args tailCalls ctxts _ctxt = + CheckExprs cenv env args ctxts tailCalls /// Check call arguments, including the return argument. The receiver argument is handled differently. and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = @@ -241,7 +241,8 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = | ctxt :: ctxts -> ctxt, ctxts CheckExpr cenv env receiverArg receiverContext TailCall.No - CheckExprs cenv env args ctxts (TailCall.Yes TailCallReturnType.NonVoid) + let tailCalls = List.replicate args.Length (TailCall.Yes TailCallReturnType.NonVoid) + CheckExprs cenv env args ctxts tailCalls and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = match expr with @@ -384,7 +385,8 @@ and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) if memberInfo.MemberFlags.IsDispatchSlot then () else - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) TailCall.No + let tailCalls = List.replicate rest.Length TailCall.No + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) tailCalls and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = CheckExprsPermitByRefLike cenv env rest @@ -405,7 +407,33 @@ and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCa if hasReceiver then CheckCallWithReceiver cenv env m returnTy argsl ctxts ctxt else - CheckCall cenv env m returnTy argsl ctxts ctxt + // if this is an application of a tailcall-attributed function, + // try to recognize continuation passing style in the arguments + // and mark such arguments as valid tailcalls + let isApplicationOfTailCallAttributedFunction = + match f with + | Expr.Val (vref, _, _) -> env.mustTailCall.Contains vref.Deref + | _ -> false + + let rec getTailCall arg = + match stripDebugPoints arg with + | Expr.Lambda (bodyExpr = expr) + | Expr.TyLambda (bodyExpr = expr) + | Expr.App (funcExpr = expr) -> getTailCall expr + | Expr.Val (valRef, _valUseFlag, _range) -> + if env.mustTailCall.Contains valRef.Deref then + TailCall.YesFromVal cenv.g valRef.Deref + else + TailCall.No + | _ -> TailCall.No + + let tailCalls = + if isApplicationOfTailCallAttributedFunction then + List.map getTailCall argsl + else + List.replicate argsl.Length TailCall.No + + CheckCall cenv env m returnTy argsl tailCalls ctxts ctxt and CheckLambda cenv env expr (argvs, m, bodyTy) (tailCall: TailCall) = let valReprInfo = @@ -485,12 +513,14 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts ctxt else - CheckCall cenv env m returnTy args argContexts ctxt + let tailCalls = List.replicate args.Length TailCall.No + CheckCall cenv env m returnTy args tailCalls argContexts ctxt | _ -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes else - CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes + let tailCalls = List.replicate args.Length TailCall.No + CheckCall cenv env m returnTy args tailCalls argContexts PermitByRefExpr.Yes | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> match ctxt with @@ -652,14 +682,14 @@ and CheckLambdas else CheckExprNoByrefs cenv env tailCall expr -and CheckExprs cenv env exprs ctxts tailCall : unit = +and CheckExprs cenv env exprs ctxts (tailCalls: TailCall list) : 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 env exp (argArity i) tailCall) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) tailCalls[i]) |> ignore and CheckExprsNoByRefLike cenv env exprs : unit = diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 3627689c453..1b9ef8274a4 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -830,3 +830,141 @@ namespace N |> 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 'TailCall' 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 'TailCall' 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 'TailCall' 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 'TailCall' 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 From 09d5096dfb9ed4a40233cb89ed15ceae492efdd1 Mon Sep 17 00:00:00 2001 From: dawe Date: Sun, 9 Jul 2023 10:37:30 +0200 Subject: [PATCH 63/77] - refactor approach for CPS support to be much simpler - more CPS tests --- src/Compiler/Checking/TailCallChecks.fs | 57 ++++-------- .../ErrorMessages/TailCallAttribute.fs | 88 ++++++++++++++++--- 2 files changed, 93 insertions(+), 52 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index e8d82f6255a..6d3d83bb0d5 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -226,8 +226,8 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (t | _ -> () /// Check call arguments, including the return argument. -and CheckCall cenv env _m _returnTy args tailCalls ctxts _ctxt = - CheckExprs cenv env args ctxts tailCalls +and CheckCall cenv env _m _returnTy args ctxts _ctxt = + CheckExprs cenv env args ctxts TailCall.No /// Check call arguments, including the return argument. The receiver argument is handled differently. and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = @@ -241,8 +241,7 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = | ctxt :: ctxts -> ctxt, ctxts CheckExpr cenv env receiverArg receiverContext TailCall.No - let tailCalls = List.replicate args.Length (TailCall.Yes TailCallReturnType.NonVoid) - CheckExprs cenv env args ctxts tailCalls + CheckExprs cenv env args ctxts (TailCall.Yes TailCallReturnType.NonVoid) and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = match expr with @@ -385,8 +384,7 @@ and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) if memberInfo.MemberFlags.IsDispatchSlot then () else - let tailCalls = List.replicate rest.Length TailCall.No - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) tailCalls + CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) TailCall.No and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = CheckExprsPermitByRefLike cenv env rest @@ -407,33 +405,7 @@ and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCa if hasReceiver then CheckCallWithReceiver cenv env m returnTy argsl ctxts ctxt else - // if this is an application of a tailcall-attributed function, - // try to recognize continuation passing style in the arguments - // and mark such arguments as valid tailcalls - let isApplicationOfTailCallAttributedFunction = - match f with - | Expr.Val (vref, _, _) -> env.mustTailCall.Contains vref.Deref - | _ -> false - - let rec getTailCall arg = - match stripDebugPoints arg with - | Expr.Lambda (bodyExpr = expr) - | Expr.TyLambda (bodyExpr = expr) - | Expr.App (funcExpr = expr) -> getTailCall expr - | Expr.Val (valRef, _valUseFlag, _range) -> - if env.mustTailCall.Contains valRef.Deref then - TailCall.YesFromVal cenv.g valRef.Deref - else - TailCall.No - | _ -> TailCall.No - - let tailCalls = - if isApplicationOfTailCallAttributedFunction then - List.map getTailCall argsl - else - List.replicate argsl.Length TailCall.No - - CheckCall cenv env m returnTy argsl tailCalls ctxts ctxt + CheckCall cenv env m returnTy argsl ctxts ctxt and CheckLambda cenv env expr (argvs, m, bodyTy) (tailCall: TailCall) = let valReprInfo = @@ -465,7 +437,12 @@ and CheckMethods cenv env baseValOpt (ty, methods) = methods |> List.iter (CheckMethod cenv env baseValOpt ty) and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = - CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal TailCall.No + let tailCall = + match stripDebugPoints body with + | Expr.App _ as a -> TailCall.YesFromExpr cenv.g a + | _ -> TailCall.No + + CheckExpr cenv env body PermitByRefExpr.YesReturnableNonLocal tailCall and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) @@ -513,14 +490,12 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts ctxt else - let tailCalls = List.replicate args.Length TailCall.No - CheckCall cenv env m returnTy args tailCalls argContexts ctxt + CheckCall cenv env m returnTy args argContexts ctxt | _ -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes else - let tailCalls = List.replicate args.Length TailCall.No - CheckCall cenv env m returnTy args tailCalls argContexts PermitByRefExpr.Yes + CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> match ctxt with @@ -670,7 +645,7 @@ and CheckLambdas // allow byref to occur as return position for byref-typed top level function or method CheckExprPermitReturnableByRef cenv env body else - CheckExprNoByrefs cenv env tailCall body + CheckExprNoByrefs cenv env (TailCall.YesFromExpr cenv.g body) body // TailCall.Yes for CPS // This path is for expression bindings that are not actually lambdas | _ -> @@ -682,14 +657,14 @@ and CheckLambdas else CheckExprNoByrefs cenv env tailCall expr -and CheckExprs cenv env exprs ctxts (tailCalls: TailCall list) : unit = +and CheckExprs cenv env 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 env exp (argArity i) tailCalls[i]) + |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i) tailCall) |> ignore and CheckExprsNoByRefLike cenv env exprs : unit = diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index 1b9ef8274a4..db3e41ed307 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -552,22 +552,13 @@ namespace N | TMDefOpens _ -> () | TMDefs defs -> for def in defs do - yield! allValsAndExprsOfModDef def // ToDo: okay to warn here? + yield! allValsAndExprsOfModDef def // ToDo: okay to not warn here? } """ |> FSharp |> withLangVersionPreview |> compile - |> shouldFail - |> withResults [ - { Error = Warning 3569 - Range = { StartLine = 34 - StartColumn = 32 - EndLine = 34 - EndColumn = 59 } - Message = - "The member or function 'allValsAndExprsOfModDef' has the 'TailCall' attribute, but is not being used in a tail recursive way." } - ] + |> shouldSucceed [] let ``Warn for calls in for and iter`` () = @@ -968,3 +959,78 @@ namespace N |> 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 From c1d89368cb82f0ef7288e25f4df888c0c19b5053 Mon Sep 17 00:00:00 2001 From: dawe Date: Sun, 9 Jul 2023 11:00:15 +0200 Subject: [PATCH 64/77] one env ought to be enough for everyone --- src/Compiler/Checking/TailCallChecks.fs | 351 ++++++++++++------------ 1 file changed, 169 insertions(+), 182 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 6d3d83bb0d5..874c3574135 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -18,18 +18,6 @@ open FSharp.Compiler.TypeRelations let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_TailCallChecks" 50 -//-------------------------------------------------------------------------- -// check environment -//-------------------------------------------------------------------------- - -type env = - { - /// Values in module that have been marked [] - mustTailCall: Zset - } - - override _.ToString() = "" - let (|ValUseAtApp|_|) e = match e with | InnerExprPat (Expr.App(funcExpr = InnerExprPat (Expr.Val (valRef = vref; flags = valUseFlags))) | Expr.Val (valRef = vref @@ -84,6 +72,9 @@ type cenv = amap: Import.ImportMap reportErrors: bool + + /// Values in module that have been marked [] + mustTailCall: Zset } override x.ToString() = "" @@ -153,11 +144,11 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = | _ -> [] /// Check an expression, where the expression is in a position where byrefs can be generated -let rec CheckExprNoByrefs cenv env (tailCall: TailCall) expr = - CheckExpr cenv env expr PermitByRefExpr.No tailCall +let rec CheckExprNoByrefs cenv (tailCall: TailCall) expr = + CheckExpr cenv expr PermitByRefExpr.No tailCall /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (tailCall: TailCall) = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr (tailCall: TailCall) = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -169,7 +160,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (t if cenv.reportErrors then if cenv.g.langVersion.SupportsFeature LanguageFeature.WarningWhenTailRecAttributeButNonTailRecUsage then match f with - | ValUseAtApp (vref, valUseFlags) when env.mustTailCall.Contains vref.Deref -> + | ValUseAtApp (vref, valUseFlags) when cenv.mustTailCall.Contains vref.Deref -> let canTailCall = match tailCall with @@ -226,11 +217,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) (env: env) expr (t | _ -> () /// Check call arguments, including the return argument. -and CheckCall cenv env _m _returnTy args ctxts _ctxt = - CheckExprs cenv env args ctxts TailCall.No +and CheckCall cenv _m _returnTy args ctxts _ctxt = CheckExprs cenv args ctxts TailCall.No /// Check call arguments, including the return argument. The receiver argument is handled differently. -and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = +and CheckCallWithReceiver cenv _m _returnTy args ctxts _ctxt = match args with | [] -> failwith "CheckCallWithReceiver: Argument list is empty." | receiverArg :: args -> @@ -240,15 +230,15 @@ and CheckCallWithReceiver cenv env _m _returnTy args ctxts _ctxt = | [] -> PermitByRefExpr.No, [] | ctxt :: ctxts -> ctxt, ctxts - CheckExpr cenv env receiverArg receiverContext TailCall.No - CheckExprs cenv env args ctxts (TailCall.Yes TailCallReturnType.NonVoid) + CheckExpr cenv receiverArg receiverContext TailCall.No + CheckExprs cenv args ctxts (TailCall.Yes TailCallReturnType.NonVoid) -and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = +and CheckExprLinear (cenv: cenv) expr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = match expr with | Expr.Sequential (e1, e2, NormalSeq, _) -> - CheckExprNoByrefs cenv env TailCall.No e1 + CheckExprNoByrefs cenv TailCall.No e1 // tailcall - CheckExprLinear cenv env e2 ctxt tailCall + CheckExprLinear cenv e2 ctxt tailCall | Expr.Let (TBind (v, _bindRhs, _) as bind, body, _, _) -> let isByRef = isByrefTy cenv.g v.Type @@ -259,29 +249,29 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (tailCa else PermitByRefExpr.Yes - CheckBinding cenv env false bindingContext bind + CheckBinding cenv false bindingContext bind // tailcall - CheckExprLinear cenv env body ctxt tailCall + CheckExprLinear cenv body ctxt tailCall | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> - argsHead |> List.iter (CheckExprNoByrefs cenv env tailCall) + argsHead |> List.iter (CheckExprNoByrefs cenv tailCall) // tailcall - CheckExprLinear cenv env argLast PermitByRefExpr.No tailCall + CheckExprLinear cenv argLast PermitByRefExpr.No tailCall | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, _m, _ty) -> - CheckDecisionTree cenv env dtree - CheckDecisionTreeTarget cenv env tailCall ctxt tg1 + CheckDecisionTree cenv dtree + CheckDecisionTreeTarget cenv tailCall ctxt tg1 // tailcall - CheckExprLinear cenv env e2 ctxt tailCall + CheckExprLinear cenv e2 ctxt tailCall - | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt tailCall + | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv innerExpr ctxt tailCall | _ -> // not a linear expression - CheckExpr cenv env expr ctxt (TailCall.YesFromExpr cenv.g expr) + CheckExpr cenv expr ctxt (TailCall.YesFromExpr cenv.g expr) /// Check an expression, given information about the position of the expression -and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = +and CheckExpr (cenv: cenv) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) : unit = // Guard the stack for deeply nested expressions cenv.stackGuard.Guard @@ -292,7 +282,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv env origExpr tailCall + CheckForOverAppliedExceptionRaisingPrimitive cenv origExpr tailCall let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr @@ -301,20 +291,20 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall | LinearMatchExpr _ | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) - | Expr.DebugPoint _ -> CheckExprLinear cenv env expr ctxt tailCall + | Expr.DebugPoint _ -> CheckExprLinear cenv expr ctxt tailCall | Expr.Sequential (e1, e2, ThenDoSeq, _) -> - CheckExprNoByrefs cenv env TailCall.No e1 - CheckExprNoByrefs cenv env TailCall.No e2 + CheckExprNoByrefs cenv TailCall.No e1 + CheckExprNoByrefs cenv TailCall.No e2 | Expr.Const _ | Expr.Val _ | Expr.Quote _ -> () - | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv env expr info + | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv expr info | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) + CheckObjectExpr cenv (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods | Expr.App (InnerExprPat (ExprValWithPossibleTypeInst (v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) when @@ -324,7 +314,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall && baseVal.IsBaseVal) -> - CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) + CheckFSharpBaseCall cenv expr (v, f, _fty, tyargs, baseVal, rest, m) // Allow base calls to IL methods | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), @@ -332,9 +322,9 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall Expr.Val (baseVal, _, _) :: rest, m) when not isVirtual && baseVal.IsBaseVal -> - CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) + CheckILBaseCall cenv (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) - | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv env (op, tyargs, args, m) ctxt expr + | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv (op, tyargs, args, m) ctxt expr // Allow 'typeof' calls as a special case, the only accepted use of System.Void! | TypeOfExpr g ty when isVoidTy g ty -> () @@ -343,25 +333,25 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) (tailCall | TypeDefOfExpr g ty when isVoidTy g ty -> () // Check an application - | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt tailCall + | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv expr (f, tyargs, argsl, m) ctxt tailCall - | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv env expr (argvs, m, bodyTy) tailCall + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv expr (argvs, m, bodyTy) tailCall - | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) tailCall + | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv expr (tps, m, bodyTy) tailCall - | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv env tailCall e1 + | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv tailCall e1 - | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) tailCall + | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv ctxt (dtree, targets, m, ty) tailCall - | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv env (binds, bodyExpr) tailCall + | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv (binds, bodyExpr) tailCall - | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) + | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv (constraints, e2, e3, m) | Expr.WitnessArg _ -> () | Expr.Link _ -> failwith "Unexpected reclink" -and CheckStructStateMachineExpr cenv env _expr info = +and CheckStructStateMachineExpr cenv _expr info = let (_dataTy, (_moveNextThisVar, moveNextExpr), @@ -369,31 +359,31 @@ and CheckStructStateMachineExpr cenv env _expr info = (_afterCodeThisVar, afterCodeBody)) = info - CheckExprNoByrefs cenv env TailCall.No moveNextExpr - CheckExprNoByrefs cenv env TailCall.No setStateMachineBody - CheckExprNoByrefs cenv env TailCall.No afterCodeBody + CheckExprNoByrefs cenv TailCall.No moveNextExpr + CheckExprNoByrefs cenv TailCall.No setStateMachineBody + CheckExprNoByrefs cenv TailCall.No afterCodeBody -and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, _m) = - CheckExprNoByrefs cenv env TailCall.No superInitCall - CheckMethods cenv env basev (ty, overrides) - CheckInterfaceImpls cenv env basev iimpls +and CheckObjectExpr cenv (ty, basev, superInitCall, overrides, iimpls, _m) = + CheckExprNoByrefs cenv TailCall.No superInitCall + CheckMethods cenv basev (ty, overrides) + CheckInterfaceImpls cenv basev iimpls -and CheckFSharpBaseCall cenv env _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) : unit = +and CheckFSharpBaseCall cenv _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) : unit = let memberInfo = Option.get v.MemberInfo if memberInfo.MemberFlags.IsDispatchSlot then () else - CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) TailCall.No + CheckExprs cenv rest (mkArgsForAppliedExpr true rest f) TailCall.No -and CheckILBaseCall cenv env (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = - CheckExprsPermitByRefLike cenv env rest +and CheckILBaseCall cenv (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = + CheckExprsPermitByRefLike cenv rest -and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCall) : unit = +and CheckApplication cenv expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCall) : unit = let g = cenv.g let returnTy = tyOfExpr g expr - CheckExprNoByrefs cenv env tailCall f + CheckExprNoByrefs cenv tailCall f let hasReceiver = match f with @@ -403,77 +393,76 @@ and CheckApplication cenv env expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCa let ctxts = mkArgsForAppliedExpr false argsl f if hasReceiver then - CheckCallWithReceiver cenv env m returnTy argsl ctxts ctxt + CheckCallWithReceiver cenv m returnTy argsl ctxts ctxt else - CheckCall cenv env m returnTy argsl ctxts ctxt + CheckCall cenv m returnTy argsl ctxts ctxt -and CheckLambda cenv env expr (argvs, m, bodyTy) (tailCall: TailCall) = +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 env false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) (tailCall: TailCall) = +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 env false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes + CheckLambdas false None cenv false valReprInfo tailCall.AtExprLambda false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, _m, _ty) tailCall = - CheckDecisionTree cenv env dtree - CheckDecisionTreeTargets cenv env targets ctxt tailCall +and CheckMatch cenv ctxt (dtree, targets, _m, _ty) tailCall = + CheckDecisionTree cenv dtree + CheckDecisionTreeTargets cenv targets ctxt tailCall -and CheckLetRec cenv env (binds, bodyExpr) tailCall = - CheckBindings cenv env binds - CheckExprNoByrefs cenv env tailCall bodyExpr +and CheckLetRec cenv (binds, bodyExpr) tailCall = + CheckBindings cenv binds + CheckExprNoByrefs cenv tailCall bodyExpr -and CheckStaticOptimization cenv env (_constraints, e2, e3, _m) = - CheckExprNoByrefs cenv env TailCall.No e2 - CheckExprNoByrefs cenv env TailCall.No e3 +and CheckStaticOptimization cenv (_constraints, e2, e3, _m) = + CheckExprNoByrefs cenv TailCall.No e2 + CheckExprNoByrefs cenv TailCall.No e3 -and CheckMethods cenv env baseValOpt (ty, methods) = - methods |> List.iter (CheckMethod cenv env baseValOpt ty) +and CheckMethods cenv baseValOpt (ty, methods) = + methods |> List.iter (CheckMethod cenv baseValOpt ty) -and CheckMethod cenv env _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = +and CheckMethod cenv _baseValOpt _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 env body PermitByRefExpr.YesReturnableNonLocal tailCall + CheckExpr cenv body PermitByRefExpr.YesReturnableNonLocal tailCall -and CheckInterfaceImpls cenv env baseValOpt l = - l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) +and CheckInterfaceImpls cenv baseValOpt l = + l |> List.iter (CheckInterfaceImpl cenv baseValOpt) -and CheckInterfaceImpl cenv env baseValOpt overrides = - CheckMethods cenv env baseValOpt overrides +and CheckInterfaceImpl cenv baseValOpt overrides = CheckMethods cenv baseValOpt overrides -and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = +and CheckExprOp cenv (op, tyargs, args, m) ctxt expr : 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 env [ e1; e2 ] + CheckExprsNoByRefLike cenv [ e1; e2 ] | TOp.TryFinally _, [ _ ], [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], e2, _, _) ] -> - CheckExpr cenv env 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 env TailCall.No 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 env [ e1; e2; e3 ] + CheckExprsNoByRefLike cenv [ e1; e2; e3 ] | TOp.TryWith _, [ _ ], [ Expr.Lambda (_, _, _, [ _ ], e1, _, _); Expr.Lambda (_, _, _, [ _ ], _e2, _, _); Expr.Lambda (_, _, _, [ _ ], e3, _, _) ] -> - CheckExpr cenv env 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 + 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 env 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 + 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), _, _ -> @@ -488,24 +477,24 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = match retTypes with | [ ty ] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> if hasReceiver then - CheckCallWithReceiver cenv env m returnTy args argContexts ctxt + CheckCallWithReceiver cenv m returnTy args argContexts ctxt else - CheckCall cenv env m returnTy args argContexts ctxt + CheckCall cenv m returnTy args argContexts ctxt | _ -> if hasReceiver then - CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes + CheckCallWithReceiver cenv m returnTy args argContexts PermitByRefExpr.Yes else - CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes + CheckCall cenv m returnTy args argContexts PermitByRefExpr.Yes | 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 env args - | _ -> CheckExprsNoByRefLike cenv env args + CheckExprsPermitByRefLike cenv args + | _ -> CheckExprsNoByRefLike cenv args - | TOp.LValueOp (LAddrOf _, _vref), _, _ -> CheckExprsNoByRefLike cenv env args + | TOp.LValueOp (LAddrOf _, _vref), _, _ -> CheckExprsNoByRefLike cenv args | TOp.LValueOp (LByrefSet, _vref), _, [ _arg ] -> () @@ -514,9 +503,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = | TOp.LValueOp (LSet, _vref), _, [ _arg ] -> () | TOp.AnonRecdGet _, _, [ arg1 ] - | TOp.TupleFieldGet _, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv env [ arg1 ] + | TOp.TupleFieldGet _, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv [ arg1 ] - | TOp.ValFieldGet _rf, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv env [ arg1 ] + | TOp.ValFieldGet _rf, _, [ arg1 ] -> CheckExprsPermitByRefLike cenv [ arg1 ] | TOp.ValFieldSet _rf, _, [ _arg1; _arg2 ] -> () @@ -524,9 +513,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = let tailCall = TailCall.YesFromExpr cenv.g x if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then - CheckExpr cenv env x ctxt tailCall + CheckExpr cenv x ctxt tailCall else - CheckExprNoByrefs cenv env tailCall x + CheckExprNoByrefs cenv tailCall x | TOp.Reraise, [ _ty1 ], [] -> () @@ -536,70 +525,68 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr : unit = // 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 env obj ctxt TailCall.No + CheckExpr cenv obj ctxt TailCall.No - | TOp.UnionCaseFieldGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv env arg1 + | TOp.UnionCaseFieldGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv arg1 - | TOp.UnionCaseTagGet _, _, [ arg1 ] -> CheckExprPermitByRefLike cenv env arg1 // allow byref - it may be address-of-struct + | 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 env obj ctxt TailCall.No + 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 env TailCall.No rhs + | [ _; 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 env args + CheckExprsPermitByRefLike cenv args // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec) ], _ -> // permit byref for lhs lvalue - CheckExprsPermitByRefLike cenv env args + 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 env args + 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 env obj ctxt TailCall.No + CheckExpr cenv obj ctxt TailCall.No | [ I_ldelema (_, _isNativePtr, _, _) ], lhsArray :: indices -> // permit byref for lhs lvalue - CheckExprPermitByRefLike cenv env lhsArray - CheckExprsNoByRefLike cenv env indices + CheckExprPermitByRefLike cenv lhsArray + CheckExprsNoByRefLike cenv indices | [ AI_conv _ ], _ -> // permit byref for args to conv - CheckExprsPermitByRefLike cenv env args + CheckExprsPermitByRefLike cenv args - | _ -> CheckExprsNoByRefLike cenv env args + | _ -> CheckExprsNoByRefLike cenv args | TOp.TraitCall _, _, _ -> - // CheckTypeInstNoByrefs cenv env m tyargs // allow args to be byref here - CheckExprsPermitByRefLike cenv env args + CheckExprsPermitByRefLike cenv args - | TOp.Recd _, _, _ -> CheckExprsPermitByRefLike cenv env args + | TOp.Recd _, _, _ -> CheckExprsPermitByRefLike cenv args - | _ -> CheckExprsNoByRefLike cenv env args + | _ -> CheckExprsNoByRefLike cenv args and CheckLambdas isTop (memberVal: Val option) cenv - env inlined valReprInfo (tailCall: TailCall) @@ -615,7 +602,7 @@ and CheckLambdas // 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 env inlined valReprInfo tailCall alwaysCheckNoReraise e1 m ety ctxt + | Expr.TyChoose (_tps, e1, m) -> CheckLambdas isTop memberVal cenv inlined valReprInfo tailCall alwaysCheckNoReraise e1 m ety ctxt | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> @@ -643,9 +630,9 @@ and CheckLambdas // 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 env body + CheckExprPermitReturnableByRef cenv body else - CheckExprNoByrefs cenv env (TailCall.YesFromExpr cenv.g body) body // TailCall.Yes for CPS + CheckExprNoByrefs cenv (TailCall.YesFromExpr cenv.g body) body // TailCall.Yes for CPS // This path is for expression bindings that are not actually lambdas | _ -> @@ -653,65 +640,64 @@ and CheckLambdas 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 tailCall + CheckExpr cenv expr ctxt tailCall else - CheckExprNoByrefs cenv env tailCall expr + CheckExprNoByrefs cenv tailCall expr -and CheckExprs cenv env exprs ctxts (tailCall: TailCall) : unit = +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 env exp (argArity i) tailCall) + |> List.mapi (fun i exp -> CheckExpr cenv exp (argArity i) tailCall) |> ignore -and CheckExprsNoByRefLike cenv env exprs : unit = +and CheckExprsNoByRefLike cenv exprs : unit = for expr in exprs do - CheckExprNoByrefs cenv env TailCall.No expr + CheckExprNoByrefs cenv TailCall.No expr -and CheckExprsPermitByRefLike cenv env exprs : unit = - exprs |> List.map (CheckExprPermitByRefLike cenv env) |> ignore +and CheckExprsPermitByRefLike cenv exprs : unit = + exprs |> List.map (CheckExprPermitByRefLike cenv) |> ignore -and CheckExprPermitByRefLike cenv env expr : unit = - CheckExpr cenv env expr PermitByRefExpr.Yes TailCall.No +and CheckExprPermitByRefLike cenv expr : unit = + CheckExpr cenv expr PermitByRefExpr.Yes TailCall.No -and CheckExprPermitReturnableByRef cenv env expr : unit = - CheckExpr cenv env expr PermitByRefExpr.YesReturnable TailCall.No +and CheckExprPermitReturnableByRef cenv expr : unit = + CheckExpr cenv expr PermitByRefExpr.YesReturnable TailCall.No -and CheckDecisionTreeTargets cenv env targets ctxt (tailCall: TailCall) = +and CheckDecisionTreeTargets cenv targets ctxt (tailCall: TailCall) = targets - |> Array.map (CheckDecisionTreeTarget cenv env tailCall ctxt) + |> Array.map (CheckDecisionTreeTarget cenv tailCall ctxt) |> List.ofArray |> ignore -and CheckDecisionTreeTarget cenv env (tailCall: TailCall) ctxt (TTarget (_vs, targetExpr, _)) : unit = - CheckExpr cenv env targetExpr ctxt tailCall +and CheckDecisionTreeTarget cenv (tailCall: TailCall) ctxt (TTarget (_vs, targetExpr, _)) : unit = CheckExpr cenv targetExpr ctxt tailCall -and CheckDecisionTree cenv env dtree = +and CheckDecisionTree cenv dtree = match dtree with - | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv env resultExprs + | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv resultExprs | TDBind (bind, rest) -> - CheckBinding cenv env false PermitByRefExpr.Yes bind - CheckDecisionTree cenv env rest - | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) + CheckBinding cenv false PermitByRefExpr.Yes bind + CheckDecisionTree cenv rest + | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt, m) -and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = - CheckExprPermitByRefLike cenv env inpExpr // can be byref for struct union switch +and CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt, m) = + CheckExprPermitByRefLike cenv inpExpr // can be byref for struct union switch for TCase (discrim, dtree) in cases do - CheckDecisionTreeTest cenv env m discrim - CheckDecisionTree cenv env dtree + CheckDecisionTreeTest cenv m discrim + CheckDecisionTree cenv dtree - dflt |> Option.iter (CheckDecisionTree cenv env) + dflt |> Option.iter (CheckDecisionTree cenv) -and CheckDecisionTreeTest cenv env _m discrim = +and CheckDecisionTreeTest cenv _m discrim = match discrim with - | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv env TailCall.No exp + | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv TailCall.No exp | _ -> () -and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind (v, bindRhs, _) as bind) : unit = +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 @@ -721,14 +707,14 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind (v, bindRhs, _) as bi | Some info -> info | _ -> ValReprInfo.emptyValData - CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo tailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt + CheckLambdas isTop (Some v) cenv v.MustInline valReprInfo tailCall alwaysCheckNoReraise bindRhs v.Range v.Type ctxt -and CheckBindings cenv env binds = +and CheckBindings cenv binds = for bind in binds do - CheckBinding cenv env false PermitByRefExpr.Yes bind + CheckBinding cenv false PermitByRefExpr.Yes bind // Top binds introduce expression, check they are reraise free. -let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = +let CheckModuleBinding cenv (isRec: bool) (TBind (_v, _e, _) 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 @@ -739,7 +725,7 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = let rec checkTailCall (insideSubBinding: bool) expr = match expr with | Expr.Val (valRef = valRef; range = m) -> - if isRec && insideSubBinding && env.mustTailCall.Contains valRef.Deref then + 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 @@ -765,20 +751,20 @@ let CheckModuleBinding cenv env (isRec: bool) (TBind (_v, _e, _) as bind) = checkTailCall false bodyExpr | _ -> () - CheckBinding cenv env true PermitByRefExpr.Yes bind + CheckBinding cenv true PermitByRefExpr.Yes bind //-------------------------------------------------------------------------- // check modules //-------------------------------------------------------------------------- -let rec CheckDefnsInModule cenv env mdefs = +let rec CheckDefnsInModule cenv mdefs = for mdef in mdefs do - CheckDefnInModule cenv env mdef + CheckDefnInModule cenv mdef -and CheckDefnInModule cenv env mdef = +and CheckDefnInModule cenv mdef = match mdef with | TMDefRec (isRec, _opens, _tycons, mspecs, _m) -> - let env = + let cenv = if isRec then let vals = allValsOfModDef mdef @@ -790,15 +776,17 @@ and CheckDefnInModule cenv env mdef = newSet else mustTailCall) - env.mustTailCall + cenv.mustTailCall vals - { env with mustTailCall = mustTailCall } + { cenv with + mustTailCall = mustTailCall + } else - env + cenv - List.iter (CheckModuleSpec cenv env isRec) mspecs - | TMDefLet (bind, _m) -> CheckModuleBinding cenv env false bind + List.iter (CheckModuleSpec cenv isRec) mspecs + | TMDefLet (bind, _m) -> CheckModuleBinding cenv false bind | TMDefOpens _ -> () | TMDefDo (e, _m) -> let tailCall = @@ -809,22 +797,22 @@ and CheckDefnInModule cenv env mdef = | _ -> TailCall.No | _ -> TailCall.No - CheckExprNoByrefs cenv env tailCall e - | TMDefs defs -> CheckDefnsInModule cenv env defs + CheckExprNoByrefs cenv tailCall e + | TMDefs defs -> CheckDefnsInModule cenv defs -and CheckModuleSpec cenv env isRec mbind = +and CheckModuleSpec cenv isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - let env = - if env.mustTailCall.Contains bind.Var then - env + let cenv = + if cenv.mustTailCall.Contains bind.Var then + cenv else - { env with + { cenv with mustTailCall = Zset.empty valOrder } - CheckModuleBinding cenv env isRec bind - | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv env rhs + CheckModuleBinding cenv isRec bind + | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv rhs let CheckImplFile (g, amap, reportErrors, implFileContents) = let cenv = @@ -833,8 +821,7 @@ let CheckImplFile (g, amap, reportErrors, implFileContents) = reportErrors = reportErrors stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") amap = amap + mustTailCall = Zset.empty valOrder } - let env = { mustTailCall = Zset.empty valOrder } - - CheckDefnInModule cenv env implFileContents + CheckDefnInModule cenv implFileContents From ab401a459a377e757facf1b7645aa5c5eef7f89b Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 10 Jul 2023 23:47:01 +0200 Subject: [PATCH 65/77] report time for "TailCall Checks" --- src/Compiler/Driver/fsc.fs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index d9422421726..a6cd7733b98 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -882,6 +882,8 @@ let main3 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) From 0650a8d19cb59dccd1c2f08ced94abeb83204fb2 Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 10 Jul 2023 23:49:38 +0200 Subject: [PATCH 66/77] clean up unused function args --- src/Compiler/Checking/TailCallChecks.fs | 90 +++++++++++-------------- 1 file changed, 41 insertions(+), 49 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 874c3574135..bbdaf89eeaf 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -217,10 +217,10 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr (tailCall: Ta | _ -> () /// Check call arguments, including the return argument. -and CheckCall cenv _m _returnTy args ctxts _ctxt = CheckExprs cenv args ctxts TailCall.No +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 _m _returnTy args ctxts _ctxt = +and CheckCallWithReceiver cenv args ctxts = match args with | [] -> failwith "CheckCallWithReceiver: Argument list is empty." | receiverArg :: args -> @@ -301,30 +301,28 @@ and CheckExpr (cenv: cenv) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) | Expr.Val _ | Expr.Quote _ -> () - | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv expr info + | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv info - | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> - CheckObjectExpr cenv (ty, basev, superInitCall, overrides, iimpls, m) + | 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 + | 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 expr (v, f, _fty, tyargs, baseVal, rest, m) + CheckFSharpBaseCall cenv (v, f, rest) // Allow base calls to IL methods - | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), - tyargs, + | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, _ilMethRef, _enclTypeInst, _methInst, _retTypes), + _tyargs, Expr.Val (baseVal, _, _) :: rest, - m) when not isVirtual && baseVal.IsBaseVal -> + _m) when not isVirtual && baseVal.IsBaseVal -> - CheckILBaseCall cenv (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) + CheckILBaseCall cenv rest - | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv (op, tyargs, args, m) ctxt expr + | 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 -> () @@ -333,7 +331,7 @@ and CheckExpr (cenv: cenv) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) | TypeDefOfExpr g ty when isVoidTy g ty -> () // Check an application - | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv expr (f, tyargs, argsl, m) ctxt tailCall + | Expr.App (f, _fty, _tyargs, argsl, _m) -> CheckApplication cenv (f, argsl) tailCall | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv expr (argvs, m, bodyTy) tailCall @@ -341,17 +339,17 @@ and CheckExpr (cenv: cenv) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) | Expr.TyChoose (_tps, e1, _) -> CheckExprNoByrefs cenv tailCall e1 - | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv ctxt (dtree, targets, m, ty) tailCall + | 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 (constraints, e2, e3, m) + | Expr.StaticOptimization (_constraints, e2, e3, _m) -> CheckStaticOptimization cenv (e2, e3) | Expr.WitnessArg _ -> () | Expr.Link _ -> failwith "Unexpected reclink" -and CheckStructStateMachineExpr cenv _expr info = +and CheckStructStateMachineExpr cenv info = let (_dataTy, (_moveNextThisVar, moveNextExpr), @@ -363,12 +361,12 @@ and CheckStructStateMachineExpr cenv _expr info = CheckExprNoByrefs cenv TailCall.No setStateMachineBody CheckExprNoByrefs cenv TailCall.No afterCodeBody -and CheckObjectExpr cenv (ty, basev, superInitCall, overrides, iimpls, _m) = +and CheckObjectExpr cenv (ty, superInitCall, overrides, iimpls) = CheckExprNoByrefs cenv TailCall.No superInitCall - CheckMethods cenv basev (ty, overrides) - CheckInterfaceImpls cenv basev iimpls + CheckMethods cenv (ty, overrides) + CheckInterfaceImpls cenv iimpls -and CheckFSharpBaseCall cenv _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) : unit = +and CheckFSharpBaseCall cenv (v, f, rest) : unit = let memberInfo = Option.get v.MemberInfo if memberInfo.MemberFlags.IsDispatchSlot then @@ -376,13 +374,9 @@ and CheckFSharpBaseCall cenv _expr (v, f, _fty, _tyargs, _baseVal, rest, _m) : u else CheckExprs cenv rest (mkArgsForAppliedExpr true rest f) TailCall.No -and CheckILBaseCall cenv (_ilMethRef, _enclTypeInst, _methInst, _retTypes, _tyargs, _baseVal, rest, _m) : unit = - CheckExprsPermitByRefLike cenv rest - -and CheckApplication cenv expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCall) : unit = - let g = cenv.g +and CheckILBaseCall cenv rest : unit = CheckExprsPermitByRefLike cenv rest - let returnTy = tyOfExpr g expr +and CheckApplication cenv (f, argsl) (tailCall: TailCall) : unit = CheckExprNoByrefs cenv tailCall f let hasReceiver = @@ -393,9 +387,9 @@ and CheckApplication cenv expr (f, _tyargs, argsl, m) ctxt (tailCall: TailCall) let ctxts = mkArgsForAppliedExpr false argsl f if hasReceiver then - CheckCallWithReceiver cenv m returnTy argsl ctxts ctxt + CheckCallWithReceiver cenv argsl ctxts else - CheckCall cenv m returnTy argsl ctxts ctxt + CheckCall cenv argsl ctxts and CheckLambda cenv expr (argvs, m, bodyTy) (tailCall: TailCall) = let valReprInfo = @@ -411,7 +405,7 @@ and CheckTyLambda cenv expr (tps, m, bodyTy) (tailCall: TailCall) = 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, _m, _ty) tailCall = +and CheckMatch cenv ctxt (dtree, targets) tailCall = CheckDecisionTree cenv dtree CheckDecisionTreeTargets cenv targets ctxt tailCall @@ -419,14 +413,14 @@ and CheckLetRec cenv (binds, bodyExpr) tailCall = CheckBindings cenv binds CheckExprNoByrefs cenv tailCall bodyExpr -and CheckStaticOptimization cenv (_constraints, e2, e3, _m) = +and CheckStaticOptimization cenv (e2, e3) = CheckExprNoByrefs cenv TailCall.No e2 CheckExprNoByrefs cenv TailCall.No e3 -and CheckMethods cenv baseValOpt (ty, methods) = - methods |> List.iter (CheckMethod cenv baseValOpt ty) +and CheckMethods cenv (ty, methods) = + methods |> List.iter (CheckMethod cenv ty) -and CheckMethod cenv _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = +and CheckMethod cenv _ty (TObjExprMethod (_, _, _tps, _vs, body, _m)) = let tailCall = match stripDebugPoints body with | Expr.App _ as a -> TailCall.YesFromExpr cenv.g a @@ -434,12 +428,12 @@ and CheckMethod cenv _baseValOpt _ty (TObjExprMethod (_, _, _tps, _vs, body, _m) CheckExpr cenv body PermitByRefExpr.YesReturnableNonLocal tailCall -and CheckInterfaceImpls cenv baseValOpt l = - l |> List.iter (CheckInterfaceImpl cenv baseValOpt) +and CheckInterfaceImpls cenv l = + l |> List.iter (CheckInterfaceImpl cenv) -and CheckInterfaceImpl cenv baseValOpt overrides = CheckMethods cenv baseValOpt overrides +and CheckInterfaceImpl cenv overrides = CheckMethods cenv overrides -and CheckExprOp cenv (op, tyargs, args, m) ctxt expr : unit = +and CheckExprOp cenv (op, tyargs, args, m) ctxt : unit = let g = cenv.g // Special cases @@ -470,21 +464,19 @@ and CheckExprOp cenv (op, tyargs, args, m) ctxt expr : unit = (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) && not args.IsEmpty - let returnTy = tyOfExpr g expr - 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 m returnTy args argContexts ctxt + CheckCallWithReceiver cenv args argContexts else - CheckCall cenv m returnTy args argContexts ctxt + CheckCall cenv args argContexts | _ -> if hasReceiver then - CheckCallWithReceiver cenv m returnTy args argContexts PermitByRefExpr.Yes + CheckCallWithReceiver cenv args argContexts else - CheckCall cenv m returnTy args argContexts PermitByRefExpr.Yes + CheckCall cenv args argContexts | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> match ctxt with @@ -681,18 +673,18 @@ and CheckDecisionTree cenv dtree = | TDBind (bind, rest) -> CheckBinding cenv false PermitByRefExpr.Yes bind CheckDecisionTree cenv rest - | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt, m) + | TDSwitch (inpExpr, cases, dflt, _m) -> CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt) -and CheckDecisionTreeSwitch cenv (inpExpr, cases, dflt, m) = +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 m discrim + CheckDecisionTreeTest cenv discrim CheckDecisionTree cenv dtree dflt |> Option.iter (CheckDecisionTree cenv) -and CheckDecisionTreeTest cenv _m discrim = +and CheckDecisionTreeTest cenv discrim = match discrim with | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _, _) -> CheckExprNoByrefs cenv TailCall.No exp | _ -> () @@ -714,7 +706,7 @@ and CheckBindings cenv binds = CheckBinding cenv false PermitByRefExpr.Yes bind // Top binds introduce expression, check they are reraise free. -let CheckModuleBinding cenv (isRec: bool) (TBind (_v, _e, _) as 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 From 5d4cdc284d580fdb48bdd3371056f4d8367b73f0 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 00:05:50 +0200 Subject: [PATCH 67/77] improve some comments and names --- src/Compiler/Checking/TailCallChecks.fs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index bbdaf89eeaf..e7d05559518 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -147,13 +147,12 @@ let rec mkArgsForAppliedExpr isBaseCall argsl x = let rec CheckExprNoByrefs cenv (tailCall: TailCall) expr = CheckExpr cenv expr PermitByRefExpr.No tailCall -/// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr (tailCall: 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 - // Some things are more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs match expr with | Expr.App (f, _fty, _tyargs, argsl, m) -> @@ -282,7 +281,7 @@ and CheckExpr (cenv: cenv) origExpr (ctxt: PermitByRefExpr) (tailCall: TailCall) let origExpr = stripExpr origExpr // CheckForOverAppliedExceptionRaisingPrimitive is more easily checked prior to NormalizeAndAdjustPossibleSubsumptionExprs - CheckForOverAppliedExceptionRaisingPrimitive cenv origExpr tailCall + CheckForNonTailRecCall cenv origExpr tailCall let expr = NormalizeAndAdjustPossibleSubsumptionExprs g origExpr let expr = stripExpr expr @@ -705,7 +704,6 @@ and CheckBindings cenv binds = for bind in binds do CheckBinding cenv false PermitByRefExpr.Yes bind -// Top binds introduce expression, check they are reraise free. 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 From 3eef971ce841b72b646c9f3c24f6b01e06300b64 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 12:26:12 +0200 Subject: [PATCH 68/77] add API docs for TailCall attribute --- src/FSharp.Core/prim-types.fsi | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/FSharp.Core/prim-types.fsi b/src/FSharp.Core/prim-types.fsi index bb29b51ed55..57af6608d3e 100644 --- a/src/FSharp.Core/prim-types.fsi +++ b/src/FSharp.Core/prim-types.fsi @@ -950,6 +950,21 @@ namespace Microsoft.FSharp.Core /// NoCompilerInliningAttribute new: unit -> NoCompilerInliningAttribute + /// Indicates a function that should be called in a tail recursive way inside it's 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 = From aaec214564685800add0edb8b540f889a5818fc0 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 13:00:41 +0200 Subject: [PATCH 69/77] add xml comment for TailCallChecks.CheckImplFile --- src/Compiler/Checking/TailCallChecks.fsi | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Compiler/Checking/TailCallChecks.fsi b/src/Compiler/Checking/TailCallChecks.fsi index 126560420ad..34af398d6f6 100644 --- a/src/Compiler/Checking/TailCallChecks.fsi +++ b/src/Compiler/Checking/TailCallChecks.fsi @@ -4,5 +4,6 @@ open FSharp.Compiler open FSharp.Compiler.TcGlobals open FSharp.Compiler.TypedTree +/// Perform the TailCall analysis on the optimized TAST for a file. val CheckImplFile: g: TcGlobals * amap: Import.ImportMap * reportErrors: bool * implFileContents: ModuleOrNamespaceContents -> unit From d68c8a4e46d0805eece0afb9234e82a61fc74d36 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 13:39:56 +0200 Subject: [PATCH 70/77] Update src/FSharp.Core/prim-types.fsi Co-authored-by: Petr --- src/FSharp.Core/prim-types.fsi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/FSharp.Core/prim-types.fsi b/src/FSharp.Core/prim-types.fsi index 57af6608d3e..aa3249d8690 100644 --- a/src/FSharp.Core/prim-types.fsi +++ b/src/FSharp.Core/prim-types.fsi @@ -950,7 +950,7 @@ namespace Microsoft.FSharp.Core /// NoCompilerInliningAttribute new: unit -> NoCompilerInliningAttribute - /// Indicates a function that should be called in a tail recursive way inside it's recursive scope. + /// 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 From ff6dff3c770228afd483e97ff2c6d094d3574c0a Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 15:08:21 +0200 Subject: [PATCH 71/77] remove some superfluous stuff from CheckLambdas --- src/Compiler/Checking/TailCallChecks.fs | 21 +-------------------- 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index e7d05559518..c25b1e13b9c 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -588,7 +588,6 @@ and CheckLambdas ctxt : unit = let g = cenv.g - let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) // The valReprInfo here says we are _guaranteeing_ to compile a function value // as a .NET method with precisely the corresponding argument counts. @@ -597,27 +596,9 @@ and CheckLambdas | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> - let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = + let _tps, _ctorThisValOpt, _baseValOpt, _vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) - let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt - let restArgs = List.concat vsl - - match memInfo with - | None -> () - | Some mi -> - // ctorThis and baseVal values are always considered used - for v in thisAndBase do - v.SetHasBeenReferenced() - // instance method 'this' is always considered used - match mi.MemberFlags.IsInstance, restArgs with - | true, firstArg :: _ -> firstArg.SetHasBeenReferenced() - | _ -> () - // any byRef arguments are considered used, as they may be 'out's - for arg in restArgs do - if isByrefTy g arg.Type then - arg.SetHasBeenReferenced() - // 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 From b696021544266ec4198da0e5f6ec2a1c27962eeb Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 15:12:53 +0200 Subject: [PATCH 72/77] More detailed comment --- src/Compiler/Checking/TailCallChecks.fsi | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Compiler/Checking/TailCallChecks.fsi b/src/Compiler/Checking/TailCallChecks.fsi index 34af398d6f6..2fa3b163755 100644 --- a/src/Compiler/Checking/TailCallChecks.fsi +++ b/src/Compiler/Checking/TailCallChecks.fsi @@ -5,5 +5,9 @@ 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 From 28a9b84de5330ba17f0adc16ce13b721ce8a4472 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 15:41:39 +0200 Subject: [PATCH 73/77] extend test with an inner class type --- .../ErrorMessages/TailCallAttribute.fs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index db3e41ed307..e7a0b246095 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -173,6 +173,10 @@ namespace N type C () = [] member this.M1() = this.M1() + 1 + + type InnerC () = + [] + member this.InnerCMeth x = this.InnerCMeth x + 23 """ |> FSharp |> withLangVersionPreview @@ -186,6 +190,13 @@ namespace N EndColumn = 41 } Message = "The member or function 'M1' has the 'TailCall' 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 'TailCall' attribute, but is not being used in a tail recursive way." } ] [] From da6851a4443fa03b116d5176e18daa1fa5d06136 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 11 Jul 2023 15:42:18 +0200 Subject: [PATCH 74/77] optimize --- src/Compiler/Checking/TailCallChecks.fs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index c25b1e13b9c..4f2185220a0 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -774,15 +774,9 @@ and CheckDefnInModule cenv mdef = and CheckModuleSpec cenv isRec mbind = match mbind with | ModuleOrNamespaceBinding.Binding bind -> - let cenv = - if cenv.mustTailCall.Contains bind.Var then - cenv - else - { cenv with - mustTailCall = Zset.empty valOrder - } + if cenv.mustTailCall.Contains bind.Var then + CheckModuleBinding cenv isRec bind - CheckModuleBinding cenv isRec bind | ModuleOrNamespaceBinding.Module (_mspec, rhs) -> CheckDefnInModule cenv rhs let CheckImplFile (g, amap, reportErrors, implFileContents) = From 6d03568cc2a224af4a4ef37b21ba84b4f086814f Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 14 Jul 2023 18:07:14 +0200 Subject: [PATCH 75/77] update xlf --- src/Compiler/xlf/FSComp.txt.cs.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.de.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.es.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.fr.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.it.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.ja.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.ko.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.pl.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.ru.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.tr.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 4 ++-- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 4 ++-- 13 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index c95ba93baf4..90e1cce8b45 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 84660c3b83f..7d27833b09f 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 769b175806e..a8e677179ba 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 3fcf9e4f979..a22f959e7aa 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 54b5d66292b..7d21cdb16a1 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 1d8dbf2c659..ad052e25d22 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index ef858689453..a003c8ae916 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index edc9601a01b..f829eaf8e68 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 03603414217..cc2041d6026 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 8ca7a0b8908..49e6c92d5e8 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index f635562b788..5ea3abcc5ac 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index b3f86482576..e95ce09f131 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index eda95e350e0..994a149ea54 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -103,8 +103,8 @@ - The member or function '{0}' has the '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 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. From 11bef39fe9888ce6925277e697c3b50f5368dc75 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 14 Jul 2023 18:11:57 +0200 Subject: [PATCH 76/77] adjust error messages after xlf update --- .../ErrorMessages/TailCallAttribute.fs | 54 +++++++++---------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs index e7a0b246095..a1e32599137 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/TailCallAttribute.fs @@ -31,7 +31,7 @@ namespace N EndLine = 12 EndColumn = 43 } Message = - "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -60,7 +60,7 @@ namespace N EndLine = 12 EndColumn = 45 } Message = - "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -91,7 +91,7 @@ namespace N EndLine = 13 EndColumn = 49 } Message = - "The member or function 'fact' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'fact' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -160,7 +160,7 @@ namespace N EndLine = 17 EndColumn = 28 } Message = - "The member or function 'bar' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'bar' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -189,14 +189,14 @@ namespace N EndLine = 8 EndColumn = 41 } Message = - "The member or function 'M1' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'InnerCMeth' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -272,7 +272,7 @@ namespace N EndLine = 10 EndColumn = 26 } Message = - "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 @@ -280,9 +280,9 @@ namespace N EndColumn = 26 } Message = #if Debug - "The member or function 'M2' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'M1' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } #endif ] @@ -340,7 +340,7 @@ namespace N EndLine = 9 EndColumn = 34 } Message = - "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -367,7 +367,7 @@ namespace N EndLine = 9 EndColumn = 33 } Message = - "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -436,7 +436,7 @@ namespace N EndLine = 8 EndColumn = 23 } Message = - "The member or function 'f' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'f' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -493,14 +493,14 @@ namespace N EndLine = 8 EndColumn = 43 } Message = - "The member or function 'm2func' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'm2func' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -525,7 +525,7 @@ namespace N EndLine = 7 EndColumn = 44 } Message = - "The member or function 'foo' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'foo' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -636,14 +636,14 @@ namespace N EndLine = 24 EndColumn = 48 } Message = - "The member or function 'CheckDefnInModule' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'CheckModuleSpec' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -690,14 +690,14 @@ namespace N EndLine = 21 EndColumn = 35 } Message = - "The member or function 'instType' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'instType' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -730,14 +730,14 @@ namespace N EndLine = 11 EndColumn = 36 } Message = - "The member or function 'foldBackOpt' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'foldBackOpt' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -785,7 +785,7 @@ namespace N EndLine = 12 EndColumn = 34 } Message = - "The member or function 'addOne' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'addOne' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -812,7 +812,7 @@ namespace N EndLine = 10 EndColumn = 43 } Message = - "The member or function 'addOne' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'addOne' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] @@ -861,28 +861,28 @@ namespace N EndLine = 14 EndColumn = 53 } Message = - "The member or function 'findMax' has the 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "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 'TailCall' attribute, but is not being used in a tail recursive way." } + "The member or function 'findMax' has the 'TailCallAttribute' attribute, but is not being used in a tail recursive way." } ] [] From baa6ca5db5159d0a081dd1092f0e614f3acd9463 Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 14 Jul 2023 18:25:01 +0200 Subject: [PATCH 77/77] revert white space changes that sneaked in during rebase --- src/Compiler/Checking/PostInferenceChecks.fs | 1196 +++++++++--------- 1 file changed, 598 insertions(+), 598 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 145c7e0799c..b9dd8dbcc14 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -32,24 +32,24 @@ open FSharp.Compiler.TypeRelations //-------------------------------------------------------------------------- // NOTES: reraise safety checks //-------------------------------------------------------------------------- - + // "rethrow may only occur with-in the body of a catch handler". // -- Section 4.23. Part III. CLI Instruction Set. ECMA Draft 2002. -// +// // 1. reraise() calls are converted to TOp.Reraise in the type checker. // 2. any remaining reraise val_refs will be first class uses. These are trapped. // 3. The freevars track free TOp.Reraise (they are bound (cleared) at try-catch handlers). // 4. An outermost expression is not contained in a try-catch handler. -// These may not have unbound rethrows. +// These may not have unbound rethrows. // Outermost expressions occur at: // * module bindings. // * attribute arguments. -// * Any more? What about fields of a static class? +// * Any more? What about fields of a static class? // 5. A lambda body (from lambda-expression or method binding) will not occur under a try-catch handler. // These may not have unbound rethrows. // 6. All other constructs are assumed to generate IL code sequences. // For correctness, this claim needs to be justified. -// +// // Informal justification: // If a reraise occurs, then it is minimally contained by either: // a) a try-catch - accepted. @@ -67,15 +67,15 @@ type Resumable = | None /// Indicates we are expecting resumable code (the body of a ResumableCode delegate or /// the body of the MoveNextMethod for a state machine) - /// -- allowed: are we inside the 'then' branch of an 'if __useResumableCode then ...' + /// -- allowed: are we inside the 'then' branch of an 'if __useResumableCode then ...' /// for a ResumableCode delegate. | ResumableExpr of allowed: bool -type env = - { +type env = + { /// The bound type parameter names in scope - boundTyparNames: string list - + boundTyparNames: string list + /// The bound type parameters in scope boundTypars: TyparMap @@ -83,45 +83,45 @@ type env = argVals: ValMap /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature - sigToImplRemapInfo: (Remap * SignatureHidingInfo) list + sigToImplRemapInfo: (Remap * SignatureHidingInfo) list /// Are we in a quotation? - quote : bool + quote : bool /// Are we under []? reflect : bool /// Are we in an extern declaration? - external : bool - + external : bool + /// Current return scope of the expr. - returnScope : int - + returnScope : int + /// Are we in an app expression (Expr.App)? isInAppExpr: bool /// Are we expecting a resumable code block etc resumableCode: Resumable - } + } override _.ToString() = "" -let BindTypar env (tp: Typar) = - { env with +let BindTypar env (tp: Typar) = + { env with boundTyparNames = tp.Name :: env.boundTyparNames - boundTypars = env.boundTypars.Add (tp, ()) } + boundTypars = env.boundTypars.Add (tp, ()) } -let BindTypars g env (tps: Typar list) = +let BindTypars g env (tps: Typar list) = let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps if isNil tps then env else - // Here we mutate to provide better names for generalized type parameters + // Here we mutate to provide better names for generalized type parameters let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps - PrettyTypes.AssignPrettyTyparNames tps nms - List.fold BindTypar env tps + PrettyTypes.AssignPrettyTyparNames tps nms + List.fold BindTypar env tps -/// Set the set of vals which are arguments in the active lambda. We are allowed to return +/// Set the set of vals which are arguments in the active lambda. We are allowed to return /// byref arguments as byref returns. -let BindArgVals env (vs: Val list) = +let BindArgVals env (vs: Val list) = { env with argVals = ValMap.OfList (List.map (fun v -> (v, ())) vs) } /// Limit flags represent a type(s) returned from checking an expression(s) that is interesting to impose rules on. @@ -152,7 +152,7 @@ let NoLimit = { scope = 0; flags = LimitFlags.None } // Combining two limits will result in both limit flags merged. // If none of the limits are limited by a by-ref or a stack referring span-like // the scope will be 0. -let CombineTwoLimits limit1 limit2 = +let CombineTwoLimits limit1 limit2 = let isByRef1 = HasLimitFlag LimitFlags.ByRef limit1 let isByRef2 = HasLimitFlag LimitFlags.ByRef limit2 let isStackSpan1 = HasLimitFlag LimitFlags.StackReferringSpanLike limit1 @@ -160,7 +160,7 @@ let CombineTwoLimits limit1 limit2 = let isLimited1 = isByRef1 || isStackSpan1 let isLimited2 = isByRef2 || isStackSpan2 - // A limit that has a stack referring span-like but not a by-ref, + // A limit that has a stack referring span-like but not a by-ref, // we force the scope to 1. This is to handle call sites // that return a by-ref and have stack referring span-likes as arguments. // This is to ensure we can only prevent out of scope at the method level rather than visibility. @@ -190,27 +190,27 @@ let CombineLimits limits = (NoLimit, limits) ||> List.fold CombineTwoLimits -type cenv = +type cenv = { boundVals: Dictionary // really a hash set limitVals: Dictionary - mutable potentialUnboundUsesOfVals: StampMap + mutable potentialUnboundUsesOfVals: StampMap - mutable anonRecdTypes: StampMap + mutable anonRecdTypes: StampMap stackGuard: StackGuard - g: TcGlobals + g: TcGlobals - amap: Import.ImportMap + amap: Import.ImportMap /// For reading metadata infoReader: InfoReader internalsVisibleToPaths : CompilationPath list - denv: DisplayEnv + denv: DisplayEnv viewCcu : CcuThunk @@ -223,8 +223,8 @@ type cenv = // outputs mutable usesQuotations: bool - mutable entryPointGiven: bool - + mutable entryPointGiven: bool + /// Callback required for quotation generation tcVal: ConstraintSolver.TcValF } @@ -261,7 +261,7 @@ let GetLimitVal cenv env m (v: Val) = elif isByrefTy cenv.g v.Type then let isByRefOfSpanLike = isSpanLikeTy cenv.g m (destByrefTy cenv.g v.Type) - + if isByRefOfSpanLike then if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then { limit with flags = LimitFlags.ByRefOfStackReferringSpanLike } @@ -292,15 +292,15 @@ let GetLimitValByRef cenv env m v = { scope = scope; flags = flags } -let LimitVal cenv (v: Val) limit = +let LimitVal cenv (v: Val) limit = if not v.IgnoresByrefScope then cenv.limitVals[v.Stamp] <- limit -let BindVal cenv env (v: Val) = +let BindVal cenv env (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 @@ -311,14 +311,14 @@ let BindVal cenv env (v: Val) = | ValueSome e -> e.HasSignatureFile v.IsModuleBinding && not v.HasSignatureFile && parentHasSignatureFile () - + if not env.external && not alreadyDone && - cenv.reportErrors && - not v.HasBeenReferenced && + cenv.reportErrors && + not v.HasBeenReferenced && (not v.IsCompiledAsTopLevel || topLevelBindingHiddenBySignatureFile ()) && not (v.DisplayName.StartsWithOrdinal("_")) && - not v.IsCompilerGenerated then + not v.IsCompilerGenerated then if v.IsCtorThisVal then warning (Error(FSComp.SR.chkUnusedThisVariable v.DisplayName, v.Range)) @@ -328,7 +328,7 @@ let BindVal cenv env (v: Val) = let BindVals cenv env vs = List.iter (BindVal cenv env) vs let RecordAnonRecdInfo cenv (anonInfo: AnonRecdTypeInfo) = - if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then + if not (cenv.anonRecdTypes.ContainsKey anonInfo.Stamp) then cenv.anonRecdTypes <- cenv.anonRecdTypes.Add(anonInfo.Stamp, anonInfo) //-------------------------------------------------------------------------- @@ -341,40 +341,40 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi // those attached to _solved_ type variables. This is used by PostTypeCheckSemanticChecks to detect uses of // values as solutions to trait constraints and determine if inference has caused the value to escape its scope. // The only record of these solutions is in the _solved_ constraints of types. - // In an ideal world we would, instead, record the solutions to these constraints as "witness variables" in expressions, - // rather than solely in types. - match ty with + // In an ideal world we would, instead, record the solutions to these constraints as "witness variables" in expressions, + // rather than solely in types. + match ty with | TType_var (tp, _) when tp.Solution.IsSome -> for cx in tp.Constraints do - match cx with - | TyparConstraint.MayResolveMember(TTrait(_, _, _, _, _, soln), _) -> - match visitTraitSolutionOpt, soln.Value with + match cx with + | TyparConstraint.MayResolveMember(TTrait(_, _, _, _, _, soln), _) -> + match visitTraitSolutionOpt, soln.Value with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () | _ -> () | _ -> () - + let ty = if g.compilingFSharpCore then match stripTyparEqns ty with // When compiling FSharp.Core, do not strip type equations at this point if we can't dereference a tycon. | TType_app (tcref, _, _) when not tcref.CanDeref -> ty | _ -> stripTyEqns g ty - else + else stripTyEqns g ty visitTy ty match ty with - | TType_forall (tps, body) -> + | TType_forall (tps, body) -> let env = BindTypars g env tps - CheckTypeDeep cenv f g env isInner body + CheckTypeDeep cenv f g env isInner body tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep cenv f g env)) | TType_measure _ -> () - | TType_app (tcref, tinst, _) -> - match visitTyconRefOpt with - | Some visitTyconRef -> visitTyconRef isInner tcref + | TType_app (tcref, tinst, _) -> + match visitTyconRefOpt with + | Some visitTyconRef -> visitTyconRef isInner tcref | None -> () // If it's a 'byref<'T>', don't check 'T as an inner. This allows byref>. @@ -384,11 +384,11 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi else CheckTypesDeep cenv f g env tinst - match visitAppTyOpt with + match visitAppTyOpt with | Some visitAppTy -> visitAppTy (tcref, tinst) | None -> () - | TType_anon (anonInfo, tys) -> + | TType_anon (anonInfo, tys) -> RecordAnonRecdInfo cenv anonInfo CheckTypesDeep cenv f g env tys @@ -402,91 +402,91 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi CheckTypeDeep cenv f g env true s CheckTypeDeep cenv f g env true t - | TType_var (tp, _) -> - if not tp.IsSolved then - match visitTyparOpt with + | TType_var (tp, _) -> + if not tp.IsSolved then + match visitTyparOpt with | None -> () - | Some visitTyar -> + | Some visitTyar -> visitTyar (env, tp) -and CheckTypesDeep cenv f g env tys = +and CheckTypesDeep cenv f g env tys = for ty in tys do CheckTypeDeep cenv f g env true ty -and CheckTypesDeepNoInner cenv f g env tys = +and CheckTypesDeepNoInner cenv f g env tys = for ty in tys do CheckTypeDeep cenv f g env false ty and CheckTypeConstraintDeep cenv f g env x = - match x with + match x with | TyparConstraint.CoercesTo(ty, _) -> CheckTypeDeep cenv f g env true ty | TyparConstraint.MayResolveMember(traitInfo, _) -> CheckTraitInfoDeep cenv f g env traitInfo | TyparConstraint.DefaultsTo(_, ty, _) -> CheckTypeDeep cenv f g env true ty | TyparConstraint.SimpleChoice(tys, _) -> CheckTypesDeep cenv f g env tys | TyparConstraint.IsEnum(underlyingTy, _) -> CheckTypeDeep cenv f g env true underlyingTy | TyparConstraint.IsDelegate(argTys, retTy, _) -> CheckTypeDeep cenv f g env true argTys; CheckTypeDeep cenv f g env true retTy - | TyparConstraint.SupportsComparison _ - | TyparConstraint.SupportsEquality _ - | TyparConstraint.SupportsNull _ - | TyparConstraint.IsNonNullableStruct _ + | TyparConstraint.SupportsComparison _ + | TyparConstraint.SupportsEquality _ + | TyparConstraint.SupportsNull _ + | TyparConstraint.IsNonNullableStruct _ | TyparConstraint.IsUnmanaged _ - | TyparConstraint.IsReferenceType _ + | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> () -and CheckTraitInfoDeep cenv (_, _, _, visitTraitSolutionOpt, _ as f) g env (TTrait(tys, _, _, argTys, retTy, soln)) = - CheckTypesDeep cenv f g env tys - CheckTypesDeep cenv f g env argTys +and CheckTraitInfoDeep cenv (_, _, _, visitTraitSolutionOpt, _ as f) g env (TTrait(tys, _, _, argTys, retTy, soln)) = + CheckTypesDeep cenv f g env tys + CheckTypesDeep cenv f g env argTys Option.iter (CheckTypeDeep cenv f g env true ) retTy - match visitTraitSolutionOpt, soln.Value with + match visitTraitSolutionOpt, soln.Value with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () /// Check for byref-like types -let CheckForByrefLikeType cenv env m ty check = +let CheckForByrefLikeType cenv env m ty check = CheckTypeDeep cenv (ignore, Some (fun _deep tcref -> if isByrefLikeTyconRef cenv.g m tcref then check()), None, None, None) cenv.g env false ty /// Check for byref types -let CheckForByrefType cenv env ty check = +let CheckForByrefType cenv env ty check = CheckTypeDeep cenv (ignore, Some (fun _deep tcref -> if isByrefTyconRef cenv.g tcref then check()), None, None, None) cenv.g env false ty /// check captures under lambdas /// -/// This is the definition of what can/can't be free in a lambda expression. This is checked at lambdas OR TBind(v, e) nodes OR TObjExprMethod nodes. -/// For TBind(v, e) nodes we may know an 'arity' which gives as a larger set of legitimate syntactic arguments for a lambda. -/// For TObjExprMethod(v, e) nodes we always know the legitimate syntactic arguments. +/// This is the definition of what can/can't be free in a lambda expression. This is checked at lambdas OR TBind(v, e) nodes OR TObjExprMethod nodes. +/// For TBind(v, e) nodes we may know an 'arity' which gives as a larger set of legitimate syntactic arguments for a lambda. +/// For TObjExprMethod(v, e) nodes we always know the legitimate syntactic arguments. let CheckEscapes cenv allowProtected m syntacticArgs body = (* m is a range suited to error reporting *) - if cenv.reportErrors then - let cantBeFree (v: Val) = - // If v is a syntactic argument, then it can be free since it was passed in. - // The following can not be free: - // a) BaseVal can never escape. - // b) Byref typed values can never escape. + if cenv.reportErrors then + let cantBeFree (v: Val) = + // If v is a syntactic argument, then it can be free since it was passed in. + // The following can not be free: + // a) BaseVal can never escape. + // b) Byref typed values can never escape. // Note that: Local mutables can be free, as they will be boxed later. - // These checks must correspond to the tests governing the error messages below. + // These checks must correspond to the tests governing the error messages below. (v.IsBaseVal || isByrefLikeTy cenv.g m v.Type) && not (ListSet.contains valEq v syntacticArgs) let frees = freeInExpr (CollectLocalsWithStackGuard()) body - let fvs = frees.FreeLocals + let fvs = frees.FreeLocals if not allowProtected && frees.UsesMethodLocalConstructs then errorR(Error(FSComp.SR.chkProtectedOrBaseCalled(), m)) - elif Zset.exists cantBeFree fvs then - let v = List.find cantBeFree (Zset.elements fvs) + elif Zset.exists cantBeFree fvs then + let v = List.find cantBeFree (Zset.elements fvs) - // byref error before mutable error (byrefs are mutable...). + // byref error before mutable error (byrefs are mutable...). if (isByrefLikeTy cenv.g m v.Type) then - // Inner functions are not guaranteed to compile to method with a predictable arity (number of arguments). - // As such, partial applications involving byref arguments could lead to closures containing byrefs. - // For safety, such functions are assumed to have no known arity, and so can not accept byrefs. + // Inner functions are not guaranteed to compile to method with a predictable arity (number of arguments). + // As such, partial applications involving byref arguments could lead to closures containing byrefs. + // For safety, such functions are assumed to have no known arity, and so can not accept byrefs. errorR(Error(FSComp.SR.chkByrefUsedInInvalidWay(v.DisplayName), m)) elif v.IsBaseVal then errorR(Error(FSComp.SR.chkBaseUsedInInvalidWay(), m)) else - // Should be dead code, unless governing tests change + // Should be dead code, unless governing tests change errorR(InternalError(FSComp.SR.chkVariableUsedInInvalidWay(v.DisplayName), m)) Some frees else @@ -498,17 +498,17 @@ let AccessInternalsVisibleToAsInternal thisCompPath internalsVisibleToPaths acce // Each internalsVisibleToPath is a compPath for the internals of some assembly. // Replace those by the compPath for the internals of this assembly. // This makes those internals visible here, but still internal. Bug://3737 - (access, internalsVisibleToPaths) ||> List.fold (fun access internalsVisibleToPath -> + (access, internalsVisibleToPaths) ||> List.fold (fun access internalsVisibleToPath -> accessSubstPaths (thisCompPath, internalsVisibleToPath) access) - + let CheckTypeForAccess (cenv: cenv) env objName valAcc m ty = - if cenv.reportErrors then + if cenv.reportErrors then - let visitType ty = - // We deliberately only check the fully stripped type for accessibility, + let visitType ty = + // We deliberately only check the fully stripped type for accessibility, // because references to private type abbreviations are permitted - match tryTcrefOfAppTy cenv.g ty with + match tryTcrefOfAppTy cenv.g ty with | ValueNone -> () | ValueSome tcref -> let thisCompPath = compPathOfCcu cenv.viewCcu @@ -519,12 +519,12 @@ let CheckTypeForAccess (cenv: cenv) env objName valAcc m ty = CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env false ty let WarnOnWrongTypeForAccess (cenv: cenv) env objName valAcc m ty = - if cenv.reportErrors then + if cenv.reportErrors then - let visitType ty = - // We deliberately only check the fully stripped type for accessibility, + let visitType ty = + // We deliberately only check the fully stripped type for accessibility, // because references to private type abbreviations are permitted - match tryTcrefOfAppTy cenv.g ty with + match tryTcrefOfAppTy cenv.g ty with | ValueNone -> () | ValueSome tcref -> let thisCompPath = compPathOfCcu cenv.viewCcu @@ -534,11 +534,11 @@ let WarnOnWrongTypeForAccess (cenv: cenv) env objName valAcc m ty = let warningText = errorText + Environment.NewLine + FSComp.SR.tcTypeAbbreviationsCheckedAtCompileTime() warning(AttributeChecking.ObsoleteWarning(warningText, m)) - CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env false ty + CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env false ty /// Indicates whether a byref or byref-like type is permitted at a particular location [] -type PermitByRefType = +type PermitByRefType = /// Don't permit any byref or byref-like types | None @@ -551,14 +551,14 @@ type PermitByRefType = /// Permit all byref and byref-like types | All - + /// Indicates whether an address-of operation is permitted at a particular location [] -type PermitByRefExpr = +type PermitByRefExpr = /// Permit a tuple of arguments where elements can be byrefs - | YesTupleOfArgs of int + | YesTupleOfArgs of int - /// Context allows for byref typed expr. + /// Context allows for byref typed expr. | Yes /// Context allows for byref typed expr, but the byref must be returnable @@ -567,19 +567,19 @@ type PermitByRefExpr = /// 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 + /// General (address-of expr and byref values not allowed) + | No - member ctxt.Disallow = - match ctxt with - | PermitByRefExpr.Yes - | PermitByRefExpr.YesReturnable - | PermitByRefExpr.YesReturnableNonLocal -> false + member ctxt.Disallow = + match ctxt with + | PermitByRefExpr.Yes + | PermitByRefExpr.YesReturnable + | PermitByRefExpr.YesReturnableNonLocal -> false | _ -> true - member ctxt.PermitOnlyReturnable = - match ctxt with - | PermitByRefExpr.YesReturnable + member ctxt.PermitOnlyReturnable = + match ctxt with + | PermitByRefExpr.YesReturnable | PermitByRefExpr.YesReturnableNonLocal -> true | _ -> false @@ -591,46 +591,46 @@ type PermitByRefExpr = let inline IsLimitEscapingScope env (ctxt: PermitByRefExpr) limit = (limit.scope >= env.returnScope || (limit.IsLocal && ctxt.PermitOnlyReturnableNonLocal)) -let mkArgsPermit n = +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 = +let mkArgsForAppliedVal isBaseCall (vref: ValRef) argsl = match vref.ValReprInfo with - | Some valReprInfo -> + | 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 + if List.length argsl >= argArities.Length then List.map mkArgsPermit argArities else [] - | None -> [] + | 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 + 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 + // 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 types occurring in the TAST. let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError = - if cenv.reportErrors then - let visitTyar (env, tp) = - if not (env.boundTypars.ContainsKey tp) then - if tp.IsCompilerGenerated then + if cenv.reportErrors then + let visitTyar (env, tp) = + if not (env.boundTypars.ContainsKey tp) then + if tp.IsCompilerGenerated then errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScopeAnon(), m)) else errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScope(tp.DisplayName), m)) let visitTyconRef isInner tcref = - + let isInnerByRefLike = isInner && isByrefLikeTyconRef cenv.g m tcref match permitByRefLike with @@ -642,25 +642,25 @@ let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError = onInnerByrefError () | _ -> () - if tyconRefEq cenv.g cenv.g.system_Void_tcref tcref then + if tyconRefEq cenv.g cenv.g.system_Void_tcref tcref then errorR(Error(FSComp.SR.chkSystemVoidOnlyInTypeof(), m)) // check if T contains byref types in case of byref - let visitAppTy (tcref, tinst) = + let visitAppTy (tcref, tinst) = if isByrefLikeTyconRef cenv.g m tcref then let visitType ty0 = match tryTcrefOfAppTy cenv.g ty0 with | ValueNone -> () - | ValueSome tcref2 -> - if isByrefTyconRef cenv.g tcref2 then - errorR(Error(FSComp.SR.chkNoByrefsOfByrefs(NicePrint.minimalStringOfType cenv.denv ty), m)) + | ValueSome tcref2 -> + if isByrefTyconRef cenv.g tcref2 then + errorR(Error(FSComp.SR.chkNoByrefsOfByrefs(NicePrint.minimalStringOfType cenv.denv ty), m)) CheckTypesDeep cenv (visitType, None, None, None, None) cenv.g env tinst - let visitTraitSolution info = - match info with - | FSMethSln(_, vref, _, _) -> + let visitTraitSolution info = + match info with + | FSMethSln(_, vref, _, _) -> //printfn "considering %s..." vref.DisplayName - if valRefInThisAssembly cenv.g.compilingFSharpCore vref && not (cenv.boundVals.ContainsKey(vref.Stamp)) then + if valRefInThisAssembly cenv.g.compilingFSharpCore vref && not (cenv.boundVals.ContainsKey(vref.Stamp)) then //printfn "recording %s..." vref.DisplayName cenv.potentialUnboundUsesOfVals <- cenv.potentialUnboundUsesOfVals.Add(vref.Stamp, m) | _ -> () @@ -671,7 +671,7 @@ let CheckType permitByRefLike cenv env m ty = CheckTypeAux permitByRefLike cenv env m ty (fun () -> errorR(Error(FSComp.SR.chkErrorUseOfByref(), m))) /// Check types occurring in TAST (like CheckType) and additionally reject any byrefs. -/// The additional byref checks are to catch "byref instantiations" - one place were byref are not permitted. +/// The additional byref checks are to catch "byref instantiations" - one place were byref are not permitted. let CheckTypeNoByrefs (cenv: cenv) env m ty = CheckType PermitByRefType.None cenv env m ty /// Check types occurring in TAST but allow a Span or similar @@ -690,21 +690,21 @@ let CheckTypeInstNoInnerByrefs cenv env m tyargs = tyargs |> List.iter (CheckTypeNoInnerByrefs cenv env m) /// Applied functions get wrapped in coerce nodes for subsumption coercions -let (|OptionalCoerce|) expr = +let (|OptionalCoerce|) expr = match stripDebugPoints expr with - | Expr.Op (TOp.Coerce, _, [DebugPoints(Expr.App (f, _, _, [], _), _)], _) -> f + | Expr.Op (TOp.Coerce, _, [DebugPoints(Expr.App (f, _, _, [], _), _)], _) -> f | _ -> expr /// Check an expression doesn't contain a 'reraise' -let CheckNoReraise cenv freesOpt (body: Expr) = +let CheckNoReraise cenv freesOpt (body: Expr) = if cenv.reportErrors then - // Avoid recomputing the free variables + // Avoid recomputing the free variables let fvs = match freesOpt with None -> freeInExpr CollectLocals body | Some fvs -> fvs if fvs.UsesUnboundRethrow then errorR(Error(FSComp.SR.chkErrorContainsCallToRethrow(), body.Range)) /// Check if a function is a quotation splice operator -let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.splice_raw_expr_vref +let isSpliceOperator g v = valRefEq g v g.splice_expr_vref || valRefEq g v g.splice_raw_expr_vref /// Examples: @@ -722,11 +722,11 @@ type TTypeEquality = | NotEqual let compareTypesWithRegardToTypeVariablesAndMeasures g amap m ty1 ty2 = - + if (typeEquiv g ty1 ty2) then ExactlyEqual else - if (typeEquiv g ty1 ty2 || TypesFeasiblyEquivStripMeasures g amap m ty1 ty2) then + if (typeEquiv g ty1 ty2 || TypesFeasiblyEquivStripMeasures g amap m ty1 ty2) then FeasiblyEqual else NotEqual @@ -773,9 +773,9 @@ let rec CheckExprNoByrefs cenv env expr = CheckExpr cenv env expr PermitByRefExpr.No |> ignore /// Check a value -and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = +and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = - if cenv.reportErrors then + if cenv.reportErrors then if isSpliceOperator cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)) if isSpliceOperator cenv.g v then errorR(Error(FSComp.SR.chkNoFirstClassSplicing(), m)) if valRefEq cenv.g v cenv.g.addrof_vref then errorR(Error(FSComp.SR.chkNoFirstClassAddressOf(), m)) @@ -787,8 +787,8 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = if valRefEq cenv.g v cenv.g.refcell_incr_vref then informationalWarning(Error(FSComp.SR.chkInfoRefcellIncr(), m)) if valRefEq cenv.g v cenv.g.refcell_decr_vref then informationalWarning(Error(FSComp.SR.chkInfoRefcellDecr(), m)) - // ByRefLike-typed values can only occur in permitting ctxts - if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then + // ByRefLike-typed values can only occur in permitting ctxts + if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) if env.isInAppExpr then @@ -797,30 +797,30 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = CheckTypeNoInnerByrefs cenv env m v.Type /// Check a use of a value -and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) = - +and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitByRefExpr) = + let g = cenv.g let limit = GetLimitVal cenv env m vref.Deref - if cenv.reportErrors then + if cenv.reportErrors then - if vref.IsBaseVal then + if vref.IsBaseVal then errorR(Error(FSComp.SR.chkLimitationsOfBaseKeyword(), m)) - let isCallOfConstructorOfAbstractType = - (match vFlags with NormalValUse -> true | _ -> false) && - vref.IsConstructor && + let isCallOfConstructorOfAbstractType = + (match vFlags with NormalValUse -> true | _ -> false) && + vref.IsConstructor && (match vref.TryDeclaringEntity with Parent tcref -> isAbstractTycon tcref.Deref | _ -> false) - if isCallOfConstructorOfAbstractType then + if isCallOfConstructorOfAbstractType then errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(), m)) // This is used to handle this case: // let x = 1 // let y = &x // &y - let isReturnExprBuiltUsingStackReferringByRefLike = + let isReturnExprBuiltUsingStackReferringByRefLike = ctxt.PermitOnlyReturnable && ((HasLimitFlag LimitFlags.ByRef limit && IsLimitEscapingScope env ctxt limit) || HasLimitFlag LimitFlags.StackReferringSpanLike limit) @@ -833,9 +833,9 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB | true, false -> errorR(Error(FSComp.SR.chkNoSpanLikeVariable(vref.DisplayName), m)) | false, true -> errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) | false, false -> errorR(Error(FSComp.SR.chkNoByrefAddressOfLocal(vref.DisplayName), m)) - - let isReturnOfStructThis = - ctxt.PermitOnlyReturnable && + + let isReturnOfStructThis = + ctxt.PermitOnlyReturnable && isByrefTy g vref.Type && (vref.IsMemberThisVal) @@ -845,9 +845,9 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB CheckValRef cenv env vref m ctxt limit - + /// Check an expression, given information about the position of the expression -and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = +and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = let g = cenv.g let expr = stripExpr expr let expr = stripDebugPoints expr @@ -861,12 +861,12 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = // Special diagnostics for `raise`, `failwith`, `failwithf`, `nullArg`, `invalidOp` library intrinsics commonly used to raise exceptions // to warn on over-application. match f with - | OptionalCoerce(Expr.Val (v, _, funcRange)) + | OptionalCoerce(Expr.Val (v, _, funcRange)) when (valRefEq g v g.raise_vref || valRefEq g v g.failwith_vref || valRefEq g v g.null_arg_vref || valRefEq g v g.invalid_op_vref) -> match argsl with | [] | [_] -> () | _ :: _ :: _ -> - warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(v.DisplayName, 1, argsl.Length), funcRange)) + warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(v.DisplayName, 1, argsl.Length), funcRange)) | OptionalCoerce(Expr.Val (v, _, funcRange)) when valRefEq g v g.invalid_arg_vref -> match argsl with @@ -893,14 +893,14 @@ and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = let isReturnSpanLike = isSpanLikeTy cenv.g m returnTy // If return is a byref, and being used as a return, then a single argument cannot be a local-byref or a stack referring span-like. - let isReturnLimitedByRef = - isReturnByref && - (HasLimitFlag LimitFlags.ByRef limitArgs || + let isReturnLimitedByRef = + isReturnByref && + (HasLimitFlag LimitFlags.ByRef limitArgs || HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs) // If return is a byref, and being used as a return, then a single argument cannot be a stack referring span-like or a local-byref of a stack referring span-like. - let isReturnLimitedSpanLike = - isReturnSpanLike && + let isReturnLimitedSpanLike = + isReturnSpanLike && (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs) @@ -911,11 +911,11 @@ and CheckCallLimitArgs cenv env m returnTy limitArgs (ctxt: PermitByRefExpr) = else errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) - // You cannot call a function that takes a byref of a span-like (not stack referring) and + // You cannot call a function that takes a byref of a span-like (not stack referring) and // either a stack referring span-like or a local-byref of a stack referring span-like. - let isCallLimited = - HasLimitFlag LimitFlags.ByRefOfSpanLike limitArgs && - (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || + let isCallLimited = + HasLimitFlag LimitFlags.ByRefOfSpanLike limitArgs && + (HasLimitFlag LimitFlags.StackReferringSpanLike limitArgs || HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limitArgs) if isCallLimited then @@ -965,7 +965,7 @@ and CheckCallWithReceiver cenv env m returnTy args ctxts ctxt = | ctxt :: ctxts -> ctxt, ctxts let receiverLimit = CheckExpr cenv env receiverArg receiverContext - let limitArgs = + let limitArgs = let limitArgs = CheckExprs cenv env args ctxts // We do not include the receiver's limit in the limit args unless the receiver is a stack referring span-like. if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike receiverLimit then @@ -975,9 +975,9 @@ 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) = match expr with - | Expr.Sequential (e1, e2, NormalSeq, _) -> + | Expr.Sequential (e1, e2, NormalSeq, _) -> CheckExprNoByrefs cenv env e1 // tailcall CheckExprLinear cenv env e2 ctxt contf @@ -991,35 +991,35 @@ and CheckExprLinear (cenv: cenv) (env: env) expr (ctxt: PermitByRefExpr) (contf else PermitByRefExpr.Yes - let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind + let limit = CheckBinding cenv { env with returnScope = env.returnScope + 1 } false bindingContext bind 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 | LinearOpExpr (_op, tyargs, argsHead, argLast, m) -> CheckTypeInstNoByrefs cenv env m tyargs - argsHead |> List.iter (CheckExprNoByrefs cenv env) + argsHead |> List.iter (CheckExprNoByrefs cenv env) // tailcall CheckExprLinear cenv env argLast PermitByRefExpr.No (fun _ -> contf NoLimit) | LinearMatchExpr (_spMatch, _exprm, dtree, tg1, e2, m, ty) -> - CheckTypeNoInnerByrefs cenv env m ty + CheckTypeNoInnerByrefs cenv env m ty CheckDecisionTree cenv env dtree let lim1 = CheckDecisionTreeTarget cenv env ctxt tg1 // tailcall CheckExprLinear cenv env e2 ctxt (fun lim2 -> contf (CombineLimits [ lim1; lim2 ])) - | Expr.DebugPoint (_, innerExpr) -> + | Expr.DebugPoint (_, innerExpr) -> CheckExprLinear cenv env innerExpr ctxt contf - | _ -> + | _ -> // not a linear expression contf (CheckExpr cenv env expr ctxt) /// 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 : bool = let g = cenv.g match env.resumableCode with @@ -1029,14 +1029,14 @@ 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 } thenExpr + CheckExprNoByrefs cenv { env with resumableCode = Resumable.None } 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 noneBranchExpr BindVal cenv env someVar CheckExprNoByrefs cenv env someBranchExpr true @@ -1083,7 +1083,7 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = 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) CheckDecisionTree cenv { env with resumableCode = Resumable.None } dtree @@ -1096,29 +1096,29 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = BindVal cenv env bind.Var CheckExprNoByrefs cenv env 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 -> + | Expr.LetRec(_bindings, bodyExpr, _range, _frees) when allowed -> errorR(Error(FSComp.SR.tcResumableCodeContainsLetRec(), expr.Range)) CheckExprNoByrefs cenv env bodyExpr true // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match - | Expr.Const (Const.Zero, _, _) -> + | Expr.Const (Const.Zero, _, _) -> true - | Expr.DebugPoint (_, innerExpr) -> + | Expr.DebugPoint (_, innerExpr) -> TryCheckResumableCodeConstructs cenv env innerExpr | _ -> 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) : Limit = + // Guard the stack for deeply nested expressions cenv.stackGuard.Guard <| fun () -> - + let g = cenv.g let origExpr = stripExpr origExpr @@ -1129,64 +1129,64 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = let expr = stripExpr expr match TryCheckResumableCodeConstructs cenv env expr with - | true -> + | true -> // we've handled the special cases of resumable code and don't do other checks. - NoLimit - | false -> + NoLimit + | false -> // Handle ResumableExpr --> other expression let env = { env with resumableCode = Resumable.None } match expr with - | LinearOpExpr _ - | LinearMatchExpr _ - | Expr.Let _ + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Let _ | Expr.Sequential (_, _, NormalSeq, _) - | Expr.DebugPoint _ -> + | Expr.DebugPoint _ -> CheckExprLinear cenv env expr ctxt id - | Expr.Sequential (e1, e2, ThenDoSeq, _) -> + | Expr.Sequential (e1, e2, ThenDoSeq, _) -> CheckExprNoByrefs cenv env e1 CheckExprNoByrefs cenv env e2 NoLimit - | Expr.Const (_, m, ty) -> - CheckTypeNoInnerByrefs cenv env m ty + | Expr.Const (_, m, ty) -> + CheckTypeNoInnerByrefs cenv env m ty NoLimit - - | Expr.Val (vref, vFlags, m) -> + + | Expr.Val (vref, vFlags, m) -> CheckValUse cenv env (vref, vFlags, m) ctxt - - | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> + + | Expr.Quote (ast, savedConv, _isFromQueryExpression, m, ty) -> CheckQuoteExpr cenv env (ast, savedConv, m, ty) | StructStateMachineExpr g info -> CheckStructStateMachineExpr cenv env expr info - | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> + | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) // Allow base calls to F# methods - | Expr.App (InnerExprPat(ExprValWithPossibleTypeInst(v, vFlags, _, _) as f), _fty, tyargs, Expr.Val (baseVal, _, _) :: rest, m) - when ((match vFlags with VSlotDirectCall -> true | _ -> false) && + | 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 env expr (v, f, _fty, tyargs, baseVal, rest, m) // Allow base calls to IL methods - | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), tyargs, Expr.Val (baseVal, _, _) :: rest, m) + | Expr.Op (TOp.ILCall (isVirtual, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), tyargs, Expr.Val (baseVal, _, _) :: rest, m) when not isVirtual && baseVal.IsBaseVal -> - + CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) | Expr.Op (op, tyargs, args, m) -> CheckExprOp cenv env (op, tyargs, args, m) ctxt expr - // Allow 'typeof' calls as a special case, the only accepted use of System.Void! + // Allow 'typeof' calls as a special case, the only accepted use of System.Void! | TypeOfExpr g ty when isVoidTy g ty -> NoLimit - // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! + // Allow 'typedefof' calls as a special case, the only accepted use of System.Void! | TypeDefOfExpr g ty when isVoidTy g ty -> NoLimit @@ -1198,65 +1198,65 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (ctxt: PermitByRefExpr) : Limit = | Expr.App (f, _fty, tyargs, argsl, m) -> CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt - | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> + | Expr.Lambda (_, _, _, argvs, _, m, bodyTy) -> CheckLambda cenv env expr (argvs, m, bodyTy) - | Expr.TyLambda (_, tps, _, m, bodyTy) -> + | Expr.TyLambda (_, tps, _, m, bodyTy) -> CheckTyLambda cenv env expr (tps, m, bodyTy) - | Expr.TyChoose (tps, e1, _) -> - let env = BindTypars g env tps - CheckExprNoByrefs cenv env e1 + | Expr.TyChoose (tps, e1, _) -> + let env = BindTypars g env tps + CheckExprNoByrefs cenv env e1 NoLimit - | Expr.Match (_, _, dtree, targets, m, ty) -> + | Expr.Match (_, _, dtree, targets, m, ty) -> CheckMatch cenv env ctxt (dtree, targets, m, ty) - | Expr.LetRec (binds, bodyExpr, _, _) -> + | Expr.LetRec (binds, bodyExpr, _, _) -> CheckLetRec cenv env (binds, bodyExpr) - | Expr.StaticOptimization (constraints, e2, e3, m) -> + | Expr.StaticOptimization (constraints, e2, e3, m) -> CheckStaticOptimization cenv env (constraints, e2, e3, m) | Expr.WitnessArg _ -> NoLimit - | Expr.Link _ -> + | Expr.Link _ -> failwith "Unexpected reclink" and CheckQuoteExpr cenv env (ast, savedConv, m, ty) = let g = cenv.g CheckExprNoByrefs cenv {env with quote=true} ast - if cenv.reportErrors then + if cenv.reportErrors then cenv.usesQuotations <- true // Translate the quotation to quotation data - try - let doData suppressWitnesses = - let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.No) - let qdata = QuotationTranslator.ConvExprPublic qscope suppressWitnesses ast + try + let doData suppressWitnesses = + let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.No) + let qdata = QuotationTranslator.ConvExprPublic qscope suppressWitnesses ast let typeDefs, spliceTypes, spliceExprs = qscope.Close() typeDefs, List.map fst spliceTypes, List.map fst spliceExprs, qdata let data1 = doData true let data2 = doData false - match savedConv.Value with + match savedConv.Value with | None -> savedConv.Value <- Some (data1, data2) | Some _ -> () - with QuotationTranslator.InvalidQuotedTerm e -> + with QuotationTranslator.InvalidQuotedTerm e -> errorRecovery e m - + CheckTypeNoByrefs cenv env m ty NoLimit and CheckStructStateMachineExpr cenv env expr info = let g = cenv.g - let (_dataTy, - (moveNextThisVar, moveNextExpr), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), + let (_dataTy, + (moveNextThisVar, moveNextExpr), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), (afterCodeThisVar, afterCodeBody)) = info if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then @@ -1275,8 +1275,8 @@ and CheckObjectExpr cenv env (ty, basev, superInitCall, overrides, iimpls, m) = CheckInterfaceImpls cenv env basev iimpls CheckTypeNoByrefs cenv env m ty - let interfaces = - [ if isInterfaceTy g ty then + let interfaces = + [ if isInterfaceTy g ty then yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty for ty, _ in iimpls do yield! AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes ty ] @@ -1291,7 +1291,7 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = if memberInfo.MemberFlags.IsDispatchSlot then errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName), m)) NoLimit - else + else let env = { env with isInAppExpr = true } let returnTy = tyOfExpr g expr @@ -1301,9 +1301,9 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = CheckTypeNoInnerByrefs cenv env m returnTy CheckExprs cenv env rest (mkArgsForAppliedExpr true rest f) -and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = +and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyargs, baseVal, rest, m) = let g = cenv.g - // Disallow calls to abstract base methods on IL types. + // Disallow calls to abstract base methods on IL types. match tryTcrefOfAppTy g baseVal.Type with | ValueSome tcref when tcref.IsILTycon -> try @@ -1324,14 +1324,14 @@ and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyarg CheckValRef cenv env baseVal m PermitByRefExpr.No CheckExprsPermitByRefLike cenv env rest -and CheckSpliceApplication cenv env (tinst, arg, m) = +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 NoLimit -and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = +and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt = let g = cenv.g - match expr with + match expr with | ResumableCodeInvoke g _ -> warning(Error(FSComp.SR.tcResumableCodeInvocation(), m)) | _ -> () @@ -1358,43 +1358,43 @@ 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) = - let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) - let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in +and CheckLambda cenv env expr (argvs, m, bodyTy) = + let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) + let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes -and CheckTyLambda cenv env expr (tps, m, bodyTy) = - let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - let ty = mkForallTyIfNeeded tps bodyTy in +and CheckTyLambda cenv env expr (tps, m, bodyTy) = + let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) + let ty = mkForallTyIfNeeded tps bodyTy in CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes -and CheckMatch cenv env ctxt (dtree, targets, m, ty) = +and CheckMatch cenv env ctxt (dtree, targets, m, ty) = CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch CheckDecisionTree cenv env dtree CheckDecisionTreeTargets cenv env targets ctxt -and CheckLetRec cenv env (binds, bodyExpr) = +and CheckLetRec cenv env (binds, bodyExpr) = BindVals cenv env (valsOfBinds binds) CheckBindings cenv env binds CheckExprNoByrefs cenv env bodyExpr NoLimit -and CheckStaticOptimization cenv env (constraints, e2, e3, m) = +and CheckStaticOptimization cenv env (constraints, e2, e3, m) = CheckExprNoByrefs cenv env e2 CheckExprNoByrefs cenv env e3 constraints |> List.iter (function - | TTyconEqualsTycon(ty1, ty2) -> + | TTyconEqualsTycon(ty1, ty2) -> CheckTypeNoByrefs cenv env m ty1 CheckTypeNoByrefs cenv env m ty2 - | TTyconIsStruct ty1 -> + | TTyconIsStruct ty1 -> CheckTypeNoByrefs cenv env m ty1) NoLimit -and CheckMethods cenv env baseValOpt (ty, methods) = - methods |> List.iter (CheckMethod cenv env baseValOpt ty) +and CheckMethods cenv env baseValOpt (ty, methods) = + methods |> List.iter (CheckMethod cenv env baseValOpt ty) -and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, body, m)) = - let env = BindTypars cenv.g env tps +and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, body, m)) = + let env = BindTypars cenv.g env tps let vs = List.concat vs let env = BindArgVals env vs let env = @@ -1410,18 +1410,18 @@ and CheckMethod cenv env baseValOpt ty (TObjExprMethod(_, attribs, tps, vs, 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 -and CheckInterfaceImpls cenv env baseValOpt l = +and CheckInterfaceImpls cenv env baseValOpt l = l |> List.iter (CheckInterfaceImpl cenv env baseValOpt) - -and CheckInterfaceImpl cenv env baseValOpt overrides = - CheckMethods cenv env baseValOpt overrides + +and CheckInterfaceImpl cenv env baseValOpt overrides = + CheckMethods cenv env baseValOpt overrides and CheckNoResumableStmtConstructs cenv _env expr = let g = cenv.g - match expr with - | Expr.Val (v, _, m) - when valRefEq g v g.cgh__resumeAt_vref || - valRefEq g v g.cgh__resumableEntry_vref || + match expr with + | Expr.Val (v, _, m) + when valRefEq g v g.cgh__resumeAt_vref || + valRefEq g v g.cgh__resumableEntry_vref || valRefEq g v g.cgh__stateMachine_vref -> errorR(Error(FSComp.SR.tcInvalidResumableConstruct(v.DisplayName), m)) | _ -> () @@ -1431,20 +1431,20 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // Ensure anonymous record type requirements are recorded match op with - | TOp.AnonRecdGet (anonInfo, _) - | TOp.AnonRecd anonInfo -> + | TOp.AnonRecdGet (anonInfo, _) + | TOp.AnonRecd anonInfo -> RecordAnonRecdInfo cenv anonInfo | _ -> () // Special cases - match op, tyargs, args with - // Handle these as special cases since mutables are allowed inside their bodies + 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, _, _)] -> - CheckTypeInstNoByrefs cenv env m tyargs + CheckTypeInstNoByrefs cenv env m tyargs CheckExprsNoByRefLike cenv env [e1;e2] | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> - CheckTypeInstNoInnerByrefs cenv env m tyargs // result of a try/finally can be a byref + 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 limit @@ -1454,19 +1454,19 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = CheckExprsNoByRefLike cenv env [e1;e2;e3] | 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 + 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 // [(* 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 CombineTwoLimits limit1 limit2 - + | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, enclTypeInst, methInst, retTypes), _, _ -> CheckTypeInstNoByrefs cenv env m tyargs CheckTypeInstNoByrefs cenv env m enclTypeInst CheckTypeInstNoByrefs cenv env m methInst CheckTypeInstNoInnerByrefs cenv env m retTypes // permit byref returns - let hasReceiver = + let hasReceiver = (ilMethRef.CallingConv.IsInstance || ilMethRef.CallingConv.IsInstanceExplicit) && not args.IsEmpty @@ -1475,46 +1475,46 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = let argContexts = List.init args.Length (fun _ -> PermitByRefExpr.Yes) match retTypes with - | [ty] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> + | [ty] when ctxt.PermitOnlyReturnable && isByrefLikeTy g m ty -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts ctxt else CheckCall cenv env m returnTy args argContexts ctxt - | _ -> + | _ -> if hasReceiver then CheckCallWithReceiver cenv env m returnTy args argContexts PermitByRefExpr.Yes else CheckCall cenv env m returnTy args argContexts PermitByRefExpr.Yes - | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> - match ctxt with - | PermitByRefExpr.YesTupleOfArgs nArity -> - if cenv.reportErrors then - if args.Length <> nArity then + | TOp.Tuple tupInfo, _, _ when not (evalTupInfoIsStruct tupInfo) -> + match ctxt with + | PermitByRefExpr.YesTupleOfArgs nArity -> + if cenv.reportErrors then + if args.Length <> nArity then errorR(InternalError("Tuple arity does not correspond to planned function argument arity", m)) - // This tuple should not be generated. The known function arity - // means it just bundles arguments. - CheckExprsPermitByRefLike cenv env args - | _ -> + // This tuple should not be generated. The known function arity + // means it just bundles arguments. + CheckExprsPermitByRefLike cenv env args + | _ -> CheckTypeInstNoByrefs cenv env m tyargs - CheckExprsNoByRefLike cenv env args + CheckExprsNoByRefLike cenv env args - | TOp.LValueOp (LAddrOf _, vref), _, _ -> + | TOp.LValueOp (LAddrOf _, vref), _, _ -> let limit1 = GetLimitValByRef cenv env m vref.Deref let limit2 = CheckExprsNoByRefLike cenv env args let limit = CombineTwoLimits limit1 limit2 - if cenv.reportErrors then + if cenv.reportErrors then - if ctxt.Disallow then + if ctxt.Disallow then errorR(Error(FSComp.SR.chkNoAddressOfAtThisPoint(vref.DisplayName), m)) - - let returningAddrOfLocal = - ctxt.PermitOnlyReturnable && + + let returningAddrOfLocal = + ctxt.PermitOnlyReturnable && HasLimitFlag LimitFlags.ByRef limit && IsLimitEscapingScope env ctxt limit - - if returningAddrOfLocal then + + if returningAddrOfLocal then if vref.IsCompilerGenerated then errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) else @@ -1522,15 +1522,15 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = limit - | TOp.LValueOp (LByrefSet, vref), _, [arg] -> + | TOp.LValueOp (LByrefSet, vref), _, [arg] -> let limit = GetLimitVal cenv env m vref.Deref let isVrefLimited = not (HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit) let isArgLimited = HasLimitFlag LimitFlags.StackReferringSpanLike (CheckExprPermitByRefLike cenv env arg) - if isVrefLimited && isArgLimited then + if isVrefLimited && isArgLimited then errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(vref.DisplayName), m)) NoLimit - | TOp.LValueOp (LByrefGet, vref), _, [] -> + | TOp.LValueOp (LByrefGet, vref), _, [] -> let limit = GetLimitVal cenv env m vref.Deref if HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit then @@ -1546,27 +1546,27 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = else { scope = 1; flags = LimitFlags.None } - | TOp.LValueOp (LSet, vref), _, [arg] -> + | TOp.LValueOp (LSet, vref), _, [arg] -> let isVrefLimited = not (HasLimitFlag LimitFlags.StackReferringSpanLike (GetLimitVal cenv env m vref.Deref)) let isArgLimited = HasLimitFlag LimitFlags.StackReferringSpanLike (CheckExprPermitByRefLike cenv env arg) - if isVrefLimited && isArgLimited then + if isVrefLimited && isArgLimited then errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(vref.DisplayName), m)) NoLimit | TOp.AnonRecdGet _, _, [arg1] - | TOp.TupleFieldGet _, _, [arg1] -> + | TOp.TupleFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprsPermitByRefLike cenv env [arg1] - | TOp.ValFieldGet _rf, _, [arg1] -> + | TOp.ValFieldGet _rf, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs - //See mkRecdFieldGetViaExprAddr -- byref arg1 when #args =1 - // Property getters on mutable structs come through here. - CheckExprsPermitByRefLike cenv env [arg1] + //See mkRecdFieldGetViaExprAddr -- byref arg1 when #args =1 + // Property getters on mutable structs come through here. + CheckExprsPermitByRefLike cenv env [arg1] - | TOp.ValFieldSet rf, _, [arg1;arg2] -> + | TOp.ValFieldSet rf, _, [arg1;arg2] -> CheckTypeInstNoByrefs cenv env m tyargs - // See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 + // See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 // Field setters on mutable structs come through here let limit1 = CheckExprPermitByRefLike cenv env arg1 let limit2 = CheckExprPermitByRefLike cenv env arg2 @@ -1591,9 +1591,9 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // Check get of static field | TOp.ValFieldGetAddr (rfref, _readonly), tyargs, [] -> - + if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)) + errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)) CheckTypeInstNoByrefs cenv env m tyargs NoLimit @@ -1606,24 +1606,24 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = // C# applies a rule where the APIs to struct types can't return the addresses of fields in that struct. // There seems no particular reason for this given that other protections in the language, though allowing - // it would mean "readonly" on a struct doesn't imply immutability-of-contents - it only implies + // it would mean "readonly" on a struct doesn't imply immutability-of-contents - it only implies if ctxt.PermitOnlyReturnable && (match stripDebugPoints obj with Expr.Val (vref, _, _) -> vref.IsMemberThisVal | _ -> false) && isByrefTy g (tyOfExpr g obj) then errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)) - // This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. + // This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. 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 - | TOp.UnionCaseFieldGet _, _, [arg1] -> + | TOp.UnionCaseFieldGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprPermitByRefLike cenv env arg1 - | TOp.UnionCaseTagGet _, _, [arg1] -> + | TOp.UnionCaseTagGet _, _, [arg1] -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprPermitByRefLike cenv env arg1 // allow byref - it may be address-of-struct @@ -1646,18 +1646,18 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = match instrs, args with // Write a .NET instance field | [ I_stfld (_alignment, _vol, _fspec) ], _ -> - // permit byref for lhs lvalue + // 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 // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec) ], _ -> - // permit byref for lhs lvalue + // permit byref for lhs lvalue CheckExprsPermitByRefLike cenv env args // Read a .NET instance field | [ I_ldfld (_alignment, _vol, _fspec); AI_nop ], _ -> - // permit byref for lhs lvalue of readonly value + // permit byref for lhs lvalue of readonly value CheckExprsPermitByRefLike cenv env args | [ I_ldsflda fspec ], [] -> @@ -1676,56 +1676,56 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | [ I_ldelema (_, isNativePtr, _, _) ], lhsArray :: indices -> if ctxt.Disallow && cenv.reportErrors && not isNativePtr && isByrefLikeTy g m (tyOfExpr g expr) then errorR(Error(FSComp.SR.chkNoAddressOfArrayElementAtThisPoint(), m)) - // permit byref for lhs lvalue + // permit byref for lhs lvalue let limit = CheckExprPermitByRefLike cenv env lhsArray CheckExprsNoByRefLike cenv env indices |> ignore limit | [ AI_conv _ ], _ -> - // permit byref for args to conv - CheckExprsPermitByRefLike cenv env args + // permit byref for args to conv + CheckExprsPermitByRefLike cenv env args | _ -> - CheckExprsNoByRefLike cenv env args + CheckExprsNoByRefLike cenv env args | TOp.TraitCall _, _, _ -> CheckTypeInstNoByrefs cenv env m tyargs - // allow args to be byref here + // allow args to be byref here CheckExprsPermitByRefLike cenv env args - + | TOp.Recd _, _, _ -> CheckTypeInstNoByrefs cenv env m tyargs CheckExprsPermitByRefLike cenv env args - | _ -> + | _ -> CheckTypeInstNoByrefs cenv env m tyargs - CheckExprsNoByRefLike cenv env args + CheckExprsNoByRefLike cenv env args and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwaysCheckNoReraise expr mOrig ety ctxt = let g = cenv.g let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo) - // The valReprInfo here says we are _guaranteeing_ to compile a function value - // as a .NET method with precisely the corresponding argument counts. + // 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) -> + | Expr.TyChoose (tps, e1, m) -> let env = BindTypars g env tps CheckLambdas isTop memberVal cenv env inlined valReprInfo alwaysCheckNoReraise e1 m ety ctxt - | Expr.Lambda (_, _, _, _, _, m, _) + | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety) - let env = BindTypars g env tps + let env = BindTypars g env tps let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt let restArgs = List.concat vsl let syntacticArgs = thisAndBase @ restArgs let env = BindArgVals env restArgs - match memInfo with + match memInfo with | None -> () - | Some mi -> + | Some mi -> // ctorThis and baseVal values are always considered used - for v in thisAndBase do v.SetHasBeenReferenced() + for v in thisAndBase do v.SetHasBeenReferenced() // instance method 'this' is always considered used match mi.MemberFlags.IsInstance, restArgs with | true, firstArg :: _ -> firstArg.SetHasBeenReferenced() @@ -1743,10 +1743,10 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa // Check argument types for arg in syntacticArgs do - if arg.InlineIfLambda && (not inlined || not (isFunTy g arg.Type || isFSharpDelegateTy g arg.Type)) then + if arg.InlineIfLambda && (not inlined || not (isFunTy g arg.Type || isFSharpDelegateTy g arg.Type)) then errorR(Error(FSComp.SR.tcInlineIfLambdaUsedOnNonInlineFunctionOrMethod(), arg.Range)) - CheckValSpecAux permitByRefType cenv env arg (fun () -> + CheckValSpecAux permitByRefType cenv env arg (fun () -> if arg.IsCompilerGenerated then errorR(Error(FSComp.SR.chkErrorUseOfByref(), arg.Range)) else @@ -1765,7 +1765,7 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa let freesOpt = CheckEscapes cenv memInfo.IsSome m syntacticArgs body // no reraise under lambda expression - CheckNoReraise cenv freesOpt body + CheckNoReraise cenv freesOpt body // Check the body of the lambda if isTop && not g.compilingFSharpCore && isByrefLikeTy g m bodyTy then @@ -1775,83 +1775,83 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa CheckExprNoByrefs cenv env body // Check byref return types - if cenv.reportErrors then + if cenv.reportErrors then if not isTop then - CheckForByrefLikeType cenv env m bodyTy (fun () -> + CheckForByrefLikeType cenv env m bodyTy (fun () -> errorR(Error(FSComp.SR.chkFirstClassFuncNoByref(), m))) - elif not g.compilingFSharpCore && isByrefTy g bodyTy then + elif not g.compilingFSharpCore && isByrefTy g bodyTy then // check no byrefs-in-the-byref - CheckForByrefType cenv env (destByrefTy g bodyTy) (fun () -> + CheckForByrefType cenv env (destByrefTy g bodyTy) (fun () -> errorR(Error(FSComp.SR.chkReturnTypeNoByref(), m))) - for tp in tps do - if tp.Constraints |> List.sumBy (function TyparConstraint.CoercesTo(ty, _) when isClassTy g ty -> 1 | _ -> 0) > 1 then + for tp in tps do + if tp.Constraints |> List.sumBy (function TyparConstraint.CoercesTo(ty, _) when isClassTy g ty -> 1 | _ -> 0) > 1 then errorR(Error(FSComp.SR.chkTyparMultipleClassConstraints(), m)) NoLimit - + // This path is for expression bindings that are not actually lambdas - | _ -> + | _ -> let m = mOrig // Permit byrefs for let x = ... CheckTypeNoInnerByrefs cenv env m ety - let limit = + let limit = if not inlined && (isByrefLikeTy g m ety || isNativePtrTy g ety) then - // allow byref to occur as RHS of byref binding. + // allow byref to occur as RHS of byref binding. CheckExpr cenv env expr ctxt - else + else CheckExprNoByrefs cenv env expr NoLimit - if alwaysCheckNoReraise then + if alwaysCheckNoReraise then CheckNoReraise cenv None expr limit and CheckExprs cenv env exprs ctxts : Limit = - let ctxts = Array.ofList ctxts - let argArity i = if i < ctxts.Length then ctxts[i] else PermitByRefExpr.No - exprs - |> List.mapi (fun i exp -> CheckExpr cenv env exp (argArity i)) + 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)) |> CombineLimits -and CheckExprsNoByRefLike cenv env exprs : Limit = +and CheckExprsNoByRefLike cenv env exprs : Limit = for expr in exprs do CheckExprNoByrefs cenv env expr NoLimit -and CheckExprsPermitByRefLike cenv env exprs : Limit = - exprs +and CheckExprsPermitByRefLike cenv env exprs : Limit = + exprs |> List.map (CheckExprPermitByRefLike cenv env) |> CombineLimits -and CheckExprPermitByRefLike cenv env expr : Limit = +and CheckExprPermitByRefLike cenv env expr : Limit = CheckExpr cenv env expr PermitByRefExpr.Yes -and CheckExprPermitReturnableByRef cenv env expr : Limit = +and CheckExprPermitReturnableByRef cenv env expr : Limit = CheckExpr cenv env expr PermitByRefExpr.YesReturnable -and CheckDecisionTreeTargets cenv env targets ctxt = - targets - |> Array.map (CheckDecisionTreeTarget cenv env ctxt) +and CheckDecisionTreeTargets cenv env targets ctxt = + targets + |> Array.map (CheckDecisionTreeTarget cenv env ctxt) |> List.ofArray |> CombineLimits -and CheckDecisionTreeTarget cenv env ctxt (TTarget(vs, targetExpr, _)) = - BindVals cenv env vs +and CheckDecisionTreeTarget cenv env 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 and CheckDecisionTree cenv env dtree = - match dtree with - | TDSuccess (resultExprs, _) -> + match dtree with + | TDSuccess (resultExprs, _) -> CheckExprsNoByRefLike cenv env resultExprs |> ignore - | TDBind(bind, rest) -> + | TDBind(bind, rest) -> CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore - CheckDecisionTree cenv env rest - | TDSwitch (inpExpr, cases, dflt, m) -> + CheckDecisionTree cenv env rest + | TDSwitch (inpExpr, cases, dflt, m) -> CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = @@ -1859,7 +1859,7 @@ and CheckDecisionTreeSwitch cenv env (inpExpr, cases, dflt, m) = for (TCase(discrim, dtree)) in cases do CheckDecisionTreeTest cenv env m discrim CheckDecisionTree cenv env dtree - dflt |> Option.iter (CheckDecisionTree cenv env) + dflt |> Option.iter (CheckDecisionTree cenv env) and CheckDecisionTreeTest cenv env m discrim = match discrim with @@ -1877,25 +1877,25 @@ and CheckAttrib cenv env (Attrib(tcref, _, args, props, _, _, m)) = props |> List.iter (fun (AttribNamedArg(_, _, _, expr)) -> CheckAttribExpr cenv env expr) args |> List.iter (CheckAttribExpr cenv env) -and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = +and CheckAttribExpr cenv env (AttribExpr(expr, vexpr)) = CheckExprNoByrefs cenv env expr CheckExprNoByrefs cenv env vexpr - CheckNoReraise cenv None expr + CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr -and CheckAttribArgExpr cenv env expr = +and CheckAttribArgExpr cenv env expr = let g = cenv.g - match expr with + match expr with - // Detect standard constants - | Expr.Const (c, m, _) -> - match c with - | Const.Bool _ - | Const.Int32 _ + // Detect standard constants + | Expr.Const (c, m, _) -> + match c with + | Const.Bool _ + | Const.Int32 _ | Const.SByte _ | Const.Int16 _ | Const.Int32 _ - | Const.Int64 _ + | Const.Int64 _ | Const.Byte _ | Const.UInt16 _ | Const.UInt32 _ @@ -1905,56 +1905,56 @@ and CheckAttribArgExpr cenv env expr = | Const.Char _ | Const.Zero | Const.String _ -> () - | _ -> - if cenv.reportErrors then + | _ -> + if cenv.reportErrors then errorR (Error (FSComp.SR.tastNotAConstantExpression(), m)) - - | Expr.Op (TOp.Array, [_elemTy], args, _m) -> + + | Expr.Op (TOp.Array, [_elemTy], args, _m) -> List.iter (CheckAttribArgExpr cenv env) args - | TypeOfExpr g _ -> + | TypeOfExpr g _ -> () - | TypeDefOfExpr g _ -> + | TypeDefOfExpr g _ -> () - | Expr.Op (TOp.Coerce, _, [arg], _) -> + | Expr.Op (TOp.Coerce, _, [arg], _) -> CheckAttribArgExpr cenv env arg - | EnumExpr g arg1 -> + | EnumExpr g arg1 -> CheckAttribArgExpr cenv env arg1 | AttribBitwiseOrExpr g (arg1, arg2) -> CheckAttribArgExpr cenv env arg1 CheckAttribArgExpr cenv env arg2 - | _ -> - if cenv.reportErrors then + | _ -> + if cenv.reportErrors then errorR (Error (FSComp.SR.chkInvalidCustAttrVal(), expr.Range)) - -and CheckAttribs cenv env (attribs: Attribs) = + +and CheckAttribs cenv env (attribs: Attribs) = if isNil attribs then () else let tcrefs = [ for Attrib(tcref, _, _, _, gs, _, m) in attribs -> (tcref, gs, m) ] // Check for violations of allowMultiple = false - let duplicates = + let duplicates = tcrefs |> Seq.groupBy (fun (tcref, gs, _) -> // Don't allow CompiledNameAttribute on both a property and its getter/setter (see E_CompiledName test) if tyconRefEq cenv.g cenv.g.attrib_CompiledNameAttribute.TyconRef tcref then (tcref.Stamp, false) else - (tcref.Stamp, gs)) - |> Seq.map (fun (_, elems) -> List.last (List.ofSeq elems), Seq.length elems) - |> Seq.filter (fun (_, count) -> count > 1) - |> Seq.map fst + (tcref.Stamp, gs)) + |> Seq.map (fun (_, elems) -> List.last (List.ofSeq elems), Seq.length elems) + |> Seq.filter (fun (_, count) -> count > 1) + |> Seq.map fst |> Seq.toList // Filter for allowMultiple = false |> List.filter (fun (tcref, _, m) -> TryFindAttributeUsageAttribute cenv.g m tcref <> Some true) - if cenv.reportErrors then + if cenv.reportErrors then for tcref, _, m in duplicates do errorR(Error(FSComp.SR.chkAttrHasAllowMultiFalse(tcref.DisplayName), m)) - - attribs |> List.iter (CheckAttrib cenv env) + + attribs |> List.iter (CheckAttrib cenv env) and CheckValInfo cenv env (ValReprInfo(_, args, ret)) = args |> List.iterSquared (CheckArgInfo cenv env) ret |> CheckArgInfo cenv env -and CheckArgInfo cenv env (argInfo : ArgReprInfo) = +and CheckArgInfo cenv env (argInfo : ArgReprInfo) = CheckAttribs cenv env argInfo.Attribs and CheckValSpecAux permitByRefLike cenv env (v: Val) onInnerByrefError = @@ -1966,12 +1966,12 @@ and CheckValSpec permitByRefLike cenv env v = CheckValSpecAux permitByRefLike cenv env v (fun () -> errorR(Error(FSComp.SR.chkErrorUseOfByref(), v.Range))) and AdjustAccess isHidden (cpath: unit -> CompilationPath) access = - if isHidden then + if isHidden then let (TAccess l) = access // FSharp 1.0 bug 1908: Values hidden by signatures are implicitly at least 'internal' let scoref = cpath().ILScopeRef TAccess(CompPath(scoref, []) :: l) - else + else access and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : Limit = @@ -1983,14 +1983,14 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin let env = { env with external = env.external || g.attrib_DllImportAttribute |> Option.exists (fun attr -> HasFSharpAttribute g attr v.Attribs) } // Check that active patterns don't have free type variables in their result - match TryGetActivePatternInfo vref with - | Some _apinfo when _apinfo.ActiveTags.Length > 1 -> + match TryGetActivePatternInfo vref with + | Some _apinfo when _apinfo.ActiveTags.Length > 1 -> if doesActivePatternHaveFreeTypars g vref then errorR(Error(FSComp.SR.activePatternChoiceHasFreeTypars(v.LogicalName), v.Range)) | _ -> () - + match cenv.potentialUnboundUsesOfVals.TryFind v.Stamp with - | None -> () + | None -> () | Some m -> let nm = v.DisplayName errorR(Error(FSComp.SR.chkMemberUsedInInvalidWay(nm, nm, stringOfRange m), v.Range)) @@ -2000,93 +2000,93 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin v.ValReprInfo |> Option.iter (CheckValInfo cenv env) // Check accessibility - if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then + if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then let access = AdjustAccess (IsHiddenVal env.sigToImplRemapInfo v) (fun () -> v.DeclaringEntity.CompilationPath) v.Accessibility CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access v.Range v.Type - - if cenv.reportErrors then + + if cenv.reportErrors then // Check top-level let-bound values match bind.Var.ValReprInfo with - | Some info when info.HasNoArgs -> + | Some info when info.HasNoArgs -> CheckForByrefLikeType cenv env v.Range v.Type (fun () -> errorR(Error(FSComp.SR.chkNoByrefAsTopValue(), v.Range))) | _ -> () match v.PublicPath with | None -> () | _ -> - if + if // Don't support implicit [] on generated members, except the implicit members // for 'let' bound functions in classes. (not v.IsCompilerGenerated || v.IsIncrClassGeneratedMember) && - + (// Check the attributes on any enclosing module - env.reflect || + env.reflect || // Check the attributes on the value HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.Attribs || - // Also check the enclosing type for members - for historical reasons, in the TAST member values + // Also check the enclosing type for members - for historical reasons, in the TAST member values // are stored in the entity that encloses the type, hence we will not have noticed the ReflectedDefinition // on the enclosing type at this point. - HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then + HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then if v.IsInstanceMember && v.MemberApparentEntity.IsStructOrEnumTycon then errorR(Error(FSComp.SR.chkNoReflectedDefinitionOnStructMember(), v.Range)) cenv.usesQuotations <- true - // If we've already recorded a definition then skip this - match v.ReflectedDefinition with + // If we've already recorded a definition then skip this + match v.ReflectedDefinition with | None -> v.SetValDefn bindRhs | Some _ -> () // Run the conversion process over the reflected definition to report any errors in the // front end rather than the back end. We currently re-run this during ilxgen.fs but there's - // no real need for that except that it helps us to bundle all reflected definitions up into + // no real need for that except that it helps us to bundle all reflected definitions up into // one blob for pickling to the binary format try - let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.Yes) + let qscope = QuotationTranslator.QuotationGenerationScope.Create (g, cenv.amap, cenv.viewCcu, cenv.tcVal, QuotationTranslator.IsReflectedDefinition.Yes) let methName = v.CompiledName g.CompilerGlobalState QuotationTranslator.ConvReflectedDefinition qscope methName v bindRhs |> ignore - + let _, _, exprSplices = qscope.Close() - if not (isNil exprSplices) then + if not (isNil exprSplices) then errorR(Error(FSComp.SR.chkReflectedDefCantSplice(), v.Range)) - with - | QuotationTranslator.InvalidQuotedTerm e -> + with + | QuotationTranslator.InvalidQuotedTerm e -> errorR e - - match v.MemberInfo with - | Some memberInfo when not v.IsIncrClassGeneratedMember -> - match memberInfo.MemberFlags.MemberKind with + + match v.MemberInfo with + | Some memberInfo when not v.IsIncrClassGeneratedMember -> + match memberInfo.MemberFlags.MemberKind with | SynMemberKind.PropertySet | SynMemberKind.PropertyGet -> // These routines raise errors for ill-formed properties v |> ReturnTypeOfPropertyVal g |> ignore v |> ArgInfosOfPropertyVal g |> ignore | _ -> () - + | _ -> () - - let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData + + 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 // unless warning is suppressed (user must know what they're doing). // // If the method has ResumableCode return attribute we check the body w.r.t. that - let env = + let env = if cenv.reportErrors && isReturnsResumableCodeTy g v.TauType then if not (g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines) then error(Error(FSComp.SR.tcResumableCodeNotSupported(), bind.Var.Range)) - if not v.MustInline then + if not v.MustInline then warning(Error(FSComp.SR.tcResumableCodeFunctionMustBeInline(), v.Range)) - if isReturnsResumableCodeTy g v.TauType then - { env with resumableCode = Resumable.ResumableExpr false } + if isReturnsResumableCodeTy g v.TauType then + { env with resumableCode = Resumable.ResumableExpr false } else env CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt -and CheckBindings cenv env binds = +and CheckBindings cenv env binds = for bind in binds do CheckBinding cenv env false PermitByRefExpr.Yes bind |> ignore @@ -2094,76 +2094,76 @@ and CheckBindings cenv env binds = let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = let g = cenv.g let isExplicitEntryPoint = HasFSharpAttribute g g.attrib_EntryPointAttribute v.Attribs - if isExplicitEntryPoint then + if isExplicitEntryPoint then cenv.entryPointGiven <- true let isLastCompiland = fst cenv.isLastCompiland - if not isLastCompiland && cenv.reportErrors then - errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) + if not isLastCompiland && cenv.reportErrors then + errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition if // Mutable values always have fields - not v.IsMutable && + not v.IsMutable && // Literals always have fields - not (HasFSharpAttribute g g.attrib_LiteralAttribute v.Attribs) && - not (HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute v.Attribs) && - not (HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute v.Attribs) && + not (HasFSharpAttribute g g.attrib_LiteralAttribute v.Attribs) && + not (HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute v.Attribs) && + not (HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute v.Attribs) && // Having a field makes the binding a static initialization trigger - IsSimpleSyntacticConstantExpr g e && + IsSimpleSyntacticConstantExpr g e && // Check the thing is actually compiled as a property IsCompiledAsStaticProperty g v || (g.compilingFSharpCore && v.Attribs |> List.exists(fun (Attrib(tc, _, _, _, _, _, _)) -> tc.CompiledName = "ValueAsStaticPropertyAttribute")) - then + then v.SetIsCompiledAsStaticPropertyWithoutField() // Check for value name clashes begin - try + try // Skip compiler generated values if v.IsCompilerGenerated then () else // Skip explicit implementations of interface methods if ValIsExplicitImpl g v then () else - - match v.TryDeclaringEntity with + + match v.TryDeclaringEntity with | ParentNone -> () // this case can happen after error recovery from earlier error - | Parent _ -> - let tcref = v.DeclaringEntity - let hasDefaultAugmentation = + | Parent _ -> + let tcref = v.DeclaringEntity + let hasDefaultAugmentation = tcref.IsUnionTycon && match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with | Some(Attrib(_, _, [ AttribBoolArg b ], _, _, _, _)) -> b | _ -> true (* not hiddenRepr *) let kind = (if v.IsMember then "member" else "value") - let check skipValCheck nm = - if not skipValCheck && - v.IsModuleBinding && - tcref.ModuleOrNamespaceType.AllValsByLogicalName.ContainsKey nm && + let check skipValCheck nm = + if not skipValCheck && + v.IsModuleBinding && + tcref.ModuleOrNamespaceType.AllValsByLogicalName.ContainsKey nm && not (valEq tcref.ModuleOrNamespaceType.AllValsByLogicalName[nm] v) then - + error(Duplicate(kind, v.DisplayName, v.Range)) #if CASES_IN_NESTED_CLASS - if tcref.IsUnionTycon && nm = "Cases" then + if tcref.IsUnionTycon && nm = "Cases" then errorR(NameClash(nm, kind, v.DisplayName, v.Range, "generated type", "Cases", tcref.Range)) #endif - if tcref.IsUnionTycon then - match nm with + if tcref.IsUnionTycon then + match nm with | "Tag" -> errorR(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.typeInfoGeneratedProperty(), "Tag", tcref.Range)) | "Tags" -> errorR(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.typeInfoGeneratedType(), "Tags", tcref.Range)) | _ -> - if hasDefaultAugmentation then - match tcref.GetUnionCaseByName nm with + if hasDefaultAugmentation then + match tcref.GetUnionCaseByName nm with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.typeInfoUnionCase(), uc.DisplayName, uc.Range)) | None -> () - let hasNoArgs = - match v.ValReprInfo with - | None -> false + let hasNoArgs = + match v.ValReprInfo with + | None -> false | Some arity -> List.sum arity.AritiesOfArgs - v.NumObjArgs <= 0 && arity.NumTypars = 0 - // In unions user cannot define properties that clash with generated ones - if tcref.UnionCasesArray.Length = 1 && hasNoArgs then + // In unions user cannot define properties that clash with generated ones + if tcref.UnionCasesArray.Length = 1 && hasNoArgs then let ucase1 = tcref.UnionCasesArray[0] for f in ucase1.RecdFieldsArray do if f.LogicalName = nm then @@ -2172,18 +2172,18 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = // Default augmentation contains the nasty 'Case' etc. let prefix = "New" if nm.StartsWithOrdinal prefix then - match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with + match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseCompiledForm(), uc.DisplayName, uc.Range)) | None -> () // Default augmentation contains the nasty 'Is' etc. let prefix = "Is" if nm.StartsWithOrdinal prefix && hasDefaultAugmentation then - match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with + match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(), uc.DisplayName, uc.Range)) | None -> () - match tcref.GetFieldByName nm with + match tcref.GetFieldByName nm with | Some rf -> error(NameClash(nm, kind, v.DisplayName, v.Range, "field", rf.LogicalName, rf.Range)) | None -> () @@ -2192,27 +2192,27 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = check false (v.CompiledName cenv.g.CompilerGlobalState) // Check if an F# extension member clashes - if v.IsExtensionMember then - tcref.ModuleOrNamespaceType.AllValsAndMembersByLogicalNameUncached[v.LogicalName] |> List.iter (fun v2 -> + if v.IsExtensionMember then + tcref.ModuleOrNamespaceType.AllValsAndMembersByLogicalNameUncached[v.LogicalName] |> List.iter (fun v2 -> if v2.IsExtensionMember && not (valEq v v2) && (v.CompiledName cenv.g.CompilerGlobalState) = (v2.CompiledName cenv.g.CompilerGlobalState) then let minfo1 = FSMeth(g, generalizedTyconRef g tcref, mkLocalValRef v, Some 0UL) let minfo2 = FSMeth(g, generalizedTyconRef g tcref, mkLocalValRef v2, Some 0UL) - if tyconRefEq g v.MemberApparentEntity v2.MemberApparentEntity && - MethInfosEquivByNameAndSig EraseAll true g cenv.amap v.Range minfo1 minfo2 then + if tyconRefEq g v.MemberApparentEntity v2.MemberApparentEntity && + MethInfosEquivByNameAndSig EraseAll true g cenv.amap v.Range minfo1 minfo2 then errorR(Duplicate(kind, v.DisplayName, v.Range))) // Properties get 'get_X', only if there are no args // Properties get 'get_X' - match v.ValReprInfo with + match v.ValReprInfo with | Some arity when arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("get_" + v.DisplayName) | _ -> () - match v.ValReprInfo with + match v.ValReprInfo with | Some arity when v.IsMutable && arity.NumCurriedArgs = 0 && arity.NumTypars = 0 -> check false ("set_" + v.DisplayName) | _ -> () - match TryChopPropertyName v.DisplayName with - | Some res -> check true res + match TryChopPropertyName v.DisplayName with + | Some res -> check true res | None -> () - with e -> errorRecovery e v.Range + with e -> errorRecovery e v.Range end CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore @@ -2221,26 +2221,26 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = // check tycons //-------------------------------------------------------------------------- -let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = +let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = let g = cenv.g let tcref = mkLocalTyconRef tycon let m = rfield.Range let fieldTy = stripTyEqns cenv.g rfield.FormalType - let isHidden = - IsHiddenTycon env.sigToImplRemapInfo tycon || - IsHiddenTyconRepr env.sigToImplRemapInfo tycon || + let isHidden = + IsHiddenTycon env.sigToImplRemapInfo tycon || + IsHiddenTyconRepr env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility CheckTypeForAccess cenv env (fun () -> rfield.LogicalName) access m fieldTy - if isByrefLikeTyconRef g m tcref then + if isByrefLikeTyconRef g m tcref then // Permit Span fields in IsByRefLike types CheckTypePermitSpanLike cenv env m fieldTy if cenv.reportErrors then CheckForByrefType cenv env fieldTy (fun () -> errorR(Error(FSComp.SR.chkCantStoreByrefValue(), tycon.Range))) else CheckTypeNoByrefs cenv env m fieldTy - if cenv.reportErrors then + if cenv.reportErrors then CheckForByrefLikeType cenv env m fieldTy (fun () -> errorR(Error(FSComp.SR.chkCantStoreByrefValue(), tycon.Range))) CheckAttribs cenv env rfield.PropertyAttribs @@ -2251,7 +2251,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = if tycon.IsProvidedGeneratedTycon then () else #endif let g = cenv.g - let m = tycon.Range + let m = tycon.Range let tcref = mkLocalTyconRef tycon let ty = generalizedTyconRef g tcref @@ -2268,9 +2268,9 @@ let CheckEntityDefn cenv env (tycon: Entity) = if not tycon.IsTypeAbbrev then - let allVirtualMethsInParent = - match GetSuperTypeOfType g cenv.amap m ty with - | Some superTy -> + let allVirtualMethsInParent = + match GetSuperTypeOfType g cenv.amap m ty with + | Some superTy -> GetIntrinsicMethInfosOfType cenv.infoReader None AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m superTy |> List.filter (fun minfo -> minfo.IsVirtual) | None -> [] @@ -2282,7 +2282,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = then MethInfosEquivByNameAndSig eraseFlag true g cenv.amap m minfo minfo2 else MethInfosEquivByNameAndPartialSig eraseFlag true g cenv.amap m minfo minfo2 (* partial ignores return type *) - let immediateMeths = + let immediateMeths = [ for v in tycon.AllGeneratedValues do yield FSMeth (g, ty, v, None) yield! GetImmediateIntrinsicMethInfosOfType (None, AccessibleFromSomewhere) g cenv.amap m ty ] @@ -2292,24 +2292,24 @@ let CheckEntityDefn cenv env (tycon: Entity) = match hash.TryGetValue nm with | true, h -> h | _ -> [] - + // precompute methods grouped by MethInfo.LogicalName - let hashOfImmediateMeths = + let hashOfImmediateMeths = let h = Dictionary() for minfo in immediateMeths do match h.TryGetValue minfo.LogicalName with - | true, methods -> + | true, methods -> h[minfo.LogicalName] <- minfo :: methods - | false, _ -> + | false, _ -> h[minfo.LogicalName] <- [minfo] h - let getOtherMethods (minfo : MethInfo) = + let getOtherMethods (minfo : MethInfo) = [ //we have added all methods to the dictionary on the previous step let methods = hashOfImmediateMeths[minfo.LogicalName] for m in methods do // use referential identity to filter out 'minfo' method - if not(Object.ReferenceEquals(m, minfo)) then + if not(Object.ReferenceEquals(m, minfo)) then yield m ] @@ -2319,34 +2319,34 @@ let CheckEntityDefn cenv env (tycon: Entity) = let m = (match minfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) let others = getOtherMethods minfo // abstract/default pairs of duplicate methods are OK - let IsAbstractDefaultPair (x: MethInfo) (y: MethInfo) = + let IsAbstractDefaultPair (x: MethInfo) (y: MethInfo) = x.IsDispatchSlot && y.IsDefiniteFSharpOverride - let IsAbstractDefaultPair2 (minfo: MethInfo) (minfo2: MethInfo) = + let IsAbstractDefaultPair2 (minfo: MethInfo) (minfo2: MethInfo) = IsAbstractDefaultPair minfo minfo2 || IsAbstractDefaultPair minfo2 minfo let checkForDup erasureFlag (minfo2: MethInfo) = not (IsAbstractDefaultPair2 minfo minfo2) && (minfo.IsInstance = minfo2.IsInstance) && MethInfosEquivWrtUniqueness erasureFlag m minfo minfo2 - if others |> List.exists (checkForDup EraseAll) then - if others |> List.exists (checkForDup EraseNone) then + if others |> List.exists (checkForDup EraseAll) then + if others |> List.exists (checkForDup EraseNone) then errorR(Error(FSComp.SR.chkDuplicateMethod(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) else errorR(Error(FSComp.SR.chkDuplicateMethodWithSuffix(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) let numCurriedArgSets = minfo.NumArgs.Length - if numCurriedArgSets > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then + if numCurriedArgSets > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then errorR(Error(FSComp.SR.chkDuplicateMethodCurried(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) - if numCurriedArgSets > 1 && - (minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) - |> List.existsSquared (fun (ParamData(isParamArrayArg, _isInArg, isOutArg, optArgInfo, callerInfo, _, reflArgInfo, ty)) -> - isParamArrayArg || isOutArg || reflArgInfo.AutoQuote || optArgInfo.IsOptional || callerInfo <> NoCallerInfo || isByrefLikeTy g m ty)) then + if numCurriedArgSets > 1 && + (minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) + |> List.existsSquared (fun (ParamData(isParamArrayArg, _isInArg, isOutArg, optArgInfo, callerInfo, _, reflArgInfo, ty)) -> + isParamArrayArg || isOutArg || reflArgInfo.AutoQuote || optArgInfo.IsOptional || callerInfo <> NoCallerInfo || isByrefLikeTy g m ty)) then errorR(Error(FSComp.SR.chkCurriedMethodsCantHaveOutParams(), m)) if numCurriedArgSets = 1 then - minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) + minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) |> List.iterSquared (fun (ParamData(_, isInArg, _, optArgInfo, callerInfo, _, _, ty)) -> ignore isInArg match (optArgInfo, callerInfo) with @@ -2370,46 +2370,46 @@ let CheckEntityDefn cenv env (tycon: Entity) = | CalleeSide, CallerMemberName -> if not ((isOptionTy g ty) && (typeEquiv g g.string_ty (destOptionTy g ty))) then errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfo.ToString(), "string", NicePrint.minimalStringOfType cenv.denv (destOptionTy g ty)), m))) - + for pinfo in immediateProps do let nm = pinfo.PropertyName - let m = - match pinfo.ArbitraryValRef with - | None -> m + let m = + match pinfo.ArbitraryValRef with + | None -> m | Some vref -> vref.DefinitionRange - if hashOfImmediateMeths.ContainsKey nm then + if hashOfImmediateMeths.ContainsKey nm then errorR(Error(FSComp.SR.chkPropertySameNameMethod(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) let others = getHash hashOfImmediateProps nm - if pinfo.HasGetter && pinfo.HasSetter && pinfo.GetterMethod.IsVirtual <> pinfo.SetterMethod.IsVirtual then + if pinfo.HasGetter && pinfo.HasSetter && pinfo.GetterMethod.IsVirtual <> pinfo.SetterMethod.IsVirtual then errorR(Error(FSComp.SR.chkGetterSetterDoNotMatchAbstract(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) - let checkForDup erasureFlag pinfo2 = + let checkForDup erasureFlag pinfo2 = // abstract/default pairs of duplicate properties are OK - let IsAbstractDefaultPair (x: PropInfo) (y: PropInfo) = + let IsAbstractDefaultPair (x: PropInfo) (y: PropInfo) = x.IsDispatchSlot && y.IsDefiniteFSharpOverride not (IsAbstractDefaultPair pinfo pinfo2 || IsAbstractDefaultPair pinfo2 pinfo) && PropInfosEquivByNameAndPartialSig erasureFlag g cenv.amap m pinfo pinfo2 (* partial ignores return type *) if others |> List.exists (checkForDup EraseAll) then - if others |> List.exists (checkForDup EraseNone) then + if others |> List.exists (checkForDup EraseNone) then errorR(Error(FSComp.SR.chkDuplicateProperty(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) else errorR(Error(FSComp.SR.chkDuplicatePropertyWithSuffix(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) // Check to see if one is an indexer and one is not - if ( (pinfo.HasGetter && - pinfo.HasSetter && + if ( (pinfo.HasGetter && + pinfo.HasSetter && let setterArgs = pinfo.DropGetter().GetParamTypes(cenv.amap, m) let getterArgs = pinfo.DropSetter().GetParamTypes(cenv.amap, m) setterArgs.Length <> getterArgs.Length) - || + || (let nargs = pinfo.GetParamTypes(cenv.amap, m).Length - others |> List.exists (fun pinfo2 -> (isNil(pinfo2.GetParamTypes(cenv.amap, m))) <> (nargs = 0)))) then - + others |> List.exists (fun pinfo2 -> (isNil(pinfo2.GetParamTypes(cenv.amap, m))) <> (nargs = 0)))) then + errorR(Error(FSComp.SR.chkPropertySameNameIndexer(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) // Check to see if the signatures of the both getter and the setter imply the same property type @@ -2421,7 +2421,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = errorR(Error(FSComp.SR.chkGetterAndSetterHaveSamePropertyType(pinfo.PropertyName, NicePrint.minimalStringOfType cenv.denv ty1, NicePrint.minimalStringOfType cenv.denv ty2), m)) hashOfImmediateProps[nm] <- pinfo :: others - + if not (isInterfaceTy g ty) then let hashOfAllVirtualMethsInParent = Dictionary() for minfo in allVirtualMethsInParent do @@ -2432,192 +2432,192 @@ let CheckEntityDefn cenv env (tycon: Entity) = if not minfo.IsDispatchSlot && not minfo.IsVirtual && minfo.IsInstance then let nm = minfo.LogicalName let m = (match minfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) - let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm + let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm let checkForDup erasureFlag (minfo2: MethInfo) = minfo2.IsDispatchSlot && MethInfosEquivByNameAndSig erasureFlag true g cenv.amap m minfo minfo2 match parentMethsOfSameName |> List.tryFind (checkForDup EraseAll) with | None -> () | Some minfo -> let mtext = NicePrint.stringOfMethInfo cenv.infoReader m cenv.denv minfo - if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then + if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then warning(Error(FSComp.SR.tcNewMemberHidesAbstractMember mtext, m)) else warning(Error(FSComp.SR.tcNewMemberHidesAbstractMemberWithSuffix mtext, m)) - + if minfo.IsDispatchSlot then let nm = minfo.LogicalName let m = (match minfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) - let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm + let parentMethsOfSameName = getHash hashOfAllVirtualMethsInParent nm let checkForDup erasureFlag minfo2 = MethInfosEquivByNameAndSig erasureFlag true g cenv.amap m minfo minfo2 - + if parentMethsOfSameName |> List.exists (checkForDup EraseAll) then - if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then + if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then errorR(Error(FSComp.SR.chkDuplicateMethodInheritedType nm, m)) else errorR(Error(FSComp.SR.chkDuplicateMethodInheritedTypeWithSuffix nm, m)) - if TyconRefHasAttributeByName m tname_IsByRefLikeAttribute tcref && not tycon.IsStructOrEnumTycon then + if TyconRefHasAttributeByName m tname_IsByRefLikeAttribute tcref && not tycon.IsStructOrEnumTycon then errorR(Error(FSComp.SR.tcByRefLikeNotStruct(), tycon.Range)) - if TyconRefHasAttribute g m g.attrib_IsReadOnlyAttribute tcref && not tycon.IsStructOrEnumTycon then + if TyconRefHasAttribute g m g.attrib_IsReadOnlyAttribute tcref && not tycon.IsStructOrEnumTycon then errorR(Error(FSComp.SR.tcIsReadOnlyNotStruct(), tycon.Range)) - // Considers TFSharpObjectRepr, TFSharpRecdRepr and TFSharpUnionRepr. + // Considers TFSharpObjectRepr, TFSharpRecdRepr and TFSharpUnionRepr. // [Review] are all cases covered: TILObjectRepr, TAsmRepr. [Yes - these are FSharp.Core.dll only] tycon.AllFieldsArray |> Array.iter (CheckRecdField false cenv env tycon) - + // Abstract slots can have byref arguments and returns - for vref in abstractSlotValsOfTycons [tycon] do - match vref.ValReprInfo with - | Some valReprInfo -> + for vref in abstractSlotValsOfTycons [tycon] do + match vref.ValReprInfo with + | Some valReprInfo -> let tps, argTysl, retTy, _ = GetValReprTypeInFSharpForm g valReprInfo vref.Type m let env = BindTypars g env tps - for argTys in argTysl do - for argTy, _ in argTys do + for argTys in argTysl do + for argTy, _ in argTys do CheckTypeNoInnerByrefs cenv env vref.Range argTy CheckTypeNoInnerByrefs cenv env vref.Range retTy | None -> () // Supported interface may not have byrefs - tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypeNoByrefs cenv env m) + tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypeNoByrefs cenv env m) - superOfTycon g tycon |> CheckTypeNoByrefs cenv env m + superOfTycon g tycon |> CheckTypeNoByrefs cenv env m - if tycon.IsUnionTycon then + if tycon.IsUnionTycon then for ucase in tycon.UnionCasesArray do - CheckAttribs cenv env ucase.Attribs + CheckAttribs cenv env ucase.Attribs ucase.RecdFieldsArray |> Array.iter (CheckRecdField true cenv env tycon) // Access checks let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility - let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty + let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty - abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) + abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) superOfTycon g tycon |> visitType // We do not have to check access of interface implementations. - if tycon.IsFSharpDelegateTycon then - match tycon.TypeReprInfo with + if tycon.IsFSharpDelegateTycon then + match tycon.TypeReprInfo with | TFSharpObjectRepr r -> - match r.fsobjmodel_kind with + match r.fsobjmodel_kind with | TFSharpDelegate ss -> - //ss.ClassTypars - //ss.MethodTypars + //ss.ClassTypars + //ss.MethodTypars ss.FormalReturnType |> Option.iter visitType ss.FormalParams |> List.iterSquared (fun (TSlotParam(_, ty, _, _, _, _)) -> visitType ty) | _ -> () | _ -> () - let interfaces = + let interfaces = AllSuperTypesOfType g cenv.amap tycon.Range AllowMultiIntfInstantiations.Yes ty |> List.filter (isInterfaceTy g) - - if tycon.IsFSharpInterfaceTycon then + + if tycon.IsFSharpInterfaceTycon then List.iter visitType interfaces // Check inherited interface is as accessible if not (isRecdOrStructTyconRefAssumedImmutable g tcref) && isRecdOrStructTyconRefReadOnly g m tcref then errorR(Error(FSComp.SR.readOnlyAttributeOnStructWithMutableField(), m)) - - if cenv.reportErrors then - if not tycon.IsTypeAbbrev then + + if cenv.reportErrors then + if not tycon.IsTypeAbbrev then let interfaces = GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g cenv.amap m ty |> List.collect (AllSuperTypesOfType g cenv.amap m AllowMultiIntfInstantiations.Yes) |> List.filter (isInterfaceTy g) CheckMultipleInterfaceInstantiations cenv ty interfaces false m - + // Check fields. We check these late because we have to have first checked that the structs are // free of cycles - if tycon.IsStructOrEnumTycon then + if tycon.IsStructOrEnumTycon then for f in tycon.AllInstanceFieldsAsList do - // Check if it's marked unsafe + // Check if it's marked unsafe let zeroInitUnsafe = TryFindFSharpBoolAttribute g g.attrib_DefaultValueAttribute f.FieldAttribs if zeroInitUnsafe = Some true then - if not (TypeHasDefaultValue g m ty) then + if not (TypeHasDefaultValue g m ty) then errorR(Error(FSComp.SR.chkValueWithDefaultValueMustHaveDefaultValue(), m)) // Check type abbreviations - match tycon.TypeAbbrev with + match tycon.TypeAbbrev with | None -> () - | Some ty -> + | Some ty -> // Library-defined outref<'T> and inref<'T> contain byrefs on the r.h.s. - if not g.compilingFSharpCore then + if not g.compilingFSharpCore then CheckForByrefType cenv env ty (fun () -> errorR(Error(FSComp.SR.chkNoByrefInTypeAbbrev(), tycon.Range))) -let CheckEntityDefns cenv env tycons = - tycons |> List.iter (CheckEntityDefn cenv env) +let CheckEntityDefns cenv env tycons = + tycons |> List.iter (CheckEntityDefn cenv env) //-------------------------------------------------------------------------- // check modules //-------------------------------------------------------------------------- -let rec CheckDefnsInModule cenv env mdefs = +let rec CheckDefnsInModule cenv env mdefs = for mdef in mdefs do CheckDefnInModule cenv env mdef and CheckNothingAfterEntryPoint cenv m = - if cenv.entryPointGiven && cenv.reportErrors then - errorR(Error(FSComp.SR.chkEntryPointUsage(), m)) + if cenv.entryPointGiven && cenv.reportErrors then + errorR(Error(FSComp.SR.chkEntryPointUsage(), m)) -and CheckDefnInModule cenv env mdef = - match mdef with - | TMDefRec(isRec, _opens, tycons, mspecs, m) -> +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) CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env) mspecs - | TMDefLet(bind, m) -> + | TMDefLet(bind, m) -> CheckNothingAfterEntryPoint cenv m - CheckModuleBinding cenv env bind + CheckModuleBinding cenv env bind BindVal cenv env bind.Var | TMDefOpens _ -> () - | TMDefDo(e, m) -> + | TMDefDo(e, m) -> CheckNothingAfterEntryPoint cenv m CheckNoReraise cenv None e CheckExprNoByrefs cenv env e - | TMDefs defs -> CheckDefnsInModule cenv env defs + | TMDefs defs -> CheckDefnsInModule cenv env defs and CheckModuleSpec cenv env mbind = - match mbind with + match mbind with | ModuleOrNamespaceBinding.Binding bind -> BindVals cenv env (valsOfBinds [bind]) CheckModuleBinding cenv env bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> CheckEntityDefn cenv env mspec let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } - CheckDefnInModule cenv env rhs + CheckDefnInModule cenv env rhs -let CheckImplFileContents cenv env implFileTy implFileContents = +let CheckImplFileContents cenv env implFileTy implFileContents = let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } UpdatePrettyTyparNames.updateModuleOrNamespaceType implFileTy CheckDefnInModule cenv env implFileContents - + let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, viewCcu, tcValF, denv, implFileTy, implFileContents, extraAttribs, isLastCompiland: bool*bool, isInternalTestSpanStackReferring) = - let cenv = - { g = g - reportErrors = reportErrors - boundVals = Dictionary<_, _>(100, HashIdentity.Structural) - limitVals = Dictionary<_, _>(100, HashIdentity.Structural) + let cenv = + { g = g + reportErrors = reportErrors + boundVals = Dictionary<_, _>(100, HashIdentity.Structural) + limitVals = Dictionary<_, _>(100, HashIdentity.Structural) stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile") - potentialUnboundUsesOfVals = Map.empty + potentialUnboundUsesOfVals = Map.empty anonRecdTypes = StampMap.Empty - usesQuotations = false - infoReader = infoReader + usesQuotations = false + infoReader = infoReader internalsVisibleToPaths = internalsVisibleToPaths - amap = amap - denv = denv + amap = amap + denv = denv viewCcu = viewCcu isLastCompiland = isLastCompiland isInternalTestSpanStackReferring = isInternalTestSpanStackReferring tcVal = tcValF 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. // See primEntityRefEq. @@ -2629,14 +2629,14 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v resolve g.system_ArgIterator_tcref resolve g.system_RuntimeArgumentHandle_tcref - let env = + let env = { sigToImplRemapInfo=[] quote=false boundTyparNames=[] argVals = ValMap.Empty boundTypars= TyparMap.Empty reflect=false - external=false + external=false returnScope = 0 isInAppExpr = false resumableCode = Resumable.None } @@ -2644,7 +2644,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v CheckImplFileContents cenv env implFileTy implFileContents CheckAttribs cenv env extraAttribs - if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then + if cenv.usesQuotations && not (QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(g).SupportsDeserializeEx) then viewCcu.UsesFSharp20PlusQuotations <- true cenv.entryPointGiven, cenv.anonRecdTypes