Skip to content

Commit

Permalink
Avoid calling CanMemberSigsMatchUpToCheck twice (#1685)
Browse files Browse the repository at this point in the history 
* Upgrade Trace class to support redo tupled with the existing undo

* Avoid calling twice CanMemberSigsMatchUpToCheck with ArgsMustSubsumeOrConvert

* Encapsulate replay
  • Loading branch information
@gusty @KevinRansom
gusty authored and KevinRansom committed Nov 7, 2016
1 parent 4202830 commit 36c7e0f
Showing 1 changed file with 70 additions and 66 deletions.
136 changes: 70 additions & 66 deletions src/fsharp/ConstraintSolver.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -304,30 +304,39 @@ 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()
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()
let res = f trace
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
Expand Down Expand Up @@ -411,16 +420,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) =
Expand All @@ -444,12 +450,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 =
Expand Down Expand Up @@ -654,7 +657,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 () ->
Expand All @@ -673,10 +676,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; *)

Expand Down Expand Up @@ -1354,12 +1354,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
Expand Down Expand Up @@ -1414,19 +1411,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 }
Expand All @@ -1451,10 +1443,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
Expand Down Expand Up @@ -1627,10 +1616,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)))

Expand Down Expand Up @@ -2123,17 +2109,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

| _,_ ->

Expand All @@ -2157,8 +2143,8 @@ and ResolveOverloading
(ArgsEquivInsideUndo csenv cx.IsSome)
reqdRetTyOpt
calledMeth) with
| [(calledMeth,_)] ->
Some calledMeth, CompleteD
| [(calledMeth,_,_)] ->
Some calledMeth, CompleteD, NoTrace // Can't re-play the trace since ArgsEquivInsideUndo was used

| _ ->
// Now determine the applicable methods.
Expand Down Expand Up @@ -2215,10 +2201,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 ->

Expand Down Expand Up @@ -2254,7 +2240,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)
Expand Down Expand Up @@ -2345,7 +2331,7 @@ and ResolveOverloading
else
None)
match bestMethods with
| [(calledMeth,_)] -> Some(calledMeth), CompleteD
| [(calledMeth,_,t)] -> Some(calledMeth), CompleteD, WithTrace t
| bestMethods ->
let methodNames =
let methods =
Expand All @@ -2356,8 +2342,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
Expand All @@ -2366,7 +2352,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.
Expand All @@ -2375,7 +2361,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
Expand All @@ -2384,7 +2374,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
trace.AddFromReplay calledMethTrc

// 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
Expand Down Expand Up @@ -2425,17 +2433,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))))
)


Expand Down

0 comments on commit 36c7e0f

Please sign in to comment.