Skip to content

Commit 21d9638

Browse files
T-GroCopilot
T-Gro
and
Copilot
committed
Split TypeEncoding into XmlDocSignatures, NullnessAnalysis, TypeTestsAndPatterns
Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com>
1 parent 602cddc commit 21d9638

2 files changed

Lines changed: 132 additions & 120 deletions

File tree

‎src/Compiler/TypedTree/TypedTreeOps.Transforms.fs‎

Lines changed: 119 additions & 113 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ open FSharp.Compiler.TypeProviders
3636
#endif
3737

3838
[<AutoOpen>]
39-
module internal TypeEncoding =
39+
module internal XmlDocSignatures =
4040

4141
let commaEncs strs = String.concat "," strs
4242
let angleEnc str = "{" + str + "}"
@@ -228,6 +228,103 @@ module internal TypeEncoding =
228228
let XmlDocSigOfEntity (eref: EntityRef) =
229229
XmlDocSigOfTycon [ (buildAccessPath eref.CompilationPathOpt); eref.Deref.CompiledName ]
230230

231+
//---------------------------------------------------------------------------
232+
// Active pattern name helpers
233+
//---------------------------------------------------------------------------
234+
235+
let TryGetActivePatternInfo (vref: ValRef) =
236+
// First is an optimization to prevent calls to string routines
237+
let logicalName = vref.LogicalName
238+
239+
if logicalName.Length = 0 || logicalName[0] <> '|' then
240+
None
241+
else
242+
ActivePatternInfoOfValName vref.DisplayNameCoreMangled vref.Range
243+
244+
type ActivePatternElemRef with
245+
member x.LogicalName =
246+
let (APElemRef(_, vref, n, _)) = x
247+
248+
match TryGetActivePatternInfo vref with
249+
| None -> error (InternalError("not an active pattern name", vref.Range))
250+
| Some apinfo ->
251+
let nms = apinfo.ActiveTags
252+
253+
if n < 0 || n >= List.length nms then
254+
error (InternalError("name_of_apref: index out of range for active pattern reference", vref.Range))
255+
256+
List.item n nms
257+
258+
member x.DisplayNameCore = x.LogicalName
259+
260+
member x.DisplayName = x.LogicalName |> ConvertLogicalNameToDisplayName
261+
262+
let mkChoiceTyconRef (g: TcGlobals) m n =
263+
match n with
264+
| 0
265+
| 1 -> error (InternalError("mkChoiceTyconRef", m))
266+
| 2 -> g.choice2_tcr
267+
| 3 -> g.choice3_tcr
268+
| 4 -> g.choice4_tcr
269+
| 5 -> g.choice5_tcr
270+
| 6 -> g.choice6_tcr
271+
| 7 -> g.choice7_tcr
272+
| _ -> error (Error(FSComp.SR.tastActivePatternsLimitedToSeven (), m))
273+
274+
let mkChoiceTy (g: TcGlobals) m tinst =
275+
match List.length tinst with
276+
| 0 -> g.unit_ty
277+
| 1 -> List.head tinst
278+
| length -> mkWoNullAppTy (mkChoiceTyconRef g m length) tinst
279+
280+
let mkChoiceCaseRef g m n i =
281+
mkUnionCaseRef (mkChoiceTyconRef g m n) ("Choice" + string (i + 1) + "Of" + string n)
282+
283+
type ActivePatternInfo with
284+
285+
member x.DisplayNameCoreByIdx idx = x.ActiveTags[idx]
286+
287+
member x.DisplayNameByIdx idx =
288+
x.ActiveTags[idx] |> ConvertLogicalNameToDisplayName
289+
290+
member apinfo.ResultType g m retTys retKind =
291+
let choicety = mkChoiceTy g m retTys
292+
293+
if apinfo.IsTotal then
294+
choicety
295+
else
296+
match retKind with
297+
| ActivePatternReturnKind.RefTypeWrapper -> mkOptionTy g choicety
298+
| ActivePatternReturnKind.StructTypeWrapper -> mkValueOptionTy g choicety
299+
| ActivePatternReturnKind.Boolean -> g.bool_ty
300+
301+
member apinfo.OverallType g m argTy retTys retKind =
302+
mkFunTy g argTy (apinfo.ResultType g m retTys retKind)
303+
304+
//---------------------------------------------------------------------------
305+
// Active pattern validation
306+
//---------------------------------------------------------------------------
307+
308+
// check if an active pattern takes type parameters only bound by the return types,
309+
// not by their argument types.
310+
let doesActivePatternHaveFreeTypars g (v: ValRef) =
311+
let vty = v.TauType
312+
let vtps = v.Typars |> Zset.ofList typarOrder
313+
314+
if not (isFunTy g v.TauType) then
315+
errorR (Error(FSComp.SR.activePatternIdentIsNotFunctionTyped (v.LogicalName), v.Range))
316+
317+
let argTys, resty = stripFunTy g vty
318+
319+
let argtps, restps =
320+
(freeInTypes CollectTypars argTys).FreeTypars, (freeInType CollectTypars resty).FreeTypars
321+
// Error if an active pattern is generic in type variables that only occur in the result Choice<_, ...>.
322+
// Note: The test restricts to v.Typars since typars from the closure are considered fixed.
323+
not (Zset.isEmpty (Zset.inter (Zset.diff restps argtps) vtps))
324+
325+
[<AutoOpen>]
326+
module internal NullnessAnalysis =
327+
231328
let inline HasConstraint ([<InlineIfLambda>] predicate) (tp: Typar) = tp.Constraints |> List.exists predicate
232329

233330
let inline tryGetTyparTyWithConstraint g ([<InlineIfLambda>] predicate) ty =
@@ -458,6 +555,27 @@ module internal TypeEncoding =
458555

459556
let TypeHasDefaultValueNew g m ty = TypeHasDefaultValueAux true g m ty
460557

558+
let (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|) (ty, g) =
559+
let sty = ty |> stripTyEqns g
560+
561+
if isTyparTy g sty then
562+
if (nullnessOfTy g sty).TryEvaluate() = ValueSome NullnessInfo.WithNull then
563+
NullableTypar
564+
else
565+
TyparTy
566+
elif isStructTy g sty then
567+
StructTy
568+
elif TypeNullIsTrueValue g sty then
569+
NullTrueValue
570+
else
571+
match (nullnessOfTy g sty).TryEvaluate() with
572+
| ValueSome NullnessInfo.WithNull -> NullableRefType
573+
| ValueSome NullnessInfo.WithoutNull -> WithoutNullRefType
574+
| _ -> UnresolvedRefType
575+
576+
[<AutoOpen>]
577+
module internal TypeTestsAndPatterns =
578+
461579
/// Determines types that are potentially known to satisfy the 'comparable' constraint and returns
462580
/// a set of residual types that must also satisfy the constraint
463581
[<return: Struct>]
@@ -489,24 +607,6 @@ module internal TypeEncoding =
489607
let (|SpecialNotEquatableHeadType|_|) g ty =
490608
if isFunTy g ty then ValueSome() else ValueNone
491609

492-
let (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|) (ty, g) =
493-
let sty = ty |> stripTyEqns g
494-
495-
if isTyparTy g sty then
496-
if (nullnessOfTy g sty).TryEvaluate() = ValueSome NullnessInfo.WithNull then
497-
NullableTypar
498-
else
499-
TyparTy
500-
elif isStructTy g sty then
501-
StructTy
502-
elif TypeNullIsTrueValue g sty then
503-
NullTrueValue
504-
else
505-
match (nullnessOfTy g sty).TryEvaluate() with
506-
| ValueSome NullnessInfo.WithNull -> NullableRefType
507-
| ValueSome NullnessInfo.WithoutNull -> WithoutNullRefType
508-
| _ -> UnresolvedRefType
509-
510610
// Can we use the fast helper for the 'LanguagePrimitives.IntrinsicFunctions.TypeTestGeneric'?
511611
let canUseTypeTestFast g ty =
512612
not (isTyparTy g ty) && not (TypeNullIsTrueValue g ty)
@@ -615,100 +715,6 @@ module internal TypeEncoding =
615715
numEnclTypeArgs, virtualCall, isNewObj, isSuperInit, isSelfInit, takesInstanceArg, isPropGet, isPropSet
616716
| _ -> 0, false, false, false, false, false, false, false
617717

618-
//---------------------------------------------------------------------------
619-
// Active pattern name helpers
620-
//---------------------------------------------------------------------------
621-
622-
let TryGetActivePatternInfo (vref: ValRef) =
623-
// First is an optimization to prevent calls to string routines
624-
let logicalName = vref.LogicalName
625-
626-
if logicalName.Length = 0 || logicalName[0] <> '|' then
627-
None
628-
else
629-
ActivePatternInfoOfValName vref.DisplayNameCoreMangled vref.Range
630-
631-
type ActivePatternElemRef with
632-
member x.LogicalName =
633-
let (APElemRef(_, vref, n, _)) = x
634-
635-
match TryGetActivePatternInfo vref with
636-
| None -> error (InternalError("not an active pattern name", vref.Range))
637-
| Some apinfo ->
638-
let nms = apinfo.ActiveTags
639-
640-
if n < 0 || n >= List.length nms then
641-
error (InternalError("name_of_apref: index out of range for active pattern reference", vref.Range))
642-
643-
List.item n nms
644-
645-
member x.DisplayNameCore = x.LogicalName
646-
647-
member x.DisplayName = x.LogicalName |> ConvertLogicalNameToDisplayName
648-
649-
let mkChoiceTyconRef (g: TcGlobals) m n =
650-
match n with
651-
| 0
652-
| 1 -> error (InternalError("mkChoiceTyconRef", m))
653-
| 2 -> g.choice2_tcr
654-
| 3 -> g.choice3_tcr
655-
| 4 -> g.choice4_tcr
656-
| 5 -> g.choice5_tcr
657-
| 6 -> g.choice6_tcr
658-
| 7 -> g.choice7_tcr
659-
| _ -> error (Error(FSComp.SR.tastActivePatternsLimitedToSeven (), m))
660-
661-
let mkChoiceTy (g: TcGlobals) m tinst =
662-
match List.length tinst with
663-
| 0 -> g.unit_ty
664-
| 1 -> List.head tinst
665-
| length -> mkWoNullAppTy (mkChoiceTyconRef g m length) tinst
666-
667-
let mkChoiceCaseRef g m n i =
668-
mkUnionCaseRef (mkChoiceTyconRef g m n) ("Choice" + string (i + 1) + "Of" + string n)
669-
670-
type ActivePatternInfo with
671-
672-
member x.DisplayNameCoreByIdx idx = x.ActiveTags[idx]
673-
674-
member x.DisplayNameByIdx idx =
675-
x.ActiveTags[idx] |> ConvertLogicalNameToDisplayName
676-
677-
member apinfo.ResultType g m retTys retKind =
678-
let choicety = mkChoiceTy g m retTys
679-
680-
if apinfo.IsTotal then
681-
choicety
682-
else
683-
match retKind with
684-
| ActivePatternReturnKind.RefTypeWrapper -> mkOptionTy g choicety
685-
| ActivePatternReturnKind.StructTypeWrapper -> mkValueOptionTy g choicety
686-
| ActivePatternReturnKind.Boolean -> g.bool_ty
687-
688-
member apinfo.OverallType g m argTy retTys retKind =
689-
mkFunTy g argTy (apinfo.ResultType g m retTys retKind)
690-
691-
//---------------------------------------------------------------------------
692-
// Active pattern validation
693-
//---------------------------------------------------------------------------
694-
695-
// check if an active pattern takes type parameters only bound by the return types,
696-
// not by their argument types.
697-
let doesActivePatternHaveFreeTypars g (v: ValRef) =
698-
let vty = v.TauType
699-
let vtps = v.Typars |> Zset.ofList typarOrder
700-
701-
if not (isFunTy g v.TauType) then
702-
errorR (Error(FSComp.SR.activePatternIdentIsNotFunctionTyped (v.LogicalName), v.Range))
703-
704-
let argTys, resty = stripFunTy g vty
705-
706-
let argtps, restps =
707-
(freeInTypes CollectTypars argTys).FreeTypars, (freeInType CollectTypars resty).FreeTypars
708-
// Error if an active pattern is generic in type variables that only occur in the result Choice<_, ...>.
709-
// Note: The test restricts to v.Typars since typars from the closure are considered fixed.
710-
not (Zset.isEmpty (Zset.inter (Zset.diff restps argtps) vtps))
711-
712718
[<AutoOpen>]
713719
module internal Rewriting =
714720

‎src/Compiler/TypedTree/TypedTreeOps.Transforms.fsi‎

Lines changed: 13 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ open FSharp.Compiler.TypedTree
1616
open FSharp.Compiler.TypedTreeBasics
1717

1818
[<AutoOpen>]
19-
module internal TypeEncoding =
19+
module internal XmlDocSignatures =
2020

2121
/// XmlDoc signature helpers
2222
val commaEncs: string seq -> string
@@ -74,15 +74,15 @@ module internal TypeEncoding =
7474

7575
val doesActivePatternHaveFreeTypars: TcGlobals -> ValRef -> bool
7676

77+
[<AutoOpen>]
78+
module internal NullnessAnalysis =
79+
7780
val nullnessOfTy: TcGlobals -> TType -> Nullness
7881

7982
val changeWithNullReqTyToVariable: TcGlobals -> reqTy: TType -> TType
8083

8184
val reqTyForArgumentNullnessInference: TcGlobals -> actualTy: TType -> reqTy: TType -> TType
8285

83-
/// Determine if a type is a ComInterop type
84-
val isComInteropTy: TcGlobals -> TType -> bool
85-
8686
val IsNonNullableStructTyparTy: TcGlobals -> TType -> bool
8787

8888
val inline HasConstraint: [<InlineIfLambda>] predicate: (TyparConstraint -> bool) -> Typar -> bool
@@ -117,6 +117,15 @@ module internal TypeEncoding =
117117

118118
val TypeHasDefaultValueNew: TcGlobals -> range -> TType -> bool
119119

120+
val (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|):
121+
TType * TcGlobals -> Choice<unit, unit, unit, unit, unit, unit, unit>
122+
123+
[<AutoOpen>]
124+
module internal TypeTestsAndPatterns =
125+
126+
/// Determine if a type is a ComInterop type
127+
val isComInteropTy: TcGlobals -> TType -> bool
128+
120129
val mkIsInstConditional: TcGlobals -> range -> TType -> Expr -> Val -> Expr -> Expr -> Expr
121130

122131
val canUseUnboxFast: TcGlobals -> range -> TType -> bool
@@ -134,9 +143,6 @@ module internal TypeEncoding =
134143
[<return: Struct>]
135144
val (|SpecialNotEquatableHeadType|_|): TcGlobals -> TType -> unit voption
136145

137-
val (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|):
138-
TType * TcGlobals -> Choice<unit, unit, unit, unit, unit, unit, unit>
139-
140146
val GetMemberCallInfo: TcGlobals -> ValRef * ValUseFlag -> int * bool * bool * bool * bool * bool * bool * bool
141147

142148
[<AutoOpen>]

0 commit comments

Comments
 (0)