Skip to content

Commit a29233c

Browse files
edgarfgpedgarfgp
authored
Check let bindings through active patterns like a match (#16856) (#20383)
1 parent 9c3a877 commit a29233c

15 files changed

Lines changed: 191 additions & 48 deletions

‎docs/release-notes/.FSharp.Compiler.Service/11.0.100.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
### Fixed
22

33
* Fix `NativePtr.stackalloc` nested in a larger expression (e.g. a call argument or the right of an assignment) producing an assembly that throws `InvalidProgramException` at load. ([Issue #8083](https://github.com/dotnet/fsharp/issues/8083), [PR #20302](https://github.com/dotnet/fsharp/pull/20302))
4+
* Fix internal error "Unexpected generalized type variables when compiling an active pattern" when an active pattern is used in a `let` binding whose right-hand side is a generic value, e.g. `let (T) = id`. Such a binding is now checked like the equivalent `match` and is not generalized. ([Issue #16856](https://github.com/dotnet/fsharp/issues/16856), [PR #20383](https://github.com/dotnet/fsharp/pull/20383))
45
* Fix Release-only (`--optimize+`) `System.InvalidProgramException` from `Seq.collect` / `yield!` over a value-type (struct) collection implementing `seq<'T>` (e.g. `ImmutableArray<_>`) when materialised with `List.ofSeq` / `Seq.toList` / `Seq.toArray` or a list/array comprehension. The collector lowering now boxes a struct sub-collection to `seq<'T>` before calling `AddMany`/`AddManyAndClose` (matching the coercion the type checker already inserts for `yield!`), and uses `unit` as the try/finally result type instead of the body type (removing a spurious `ldnull` store). ([Issue #20203](https://github.com/dotnet/fsharp/issues/20203))
56
* Fix recursive inline SRTP resolution being truncated by one currying level (e.g. FSharpPlus `memoizeN`), a regression from the function-domain unification order change in [PR #15181](https://github.com/dotnet/fsharp/pull/15181); the contravariant domain now keeps the inference variable that still carries the pending member constraint. ([PR #20247](https://github.com/dotnet/fsharp/pull/20247))
67
* Fix exponential (2^N) compile time in pattern matching with shared guards and partial active patterns. ([Issue #18425](https://github.com/dotnet/fsharp/issues/18425), [PR #20244](https://github.com/dotnet/fsharp/pull/20244))

‎src/Compiler/Checking/CheckBasics.fs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -86,7 +86,9 @@ type PrelimVal1 =
8686

8787
type UnscopedTyparEnv = UnscopedTyparEnv of NameMap<Typar>
8888

89-
type TcPatLinearEnv = TcPatLinearEnv of tpenv: UnscopedTyparEnv * names: NameMap<PrelimVal1> * takenNames: Set<string>
89+
/// Represents the context flowed left-to-right through pattern checking.
90+
/// 'usesActivePattern' is true if an active pattern occurs in the pattern; see TcLetBinding.
91+
type TcPatLinearEnv = TcPatLinearEnv of tpenv: UnscopedTyparEnv * names: NameMap<PrelimVal1> * takenNames: Set<string> * usesActivePattern: bool
9092

9193
/// Translation of patterns is split into three phases. The first collects names.
9294
/// The second is run after val_specs have been created for those names and inference

‎src/Compiler/Checking/CheckBasics.fsi‎

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -214,8 +214,14 @@ type TcPatPhase2Input =
214214

215215
member WithRightPath: unit -> TcPatPhase2Input
216216

217-
/// Represents the context flowed left-to-right through pattern checking
218-
type TcPatLinearEnv = TcPatLinearEnv of tpenv: UnscopedTyparEnv * names: NameMap<PrelimVal1> * takenNames: Set<string>
217+
/// Represents the context flowed left-to-right through pattern checking.
218+
/// 'usesActivePattern' is true if an active pattern occurs in the pattern; see TcLetBinding.
219+
type TcPatLinearEnv =
220+
| TcPatLinearEnv of
221+
tpenv: UnscopedTyparEnv *
222+
names: NameMap<PrelimVal1> *
223+
takenNames: Set<string> *
224+
usesActivePattern: bool
219225

220226
/// Represents the flags passed to TcPat regarding the binding location
221227
type TcPatValFlags =

‎src/Compiler/Checking/CheckDeclarations.fs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2693,7 +2693,7 @@ module EstablishTypeDefinitionCores =
26932693
| Some pat ->
26942694
let ctorArgNames, patEnv, _ = TcSimplePatsOfUnknownType cenv true NoCheckCxs env tpenv pat
26952695

2696-
let (TcPatLinearEnv(_, names, _)) = patEnv
2696+
let (TcPatLinearEnv(_, names, _, _)) = patEnv
26972697

26982698
for arg in ctorArgNames do
26992699
let ty = names[arg].Type
@@ -3923,7 +3923,7 @@ module EstablishTypeDefinitionCores =
39233923
if tycon.IsFSharpStructOrEnumTycon then
39243924
let ctorArgNames, patEnv, _ = TcSimplePatsOfUnknownType cenv true CheckCxs envinner tpenv pat
39253925

3926-
let (TcPatLinearEnv(_, names, _)) = patEnv
3926+
let (TcPatLinearEnv(_, names, _, _)) = patEnv
39273927

39283928
for arg in ctorArgNames do
39293929
let ty = names[arg].Type

‎src/Compiler/Checking/CheckIncrementalClasses.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,7 @@ let TcImplicitCtorInfo_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, att
149149
for spat in spats do
150150
reportGeneratedPattern spat
151151

152-
let (TcPatLinearEnv(_, names, _)) = patEnv
152+
let (TcPatLinearEnv(_, names, _, _)) = patEnv
153153

154154
// Create the values with the given names
155155
let _, vspecs = MakeAndPublishSimpleVals cenv env names

‎src/Compiler/Checking/CheckPatterns.fs‎

Lines changed: 25 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,7 @@ let rec TryAdjustHiddenVarNameToCompGenName (cenv: cenv) env (id: Ident) altName
7777
/// Bind the patterns used in a lambda. Not clear why we don't use TcPat.
7878
and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (attribs: SynAttributes) =
7979
let g = cenv.g
80-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
80+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
8181

8282
match p with
8383
| SynSimplePat.Id (id, altNameRefCellOpt, isCompGen, isMemberThis, isOpt, m) ->
@@ -99,7 +99,7 @@ and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (at
9999

100100
let vFlags = TcPatValFlags (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, isCompGen)
101101
let _, names, takenNames = TcPatBindingName cenv env id ty isMemberThis None None vFlags (names, takenNames)
102-
let patEnvR = TcPatLinearEnv(tpenv, names, takenNames)
102+
let patEnvR = TcPatLinearEnv(tpenv, names, takenNames, usesAP)
103103
id.idText, patEnvR
104104

105105
| SynSimplePat.Typed (p, cty, m) ->
@@ -114,7 +114,7 @@ and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (at
114114
UnifyTypes cenv env m ty optionalParamTy
115115
| _ -> UnifyTypes cenv env m ty ctyR
116116

117-
let patEnvR = TcPatLinearEnv(tpenv, names, takenNames)
117+
let patEnvR = TcPatLinearEnv(tpenv, names, takenNames, usesAP)
118118

119119
// Ensure the untyped typar name sticks
120120
match cty, ty with
@@ -169,17 +169,17 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS
169169

170170
let augmentTakenNamesFromFirstGroup (parsedData: SynPat list * bool) (patEnvOut: TcPatLinearEnv) : TcPatLinearEnv =
171171
match parsedData, patEnvOut with
172-
| (pats ,true), TcPatLinearEnv(tpenvR, namesR, takenNamesR) ->
172+
| (pats ,true), TcPatLinearEnv(tpenvR, namesR, takenNamesR, usesAPR) ->
173173
match pats with
174174
| pat :: _ ->
175175
let extra = collectBoundIdTextsFromPat [] pat |> Set.ofList
176-
TcPatLinearEnv(tpenvR, namesR, Set.union takenNamesR extra)
176+
TcPatLinearEnv(tpenvR, namesR, Set.union takenNamesR extra, usesAPR)
177177
| _ -> patEnvOut
178178
| _ -> patEnvOut
179179

180180
let bindCurriedGroup (synSimplePats: SynSimplePats) : string list * TcPatLinearEnv =
181181
let g = cenv.g
182-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
182+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
183183
match synSimplePats with
184184
| SynSimplePats.SimplePats ([], _, m) ->
185185
// Unit "()" patterns in argument position become SynSimplePats.SimplePats([], _) in the
@@ -194,7 +194,7 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS
194194
UnifyTypes cenv env m ty g.unit_ty
195195
let vFlags = TcPatValFlags (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, true)
196196
let _, namesR, takenNamesR = TcPatBindingName cenv env id ty false None None vFlags (names, takenNames)
197-
[ id.idText ], TcPatLinearEnv(tpenv, namesR, takenNamesR)
197+
[ id.idText ], TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP)
198198
| SynSimplePats.SimplePats ([sp], _, _) ->
199199
// Single parameter: no tuple splitting, check directly
200200
let v, patEnv' = TcSimplePat optionalArgsOK checkConstraints cenv ty env patEnv sp []
@@ -221,7 +221,7 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS
221221
and TcSimplePatsOfUnknownType (cenv: cenv) optionalArgsOK checkConstraints env tpenv (pat: SynPat) =
222222
let g = cenv.g
223223
let argTy = NewInferenceType g
224-
let patEnv = TcPatLinearEnv (tpenv, NameMap.empty, Set.empty)
224+
let patEnv = TcPatLinearEnv (tpenv, NameMap.empty, Set.empty, false)
225225
let spats, _ = SimplePatsOfPat cenv.synArgNameGenerator pat
226226
let names, patEnv = TcSimplePats cenv optionalArgsOK checkConstraints argTy env patEnv spats ([], false)
227227
names, patEnv, spats
@@ -314,16 +314,16 @@ and TcPat warnOnUpper (cenv: cenv) env valReprInfo vFlags (patEnv: TcPatLinearEn
314314

315315
| SynPat.OptionalVal (id, m) ->
316316
errorR (Error (FSComp.SR.tcOptionalArgsOnlyOnMembers (), m))
317-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
317+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
318318
let bindf, namesR, takenNamesR = TcPatBindingName cenv env id ty false None valReprInfo vFlags (names, takenNames)
319-
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR)
319+
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP)
320320
(fun values -> TPat_as (TPat_wild m, bindf values, m)), patEnvR
321321

322322
| SynPat.Typed (p, cty, m) ->
323-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
323+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
324324
let ctyR, tpenvR = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv cty
325325
UnifyTypes cenv env m ty ctyR
326-
let patEnvR = TcPatLinearEnv(tpenvR, names, takenNames)
326+
let patEnvR = TcPatLinearEnv(tpenvR, names, takenNames, usesAP)
327327
TcPat warnOnUpper cenv env valReprInfo vFlags patEnvR ty p
328328

329329
| SynPat.Attrib (innerPat, attrs, _) ->
@@ -395,9 +395,9 @@ and TcConstPat warnOnUpper cenv env vFlags patEnv ty synConst m =
395395
(fun _ -> TPat_error m), patEnv
396396

397397
and TcPatNamedAs warnOnUpper cenv env valReprInfo vFlags patEnv ty synInnerPat id isMemberThis vis m =
398-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
398+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
399399
let bindf, namesR, takenNamesR = TcPatBindingName cenv env id ty isMemberThis vis valReprInfo vFlags (names, takenNames)
400-
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR)
400+
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP)
401401
let innerPat, acc = TcPat warnOnUpper cenv env None vFlags patEnvR ty synInnerPat
402402
let phase2 values = TPat_as (innerPat values, bindf values, m)
403403
phase2, acc
@@ -418,18 +418,18 @@ and TcPatUnnamedAs warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m =
418418
phase2, patEnvR
419419

420420
and TcPatNamed warnOnUpper cenv env vFlags patEnv id ty isMemberThis vis valReprInfo m =
421-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
421+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
422422
let bindf, namesR, takenNamesR = TcPatBindingName cenv env id ty isMemberThis vis valReprInfo vFlags (names, takenNames)
423-
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR)
423+
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP)
424424
let pat', acc = TcPat warnOnUpper cenv env None vFlags patEnvR ty (SynPat.Wild m)
425425
let phase2 values = TPat_as (pat' values, bindf values, m)
426426
phase2, acc
427427

428428
and TcPatIsInstance warnOnUpper cenv env valReprInfo vFlags patEnv srcTy synPat synTargetTy m =
429-
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
429+
let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv
430430
let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv synTargetTy
431431
TcRuntimeTypeTest false true cenv env.DisplayEnv m tgtTy srcTy
432-
let patEnv = TcPatLinearEnv(tpenv, names, takenNames)
432+
let patEnv = TcPatLinearEnv(tpenv, names, takenNames, usesAP)
433433
match synPat with
434434
| SynPat.IsInst(_, m) ->
435435
(fun _ -> TPat_isinst (srcTy, tgtTy, None, m)), patEnv
@@ -445,11 +445,11 @@ and TcPatAttributed warnOnUpper cenv env vFlags patEnv ty innerPat attrs =
445445
TcPat warnOnUpper cenv env None vFlags patEnv ty innerPat
446446

447447
and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m =
448-
let (TcPatLinearEnv(_, names, takenNames)) = patEnv
448+
let (TcPatLinearEnv(_, names, takenNames, usesAP)) = patEnv
449449
let pat1R, patEnv1 = TcPat warnOnUpper cenv env None vFlags patEnv ty pat1
450-
let (TcPatLinearEnv(tpenv, names1, takenNames1)) = patEnv1
451-
let pat2R, patEnv2 = TcPat warnOnUpper cenv env None vFlags (TcPatLinearEnv(tpenv, names, takenNames)) ty pat2
452-
let (TcPatLinearEnv(tpenv, names2, takenNames2)) = patEnv2
450+
let (TcPatLinearEnv(tpenv, names1, takenNames1, usesAP1)) = patEnv1
451+
let pat2R, patEnv2 = TcPat warnOnUpper cenv env None vFlags (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) ty pat2
452+
let (TcPatLinearEnv(tpenv, names2, takenNames2, usesAP2)) = patEnv2
453453

454454
if takenNames1 <> takenNames2 then
455455
errorR (UnionPatternsBindDifferentNames m)
@@ -463,7 +463,7 @@ and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m =
463463

464464
let namesR = NameMap.layer names1 names2
465465
let takenNamesR = Set.union takenNames1 takenNames2
466-
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR)
466+
let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP1 || usesAP2)
467467
let phase2 values = TPat_disjs ([pat1R values; pat2R (values.WithRightPath())], m)
468468
phase2, patEnvR
469469

@@ -622,7 +622,7 @@ and TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (patEnv: TcPatLine
622622
/// Check a long identifier in a pattern that has been not been resolved to anything else and represents a new value, or nameof
623623
and TcPatLongIdentNewDef warnOnUpperForId warnOnUpper (cenv: cenv) env ad valReprInfo vFlags patEnv ty (vis, id, args, m) =
624624
let g = cenv.g
625-
let (TcPatLinearEnv(tpenv, _, _)) = patEnv
625+
let (TcPatLinearEnv(tpenv, _, _, _)) = patEnv
626626

627627
match GetSynArgPatterns args with
628628
| [] ->
@@ -858,7 +858,7 @@ and TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (mLongId, rfin
858858
/// Check a long identifier that has been resolved to an F# value that is a literal
859859
and TcPatLongIdentLiteral warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId, vref, args, m) =
860860
let g = cenv.g
861-
let (TcPatLinearEnv(tpenv, _, _)) = patEnv
861+
let (TcPatLinearEnv(tpenv, _, _, _)) = patEnv
862862

863863
match vref.LiteralValue with
864864
| None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m))

0 commit comments

Comments
 (0)