Skip to content

Commit a814c1a

Browse files
auduchinokbaronfel
auduchinok
authored and
baronfel
committed
PatternMatchCompilation cleanup (#6993)
* PatternMatchCompilation cleanup * More cleanup
1 parent b81dde0 commit a814c1a

File tree

2 files changed

+119
-123
lines changed

2 files changed

+119
-123
lines changed

‎src/fsharp/PatternMatchCompilation.fs‎

Lines changed: 108 additions & 112 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,6 @@ type ActionOnFailure =
3030
| FailFilter
3131

3232
[<NoEquality; NoComparison>]
33-
/// Represents type-checked patterns
3433
type Pattern =
3534
| TPat_const of Const * range
3635
| TPat_wild of range (* note = TPat_disjs([], m), but we haven't yet removed that duplication *)
@@ -720,7 +719,9 @@ let rec erasePartialPatterns inpp =
720719
| TPat_range _
721720
| TPat_null _
722721
| TPat_isinst _ -> inpp
723-
and erasePartials inps = List.map erasePartialPatterns inps
722+
723+
and erasePartials inps =
724+
List.map erasePartialPatterns inps
724725

725726

726727
//---------------------------------------------------------------------------
@@ -740,118 +741,115 @@ let CompilePatternBasic
740741
(clausesL: TypedMatchClause list)
741742
inputTy
742743
resultTy =
743-
// Add the targets to a match builder
744-
// Note the input expression has already been evaluated and saved into a variable.
745-
// Hence no need for a new sequence point.
746-
let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding, exprm)
747-
clausesL |> List.iteri (fun _i c -> mbuilder.AddTarget c.Target |> ignore)
748-
749-
// Add the incomplete or rethrow match clause on demand, printing a
750-
// warning if necessary (only if it is ever exercised)
751-
let incompleteMatchClauseOnce = ref None
744+
// Add the targets to a match builder.
745+
// Note the input expression has already been evaluated and saved into a variable,
746+
// hence no need for a new sequence point.
747+
let matchBuilder = MatchBuilder (NoSequencePointAtInvisibleBinding, exprm)
748+
clausesL |> List.iter (fun c -> matchBuilder.AddTarget c.Target |> ignore)
749+
750+
// Add the incomplete or rethrow match clause on demand,
751+
// printing a warning if necessary (only if it is ever exercised).
752+
let mutable incompleteMatchClauseOnce = None
752753
let getIncompleteMatchClause refuted =
753-
// This is lazy because emit a
754-
// warning when the lazy thunk gets evaluated
755-
match !incompleteMatchClauseOnce with
754+
// This is lazy because emit a warning when the lazy thunk gets evaluated.
755+
match incompleteMatchClauseOnce with
756756
| None ->
757-
(* Emit the incomplete match warning *)
758-
if warnOnIncomplete then
759-
match actionOnFailure with
760-
| ThrowIncompleteMatchException | IgnoreWithWarning ->
761-
let ignoreWithWarning = (actionOnFailure = IgnoreWithWarning)
762-
match ShowCounterExample g denv matchm refuted with
763-
| Some(text, failingWhenClause, true) ->
764-
warning (EnumMatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), matchm))
765-
| Some(text, failingWhenClause, false) ->
766-
warning (MatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), matchm))
767-
| None ->
768-
warning (MatchIncomplete(ignoreWithWarning, None, matchm))
769-
| _ ->
770-
()
771-
772-
let throwExpr =
773-
match actionOnFailure with
774-
| FailFilter ->
775-
// Return 0 from the .NET exception filter
776-
mkInt g matchm 0
777-
778-
| Rethrow ->
779-
// Rethrow unmatched try-catch exn. No sequence point at the target since its not
780-
// real code.
781-
mkReraise matchm resultTy
782-
783-
| Throw ->
784-
// We throw instead of rethrow on unmatched try-catch in a computation expression. But why?
785-
// Because this isn't a real .NET exception filter/handler but just a function we're passing
786-
// to a computation expression builder to simulate one.
787-
mkThrow matchm resultTy (exprForVal matchm origInputVal)
788-
789-
| ThrowIncompleteMatchException ->
790-
mkThrow matchm resultTy
791-
(mkExnExpr(mk_MFCore_tcref g.fslibCcu "MatchFailureException",
792-
[ mkString g matchm matchm.FileName
793-
mkInt g matchm matchm.StartLine
794-
mkInt g matchm matchm.StartColumn], matchm))
795-
796-
| IgnoreWithWarning ->
797-
mkUnit g matchm
798-
799-
// We don't emit a sequence point at any of the above cases because they don't correspond to
800-
// user code.
801-
//
802-
// Note we don't emit sequence points at either the succeeding or failing
803-
// targets of filters since if the exception is filtered successfully then we
804-
// will run the handler and hit the sequence point there.
805-
// That sequence point will have the pattern variables bound, which is exactly what we want.
806-
let tg = TTarget(List.empty, throwExpr, SuppressSequencePointAtTarget )
807-
mbuilder.AddTarget tg |> ignore
808-
let clause = TClause(TPat_wild matchm, None, tg, matchm)
809-
incompleteMatchClauseOnce := Some clause
810-
clause
757+
// Emit the incomplete match warning.
758+
if warnOnIncomplete then
759+
match actionOnFailure with
760+
| ThrowIncompleteMatchException | IgnoreWithWarning ->
761+
let ignoreWithWarning = (actionOnFailure = IgnoreWithWarning)
762+
match ShowCounterExample g denv matchm refuted with
763+
| Some(text, failingWhenClause, true) ->
764+
warning (EnumMatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), matchm))
765+
| Some(text, failingWhenClause, false) ->
766+
warning (MatchIncomplete(ignoreWithWarning, Some(text, failingWhenClause), matchm))
767+
| None ->
768+
warning (MatchIncomplete(ignoreWithWarning, None, matchm))
769+
| _ ->
770+
()
771+
772+
let throwExpr =
773+
match actionOnFailure with
774+
| FailFilter ->
775+
// Return 0 from the .NET exception filter.
776+
mkInt g matchm 0
777+
778+
| Rethrow ->
779+
// Rethrow unmatched try-catch exn. No sequence point at the target since its not real code.
780+
mkReraise matchm resultTy
781+
782+
| Throw ->
783+
// We throw instead of rethrow on unmatched try-catch in a computation expression. But why?
784+
// Because this isn't a real .NET exception filter/handler but just a function we're passing
785+
// to a computation expression builder to simulate one.
786+
mkThrow matchm resultTy (exprForVal matchm origInputVal)
787+
788+
| ThrowIncompleteMatchException ->
789+
mkThrow matchm resultTy
790+
(mkExnExpr(mk_MFCore_tcref g.fslibCcu "MatchFailureException",
791+
[ mkString g matchm matchm.FileName
792+
mkInt g matchm matchm.StartLine
793+
mkInt g matchm matchm.StartColumn], matchm))
794+
795+
| IgnoreWithWarning ->
796+
mkUnit g matchm
797+
798+
// We don't emit a sequence point at any of the above cases because they don't correspond to user code.
799+
//
800+
// Note we don't emit sequence points at either the succeeding or failing targets of filters since if
801+
// the exception is filtered successfully then we will run the handler and hit the sequence point there.
802+
// That sequence point will have the pattern variables bound, which is exactly what we want.
803+
let tg = TTarget(List.empty, throwExpr, SuppressSequencePointAtTarget)
804+
let _ = matchBuilder.AddTarget tg
805+
let clause = TClause(TPat_wild matchm, None, tg, matchm)
806+
incompleteMatchClauseOnce <- Some clause
807+
clause
811808

812809
| Some c -> c
813810

814-
// Helpers to get the variables bound at a target. We conceptually add a dummy clause that will always succeed with a "throw"
811+
// Helpers to get the variables bound at a target.
812+
// We conceptually add a dummy clause that will always succeed with a "throw"
815813
let clausesA = Array.ofList clausesL
816-
let nclauses = clausesA.Length
814+
let nClauses = clausesA.Length
817815
let GetClause i refuted =
818-
if i < nclauses then
816+
if i < nClauses then
819817
clausesA.[i]
820-
elif i = nclauses then getIncompleteMatchClause refuted
818+
elif i = nClauses then getIncompleteMatchClause refuted
821819
else failwith "GetClause"
822820
let GetValsBoundByClause i refuted = (GetClause i refuted).BoundVals
823821
let GetWhenGuardOfClause i refuted = (GetClause i refuted).GuardExpr
824822

825-
// Different uses of parameterized active patterns have different identities as far as paths
826-
// are concerned. Here we generate unique numbers that are completely different to any stamp
827-
// by usig negative numbers.
823+
// Different uses of parameterized active patterns have different identities as far as paths are concerned.
824+
// Here we generate unique numbers that are completely different to any stamp by using negative numbers.
828825
let genUniquePathId() = - (newUnique())
829826

830-
// Build versions of these functions which apply a dummy instantiation to the overall type arguments
827+
// Build versions of these functions which apply a dummy instantiation to the overall type arguments.
831828
let GetSubExprOfInput, getDiscrimOfPattern =
832829
let tyargs = List.map (fun _ -> g.unit_ty) origInputValTypars
833830
let unit_tpinst = mkTyparInst origInputValTypars tyargs
834831
GetSubExprOfInput g (origInputValTypars, tyargs, unit_tpinst),
835832
getDiscrimOfPattern g unit_tpinst
836833

837-
// The main recursive loop of the pattern match compiler
834+
// The main recursive loop of the pattern match compiler.
838835
let rec InvestigateFrontiers refuted frontiers =
839836
match frontiers with
840837
| [] -> failwith "CompilePattern: compile - empty clauses: at least the final clause should always succeed"
841-
| (Frontier (i, active, valMap)) :: rest ->
838+
| Frontier (i, active, valMap) :: rest ->
842839

843-
// Check to see if we've got a succeeding clause. There may still be a 'when' condition for the clause
840+
// Check to see if we've got a succeeding clause. There may still be a 'when' condition for the clause.
844841
match active with
845842
| [] -> CompileSuccessPointAndGuard i refuted valMap rest
846843

847844
| _ ->
848-
(* Otherwise choose a point (i.e. a path) to investigate. *)
845+
// Otherwise choose a point (i.e. a path) to investigate.
849846
let (Active(path, subexpr, pat)) = ChooseInvestigationPointLeftToRight frontiers
850847
match pat with
851848
// All these constructs should have been eliminated in BindProjectionPattern
852-
| TPat_as _ | TPat_tuple _ | TPat_wild _ | TPat_disjs _ | TPat_conjs _ | TPat_recd _ -> failwith "Unexpected pattern"
849+
| TPat_as _ | TPat_tuple _ | TPat_wild _ | TPat_disjs _ | TPat_conjs _ | TPat_recd _ ->
850+
failwith "Unexpected pattern"
853851

854-
// Leaving the ones where we have real work to do
852+
// Leaving the ones where we have real work to do.
855853
| _ ->
856854

857855
let simulSetOfEdgeDiscrims, fallthroughPathFrontiers = ChooseSimultaneousEdges frontiers path
@@ -879,7 +877,6 @@ let CompilePatternBasic
879877
finalDecisionTree
880878

881879
and CompileSuccessPointAndGuard i refuted valMap rest =
882-
883880
let vs2 = GetValsBoundByClause i refuted
884881
let es2 =
885882
vs2 |> List.map (fun v ->
@@ -907,25 +904,25 @@ let CompilePatternBasic
907904

908905
| None -> rhs'
909906

910-
/// Select the set of discriminators which we can handle in one test, or as a series of
911-
/// iterated tests, e.g. in the case of TPat_isinst. Ensure we only take at most one class of `TPat_query` at a time.
907+
/// Select the set of discriminators which we can handle in one test, or as a series of iterated tests,
908+
/// e.g. in the case of TPat_isinst. Ensure we only take at most one class of `TPat_query` at a time.
912909
/// Record the rule numbers so we know which rule the TPat_query cam from, so that when we project through
913910
/// the frontier we only project the right rule.
914911
and ChooseSimultaneousEdges frontiers path =
915912
frontiers |> chooseSimultaneousEdgeSet None (fun prevOpt (Frontier (i', active', _)) ->
916-
if isMemOfActives path active' then
917-
let p = lookupActive path active' |> snd
918-
match getDiscrimOfPattern p with
919-
| Some discrim ->
920-
if (match prevOpt with None -> true | Some (EdgeDiscrim(_, discrimPrev, _)) -> discrimsHaveSameSimultaneousClass g discrim discrimPrev) then
921-
Some (EdgeDiscrim(i', discrim, p.Range)), true
922-
else
923-
None, false
924-
925-
| None ->
926-
None, true
927-
else
928-
None, true)
913+
if isMemOfActives path active' then
914+
let _, p = lookupActive path active'
915+
match getDiscrimOfPattern p with
916+
| Some discrim ->
917+
if (match prevOpt with None -> true | Some (EdgeDiscrim(_, discrimPrev, _)) -> discrimsHaveSameSimultaneousClass g discrim discrimPrev) then
918+
Some (EdgeDiscrim(i', discrim, p.Range)), true
919+
else
920+
None, false
921+
922+
| None ->
923+
None, true
924+
else
925+
None, true)
929926

930927
and IsCopyableInputExpr origInputExpr =
931928
match origInputExpr with
@@ -1298,13 +1295,13 @@ let CompilePatternBasic
12981295
mkFrontiers investigations i)
12991296
|> List.concat)
13001297
@
1301-
mkFrontiers [([], ValMap<_>.Empty)] nclauses)
1298+
mkFrontiers [([], ValMap<_>.Empty)] nClauses)
13021299
let dtree =
13031300
InvestigateFrontiers
13041301
[]
13051302
frontiers
13061303

1307-
let targets = mbuilder.CloseTargets()
1304+
let targets = matchBuilder.CloseTargets()
13081305

13091306

13101307
// Report unused targets
@@ -1320,33 +1317,32 @@ let isPartialOrWhenClause (c: TypedMatchClause) = isPatternPartial c.Pattern ||
13201317

13211318

13221319
let rec CompilePattern g denv amap exprm matchm warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: TypedMatchClause list) inputTy resultTy =
1323-
match clausesL with
1324-
| _ when List.exists isPartialOrWhenClause clausesL ->
1320+
match clausesL with
1321+
| _ when List.exists isPartialOrWhenClause clausesL ->
13251322
// Partial clauses cause major code explosion if treated naively
13261323
// Hence treat any pattern matches with any partial clauses clause-by-clause
13271324

13281325
// First make sure we generate at least some of the obvious incomplete match warnings.
1329-
let warnOnUnused = false in (* we can't turn this on since we're pretending all partial's fail in order to control the complexity of this. *)
1326+
let warnOnUnused = false // we can't turn this on since we're pretending all partials fail in order to control the complexity of this.
13301327
let warnOnIncomplete = true
13311328
let clausesPretendAllPartialFail = List.collect (fun (TClause(p, whenOpt, tg, m)) -> [TClause(erasePartialPatterns p, whenOpt, tg, m)]) clausesL
13321329
let _ = CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesPretendAllPartialFail inputTy resultTy
13331330
let warnOnIncomplete = false
13341331

13351332
let rec atMostOnePartialAtATime clauses =
13361333
match List.takeUntil isPartialOrWhenClause clauses with
1337-
| l, [] ->
1334+
| l, [] ->
13381335
CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) l inputTy resultTy
13391336
| l, (h :: t) ->
1340-
// Add the partial clause
1337+
// Add the partial clause.
13411338
doGroupWithAtMostOnePartial (l @ [h]) t
13421339

13431340
and doGroupWithAtMostOnePartial group rest =
1341+
// Compile the remaining clauses.
1342+
let decisionTree, targets = atMostOnePartialAtATime rest
13441343

1345-
// Compile the remaining clauses
1346-
let dtree, targets = atMostOnePartialAtATime rest
1347-
1348-
// Make the expression that represents the remaining cases of the pattern match
1349-
let expr = mkAndSimplifyMatch NoSequencePointAtInvisibleBinding exprm matchm resultTy dtree targets
1344+
// Make the expression that represents the remaining cases of the pattern match.
1345+
let expr = mkAndSimplifyMatch NoSequencePointAtInvisibleBinding exprm matchm resultTy decisionTree targets
13501346

13511347
// If the remainder of the match boiled away to nothing interesting.
13521348
// We measure this simply by seeing if the range of the resulting expression is identical to matchm.
@@ -1362,5 +1358,5 @@ let rec CompilePattern g denv amap exprm matchm warnOnUnused actionOnFailure (o
13621358

13631359
atMostOnePartialAtATime clausesL
13641360

1365-
| _ ->
1366-
CompilePatternBasic g denv amap exprm matchm warnOnUnused true actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesL inputTy resultTy
1361+
| _ ->
1362+
CompilePatternBasic g denv amap exprm matchm warnOnUnused true actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) clausesL inputTy resultTy

‎src/fsharp/PatternMatchCompilation.fsi‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,6 @@ open FSharp.Compiler.Tastops
99
open FSharp.Compiler.TcGlobals
1010
open FSharp.Compiler.Range
1111

12-
1312
/// What should the decision tree contain for any incomplete match?
1413
type ActionOnFailure =
1514
| ThrowIncompleteMatchException
@@ -23,30 +22,31 @@ type ActionOnFailure =
2322
type Pattern =
2423
| TPat_const of Const * range
2524
| TPat_wild of range
26-
| TPat_as of Pattern * PatternValBinding * range
27-
| TPat_disjs of Pattern list * range
28-
| TPat_conjs of Pattern list * range
25+
| TPat_as of Pattern * PatternValBinding * range
26+
| TPat_disjs of Pattern list * range
27+
| TPat_conjs of Pattern list * range
2928
| TPat_query of (Expr * TType list * (ValRef * TypeInst) option * int * PrettyNaming.ActivePatternInfo) * Pattern * range
3029
| TPat_unioncase of UnionCaseRef * TypeInst * Pattern list * range
3130
| TPat_exnconstr of TyconRef * Pattern list * range
32-
| TPat_tuple of TupInfo * Pattern list * TType list * range
33-
| TPat_array of Pattern list * TType * range
31+
| TPat_tuple of TupInfo * Pattern list * TType list * range
32+
| TPat_array of Pattern list * TType * range
3433
| TPat_recd of TyconRef * TypeInst * Pattern list * range
3534
| TPat_range of char * char * range
3635
| TPat_null of range
3736
| TPat_isinst of TType * TType * PatternValBinding option * range
38-
member Range : range
37+
38+
member Range: range
3939

4040
and PatternValBinding =
4141
| PBind of Val * TypeScheme
4242

4343
and TypedMatchClause =
4444
| TClause of Pattern * Expr option * DecisionTreeTarget * range
4545

46-
val ilFieldToTastConst : ILFieldInit -> Tast.Const
46+
val ilFieldToTastConst: ILFieldInit -> Tast.Const
4747

4848
/// Compile a pattern into a decision tree and a set of targets.
49-
val internal CompilePattern :
49+
val internal CompilePattern:
5050
TcGlobals ->
5151
DisplayEnv ->
5252
Import.ImportMap ->
@@ -66,8 +66,8 @@ val internal CompilePattern :
6666
TType ->
6767
// result type
6868
TType ->
69-
// produce TAST nodes
70-
DecisionTree * DecisionTreeTarget list
69+
// produce TAST nodes
70+
DecisionTree * DecisionTreeTarget list
7171

7272
exception internal MatchIncomplete of bool * (string * bool) option * range
7373
exception internal RuleNeverMatched of range

0 commit comments

Comments
 (0)