From 6e1d61414adb52073f2ed7623f48fe778c0c94f4 Mon Sep 17 00:00:00 2001 From: Gusty Date: Sun, 30 Oct 2016 22:30:58 +0100 Subject: [PATCH 1/3] Upgrade Trace class to support redo tupled with the existing undo --- src/fsharp/ConstraintSolver.fs | 67 +++++++++++----------------------- 1 file changed, 22 insertions(+), 45 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 4a985fe5b40..fbf7ba911b8 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -304,15 +304,19 @@ let BakedInTraitConstraintNames = // Run the constraint solver with undo (used during method overload resolution) type Trace = - { mutable actions: (unit -> unit) list } + { mutable actions: ((unit -> unit) * (unit -> unit)) list } static member New () = { actions = [] } - member t.Undo () = List.iter (fun a -> a ()) t.actions - member t.Push f = t.actions <- f :: t.actions + member t.Undo () = List.iter (fun (_, a) -> a ()) t.actions + member t.Push f undo = t.actions <- (f, undo) :: t.actions type OptionalTrace = | NoTrace | WithTrace of Trace member x.HasTrace = match x with NoTrace -> false | WithTrace _ -> true + member t.Exec f undo = + match t with + | WithTrace trace -> trace.Push f undo; f() + | NoTrace -> f() let CollectThenUndo f = @@ -411,16 +415,13 @@ let SubstMeasure (r:Typar) ms = | None -> tp.typar_solution <- Some (TType_measure ms) | Some _ -> error(InternalError("already solved",r.Range)); -let rec TransactStaticReq (csenv:ConstraintSolverEnv) trace (tpr:Typar) req = +let rec TransactStaticReq (csenv:ConstraintSolverEnv) (trace:OptionalTrace) (tpr:Typar) req = let m = csenv.m if (tpr.Rigidity.ErrorIfUnified && tpr.StaticReq <> req) then ErrorD(ConstraintSolverError(FSComp.SR.csTypeCannotBeResolvedAtCompileTime(tpr.Name),m,m)) else let orig = tpr.StaticReq - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> tpr.SetStaticReq orig) - tpr.SetStaticReq req; + trace.Exec (fun () -> tpr.SetStaticReq req) (fun () -> tpr.SetStaticReq orig) CompleteD and SolveTypStaticReqTypar (csenv:ConstraintSolverEnv) trace req (tpr:Typar) = @@ -444,12 +445,9 @@ and SolveTypStaticReq (csenv:ConstraintSolverEnv) trace req ty = SolveTypStaticReqTypar csenv trace req tpr else CompleteD -let rec TransactDynamicReq trace (tpr:Typar) req = +let rec TransactDynamicReq (trace:OptionalTrace) (tpr:Typar) req = let orig = tpr.DynamicReq - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> tpr.SetDynamicReq orig) - tpr.SetDynamicReq req; + trace.Exec (fun () -> tpr.SetDynamicReq req) (fun () -> tpr.SetDynamicReq orig) CompleteD and SolveTypDynamicReq (csenv:ConstraintSolverEnv) trace req ty = @@ -654,7 +652,7 @@ let CheckWarnIfRigid (csenv:ConstraintSolverEnv) ty1 (r:Typar) ty = /// Add the constraint "ty1 = ty" to the constraint problem, where ty1 is a type variable. /// Propagate all effects of adding this constraint, e.g. to solve other variables -let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty = +let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace:OptionalTrace) ty1 ty = let m = csenv.m DepthCheck ndeep m ++ (fun () -> @@ -673,10 +671,7 @@ let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty = // We may need to make use of the equation when solving the constraints. // Record a entry in the undo trace if one is provided let tpdata = r.Data - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> tpdata.typar_solution <- None) - tpdata.typar_solution <- Some ty; + trace.Exec (fun () -> tpdata.typar_solution <- Some ty) (fun () -> tpdata.typar_solution <- None) (* dprintf "setting typar %d to type %s at %a\n" r.Stamp ((DebugPrint.showType ty)) outputRange m; *) @@ -1354,12 +1349,9 @@ and MemberConstraintSolutionOfRecdFieldInfo rfinfo isSet = FSRecdFieldSln(rfinfo.TypeInst,rfinfo.RecdFieldRef,isSet) /// Write into the reference cell stored in the TAST and add to the undo trace if necessary -and TransactMemberConstraintSolution traitInfo trace sln = +and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = let prev = traitInfo.Solution - traitInfo.Solution <- Some sln - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> traitInfo.Solution <- prev) + trace.Exec (fun () -> traitInfo.Solution <- Some sln) (fun () -> traitInfo.Solution <- prev) /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads @@ -1414,19 +1406,14 @@ and SolveRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep permitWeakR else ResultD false)) -and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep permitWeakResolution trace tp = +and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep permitWeakResolution (trace:OptionalTrace) tp = let cxst = csenv.SolverState.ExtraCxs let tpn = tp.Stamp let cxs = cxst.FindAll tpn if List.isEmpty cxs then ResultD false else - cxs |> List.iter (fun _ -> cxst.Remove tpn); - - assert (List.isEmpty (cxst.FindAll tpn)) - - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn,cx))) + trace.Exec (fun () -> cxs |> List.iter (fun _ -> cxst.Remove tpn)) (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn,cx))) + assert (List.isEmpty (cxst.FindAll tpn)) cxs |> AtLeastOneD (fun (traitInfo,m2) -> let csenv = { csenv with m = m2 } @@ -1451,10 +1438,7 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup // check the constraint is not already listed for this type variable if not (cxs |> List.exists (fun (traitInfo2,_) -> traitsAEquiv g aenv traitInfo traitInfo2)) then - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) - csenv.SolverState.ExtraCxs.Add (tpn,(traitInfo,m2)) + trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn,(traitInfo,m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) ); // Associate the constraint with each type variable in the support, so if the type variable @@ -1627,10 +1611,7 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // Record a entry in the undo trace if one is provided let d = tp.Data let orig = d.typar_constraints - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> d.typar_constraints <- orig) - d.typar_constraints <- newConstraints + trace.Exec (fun () -> d.typar_constraints <- newConstraints) (fun () -> d.typar_constraints <- orig) CompleteD))) @@ -2425,17 +2406,13 @@ let UnifyUniqueOverloading | _ -> ResultD false -let EliminateConstraintsForGeneralizedTypars csenv trace (generalizedTypars: Typars) = +let EliminateConstraintsForGeneralizedTypars csenv (trace:OptionalTrace) (generalizedTypars: Typars) = // Remove the global constraints where this type variable appears in the support of the constraint generalizedTypars |> List.iter (fun tp -> let tpn = tp.Stamp let cxst = csenv.SolverState.ExtraCxs let cxs = cxst.FindAll tpn - cxs |> List.iter (fun cx -> - cxst.Remove tpn - match trace with - | NoTrace -> () - | WithTrace trace -> trace.Push (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn,cx)))) + cxs |> List.iter (fun cx -> trace.Exec (fun () -> cxst.Remove tpn) (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn,cx)))) ) From 0c257aa4c90122398cc70c4e82854843c31604e3 Mon Sep 17 00:00:00 2001 From: Gusty Date: Sun, 30 Oct 2016 22:47:43 +0100 Subject: [PATCH 2/3] Avoid calling twice CanMemberSigsMatchUpToCheck with ArgsMustSubsumeOrConvert --- src/fsharp/ConstraintSolver.fs | 63 +++++++++++++++++++++++----------- 1 file changed, 43 insertions(+), 20 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index fbf7ba911b8..213de031a4b 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -325,13 +325,14 @@ let CollectThenUndo f = trace.Undo(); res -let CheckThenUndo f = CollectThenUndo f |> CheckNoErrorsAndGetWarnings - let FilterEachThenUndo f meths = meths |> List.choose (fun calledMeth -> - match CheckThenUndo (fun trace -> f trace calledMeth) with + let trace = Trace.New() + let res = f trace calledMeth + trace.Undo() + match res |> CheckNoErrorsAndGetWarnings with | None -> None - | Some warns -> Some (calledMeth,warns.Length)) + | Some warns -> Some (calledMeth,warns.Length,trace)) let ShowAccessDomain ad = match ad with @@ -2104,17 +2105,17 @@ and ResolveOverloading let isOpConversion = (methodName = "op_Explicit" || methodName = "op_Implicit") // See what candidates we have based on name and arity let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m,ad)) - let calledMethOpt, errors = + let calledMethOpt, errors, calledMethTrace = match calledMethGroup,candidates with | _,[calledMeth] when not isOpConversion -> - Some calledMeth, CompleteD + Some calledMeth, CompleteD, NoTrace | [],_ when not isOpConversion -> - None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName),m)) + None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName),m)), NoTrace | _,[] when not isOpConversion -> - None, ReportNoCandidatesError csenv callerArgCounts methodName ad calledMethGroup + None, ReportNoCandidatesError csenv callerArgCounts methodName ad calledMethGroup, NoTrace | _,_ -> @@ -2138,8 +2139,8 @@ and ResolveOverloading (ArgsEquivInsideUndo csenv cx.IsSome) reqdRetTyOpt calledMeth) with - | [(calledMeth,_)] -> - Some calledMeth, CompleteD + | [(calledMeth,_,_)] -> + Some calledMeth, CompleteD, NoTrace | _ -> // Now determine the applicable methods. @@ -2196,10 +2197,10 @@ and ResolveOverloading | OkResult _ -> None | ErrorResult(_,exn) -> Some (calledMeth, exn))) - None,ErrorD (failOverloading (FSComp.SR.csNoOverloadsFound methodName) errors) + None,ErrorD (failOverloading (FSComp.SR.csNoOverloadsFound methodName) errors), NoTrace - | [(calledMeth,_)] -> - Some calledMeth, CompleteD + | [(calledMeth,_,t)] -> + Some calledMeth, CompleteD, WithTrace t | applicableMeths -> @@ -2235,7 +2236,7 @@ and ResolveOverloading if c <> 0 then c else 0 - let better (candidate:CalledMeth<_>, candidateWarnCount) (other:CalledMeth<_>, otherWarnCount) = + let better (candidate:CalledMeth<_>, candidateWarnCount, _) (other:CalledMeth<_>, otherWarnCount, _) = // Prefer methods that don't give "this code is less generic" warnings // Note: Relies on 'compare' respecting true > false let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) @@ -2326,7 +2327,7 @@ and ResolveOverloading else None) match bestMethods with - | [(calledMeth,_)] -> Some(calledMeth), CompleteD + | [(calledMeth,_,t)] -> Some(calledMeth), CompleteD, WithTrace t | bestMethods -> let methodNames = let methods = @@ -2337,8 +2338,8 @@ and ResolveOverloading | [] -> match applicableMeths with | [] -> candidates - | m -> m |> List.map fst - | m -> m |> List.map fst + | m -> m |> List.map (fun (x,_,_) -> x) + | m -> m |> List.map (fun (x,_,_) -> x) methods |> List.map (fun cmeth -> NicePrint.stringOfMethInfo amap m denv cmeth.Method) |> List.sort @@ -2347,7 +2348,7 @@ and ResolveOverloading match methodNames with | [] -> msg | names -> sprintf "%s %s" msg (FSComp.SR.csCandidates (String.concat ", " names)) - None, ErrorD (failOverloading msg []) + None, ErrorD (failOverloading msg []), NoTrace // If we've got a candidate solution: make the final checks - no undo here! // Allow subsumption on arguments. Include the return type. @@ -2356,7 +2357,11 @@ and ResolveOverloading | Some(calledMeth) -> calledMethOpt, errors ++ (fun () -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx + let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx + match calledMethTrace with + | NoTrace -> + + // No trace available for CanMemberSigsMatchUpToCheck with ArgsMustSubsumeOrConvert CanMemberSigsMatchUpToCheck csenv permitOptArgs @@ -2365,7 +2370,25 @@ and ResolveOverloading (TypesMustSubsumeOrConvertInsideUndo csenv ndeep trace cxsln m)// REVIEW: this should not be an "InsideUndo" operation (ArgsMustSubsumeOrConvert csenv ndeep trace cxsln cx.IsSome) reqdRetTyOpt - calledMeth) + calledMeth + | WithTrace calledMethTrc -> + + // Re-play existing trace + calledMethTrc.actions |> List.rev |> List.iter (fun (action, undo) -> trace.Exec action undo) + + // Unify return type + match reqdRetTyOpt with + | None -> CompleteD + | Some _ when calledMeth.Method.IsConstructor -> CompleteD + | Some reqdRetTy -> + let methodRetTy = + if List.isEmpty calledMeth.UnnamedCalledOutArgs then + calledMeth.ReturnType + else + let outArgTys = calledMeth.UnnamedCalledOutArgs |> List.map (fun calledArg -> destByrefTy g calledArg.CalledArgumentType) + if isUnitTy g calledMeth.ReturnType then mkRefTupledTy g outArgTys + else mkRefTupledTy g (calledMeth.ReturnType :: outArgTys) + MustUnify csenv ndeep trace cxsln reqdRetTy methodRetTy) | None -> None, errors From c3cc8b166e2e0bc30cdd45f61de07a3408828a13 Mon Sep 17 00:00:00 2001 From: Gusty Date: Mon, 31 Oct 2016 23:10:49 +0100 Subject: [PATCH 3/3] Encapsulate replay --- src/fsharp/ConstraintSolver.fs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 213de031a4b..18a19de3afc 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -317,7 +317,11 @@ type OptionalTrace = match t with | WithTrace trace -> trace.Push f undo; f() | NoTrace -> f() - + member t.AddFromReplay source = + source.actions |> List.rev |> + match t with + | WithTrace trace -> List.iter (fun (action, undo) -> trace.Push action undo; action()) + | NoTrace -> List.iter (fun (action, _ ) -> action()) let CollectThenUndo f = let trace = Trace.New() @@ -2140,7 +2144,7 @@ and ResolveOverloading reqdRetTyOpt calledMeth) with | [(calledMeth,_,_)] -> - Some calledMeth, CompleteD, NoTrace + Some calledMeth, CompleteD, NoTrace // Can't re-play the trace since ArgsEquivInsideUndo was used | _ -> // Now determine the applicable methods. @@ -2374,7 +2378,7 @@ and ResolveOverloading | WithTrace calledMethTrc -> // Re-play existing trace - calledMethTrc.actions |> List.rev |> List.iter (fun (action, undo) -> trace.Exec action undo) + trace.AddFromReplay calledMethTrc // Unify return type match reqdRetTyOpt with