diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs
index 4e3452a2d8..a653b7133f 100644
--- a/src/Compiler/CodeGen/IlxGen.fs
+++ b/src/Compiler/CodeGen/IlxGen.fs
@@ -3208,7 +3208,7 @@ and DelayCodeGenMethodForExpr cenv mgbuf (_, _, eenv, _, _, _, _ as args) =
let change3rdOutOf7 (a1, a2, _, a4, a5, a6, a7) newA3 = (a1, a2, newA3, a4, a5, a6, a7)
if eenv.delayCodeGen then
- let cenv =
+ let cenv: cenv =
{ cenv with
stackGuard = getEmptyStackGuard ()
}
diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs
index dc6d346048..305b85409c 100644
--- a/src/Compiler/Driver/CompilerImports.fs
+++ b/src/Compiler/Driver/CompilerImports.fs
@@ -215,7 +215,7 @@ let WriteSignatureData (tcConfig: TcConfig, tcGlobals, exportRemapping, ccu: Ccu
let signatureDataFile =
FileSystem.ChangeExtensionShim(outputFile, ".signature-data.json")
- serializeEntity signatureDataFile mspec)
+ DebugPrint.serializeEntity signatureDataFile mspec)
// For historical reasons, we use a different resource name for FSharp.Core, so older F# compilers
// don't complain when they see the resource.
diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj
index 8a3782bcb3..de520e7814 100644
--- a/src/Compiler/FSharp.Compiler.Service.fsproj
+++ b/src/Compiler/FSharp.Compiler.Service.fsproj
@@ -336,8 +336,20 @@
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Attributes.fs b/src/Compiler/TypedTree/TypedTreeOps.Attributes.fs
new file mode 100644
index 0000000000..488cc8e252
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Attributes.fs
@@ -0,0 +1,2545 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// TypedTreeOps.Attributes: IL extensions, attribute helpers, and debug printing.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+open FSharp.Compiler
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal ILExtensions =
+
+ //----------------------------------------------------------------------------
+ // Detect attributes
+ //----------------------------------------------------------------------------
+
+ // AbsIL view of attributes (we read these from .NET binaries)
+ let isILAttribByName (tencl: string list, tname: string) (attr: ILAttribute) =
+ (attr.Method.DeclaringType.TypeSpec.Name = tname)
+ && (attr.Method.DeclaringType.TypeSpec.Enclosing = tencl)
+
+ // AbsIL view of attributes (we read these from .NET binaries). The comparison is done by name.
+ let isILAttrib (tref: ILTypeRef) (attr: ILAttribute) =
+ isILAttribByName (tref.Enclosing, tref.Name) attr
+
+ // REVIEW: consider supporting querying on Abstract IL custom attributes.
+ // These linear iterations cost us a fair bit when there are lots of attributes
+ // on imported types. However this is fairly rare and can also be solved by caching the
+ // results of attribute lookups in the TAST
+ let HasILAttribute tref (attrs: ILAttributes) =
+ attrs.AsArray() |> Array.exists (isILAttrib tref)
+
+ let TryDecodeILAttribute tref (attrs: ILAttributes) =
+ attrs.AsArray()
+ |> Array.tryPick (fun x ->
+ if isILAttrib tref x then
+ Some(decodeILAttribData x)
+ else
+ None)
+
+ // F# view of attributes (these get converted to AbsIL attributes in ilxgen)
+ let IsMatchingFSharpAttribute g (AttribInfo(_, tcref)) (Attrib(tcref2, _, _, _, _, _, _)) = tyconRefEq g tcref tcref2
+
+ let HasFSharpAttribute g tref attrs =
+ List.exists (IsMatchingFSharpAttribute g tref) attrs
+
+ let TryFindFSharpAttribute g tref attrs =
+ List.tryFind (IsMatchingFSharpAttribute g tref) attrs
+
+ []
+ let (|ExtractAttribNamedArg|_|) nm args =
+ args
+ |> List.tryPick (function
+ | AttribNamedArg(nm2, _, _, v) when nm = nm2 -> Some v
+ | _ -> None)
+ |> ValueOption.ofOption
+
+ []
+ let (|ExtractILAttributeNamedArg|_|) nm (args: ILAttributeNamedArg list) =
+ args
+ |> List.tryPick (function
+ | nm2, _, _, v when nm = nm2 -> Some v
+ | _ -> None)
+ |> ValueOption.ofOption
+
+ []
+ let (|StringExpr|_|) =
+ function
+ | Expr.Const(Const.String n, _, _) -> ValueSome n
+ | _ -> ValueNone
+
+ []
+ let (|AttribInt32Arg|_|) =
+ function
+ | AttribExpr(_, Expr.Const(Const.Int32 n, _, _)) -> ValueSome n
+ | _ -> ValueNone
+
+ []
+ let (|AttribInt16Arg|_|) =
+ function
+ | AttribExpr(_, Expr.Const(Const.Int16 n, _, _)) -> ValueSome n
+ | _ -> ValueNone
+
+ []
+ let (|AttribBoolArg|_|) =
+ function
+ | AttribExpr(_, Expr.Const(Const.Bool n, _, _)) -> ValueSome n
+ | _ -> ValueNone
+
+ []
+ let (|AttribStringArg|_|) =
+ function
+ | AttribExpr(_, Expr.Const(Const.String n, _, _)) -> ValueSome n
+ | _ -> ValueNone
+
+ let (|AttribElemStringArg|_|) =
+ function
+ | ILAttribElem.String(n) -> n
+ | _ -> None
+
+ let TryFindILAttribute (AttribInfo(atref, _)) attrs = HasILAttribute atref attrs
+
+ let IsILAttrib (AttribInfo(builtInAttrRef, _)) attr = isILAttrib builtInAttrRef attr
+
+ let inline hasFlag (flags: ^F) (flag: ^F) : bool when ^F: enum =
+ let f = LanguagePrimitives.EnumToValue flags
+ let v = LanguagePrimitives.EnumToValue flag
+ f &&& v <> 0uL
+
+ /// Compute well-known attribute flags for an ILAttributes collection.
+ /// Classify a single IL attribute, returning its well-known flag (or None).
+ let classifyILAttrib (attr: ILAttribute) : WellKnownILAttributes =
+ let atref = attr.Method.DeclaringType.TypeSpec.TypeRef
+
+ if not atref.Enclosing.IsEmpty then
+ WellKnownILAttributes.None
+ else
+ let name = atref.Name
+
+ if name.StartsWith("System.Runtime.CompilerServices.") then
+ match name with
+ | "System.Runtime.CompilerServices.IsReadOnlyAttribute" -> WellKnownILAttributes.IsReadOnlyAttribute
+ | "System.Runtime.CompilerServices.IsUnmanagedAttribute" -> WellKnownILAttributes.IsUnmanagedAttribute
+ | "System.Runtime.CompilerServices.ExtensionAttribute" -> WellKnownILAttributes.ExtensionAttribute
+ | "System.Runtime.CompilerServices.IsByRefLikeAttribute" -> WellKnownILAttributes.IsByRefLikeAttribute
+ | "System.Runtime.CompilerServices.InternalsVisibleToAttribute" -> WellKnownILAttributes.InternalsVisibleToAttribute
+ | "System.Runtime.CompilerServices.CallerMemberNameAttribute" -> WellKnownILAttributes.CallerMemberNameAttribute
+ | "System.Runtime.CompilerServices.CallerFilePathAttribute" -> WellKnownILAttributes.CallerFilePathAttribute
+ | "System.Runtime.CompilerServices.CallerLineNumberAttribute" -> WellKnownILAttributes.CallerLineNumberAttribute
+ | "System.Runtime.CompilerServices.RequiresLocationAttribute" -> WellKnownILAttributes.RequiresLocationAttribute
+ | "System.Runtime.CompilerServices.NullableAttribute" -> WellKnownILAttributes.NullableAttribute
+ | "System.Runtime.CompilerServices.NullableContextAttribute" -> WellKnownILAttributes.NullableContextAttribute
+ | "System.Runtime.CompilerServices.IDispatchConstantAttribute" -> WellKnownILAttributes.IDispatchConstantAttribute
+ | "System.Runtime.CompilerServices.IUnknownConstantAttribute" -> WellKnownILAttributes.IUnknownConstantAttribute
+ | "System.Runtime.CompilerServices.SetsRequiredMembersAttribute" -> WellKnownILAttributes.SetsRequiredMembersAttribute
+ | "System.Runtime.CompilerServices.CompilerFeatureRequiredAttribute" ->
+ WellKnownILAttributes.CompilerFeatureRequiredAttribute
+ | "System.Runtime.CompilerServices.RequiredMemberAttribute" -> WellKnownILAttributes.RequiredMemberAttribute
+ | _ -> WellKnownILAttributes.None
+
+ elif name.StartsWith("Microsoft.FSharp.Core.") then
+ match name with
+ | "Microsoft.FSharp.Core.AllowNullLiteralAttribute" -> WellKnownILAttributes.AllowNullLiteralAttribute
+ | "Microsoft.FSharp.Core.ReflectedDefinitionAttribute" -> WellKnownILAttributes.ReflectedDefinitionAttribute
+ | "Microsoft.FSharp.Core.AutoOpenAttribute" -> WellKnownILAttributes.AutoOpenAttribute
+ | "Microsoft.FSharp.Core.CompilerServices.NoEagerConstraintApplicationAttribute" ->
+ WellKnownILAttributes.NoEagerConstraintApplicationAttribute
+ | _ -> WellKnownILAttributes.None
+
+ else
+ match name with
+ | "System.ParamArrayAttribute" -> WellKnownILAttributes.ParamArrayAttribute
+ | "System.Reflection.DefaultMemberAttribute" -> WellKnownILAttributes.DefaultMemberAttribute
+ | "System.Diagnostics.CodeAnalysis.SetsRequiredMembersAttribute" ->
+ // Also at System.Runtime.CompilerServices (line above); .NET defines it in both namespaces
+ WellKnownILAttributes.SetsRequiredMembersAttribute
+ | "System.ObsoleteAttribute" -> WellKnownILAttributes.ObsoleteAttribute
+ | "System.Diagnostics.CodeAnalysis.ExperimentalAttribute" -> WellKnownILAttributes.ExperimentalAttribute
+ | "System.AttributeUsageAttribute" -> WellKnownILAttributes.AttributeUsageAttribute
+ | _ -> WellKnownILAttributes.None
+
+ /// Compute well-known attribute flags for an ILAttributes collection.
+ let computeILWellKnownFlags (_g: TcGlobals) (attrs: ILAttributes) : WellKnownILAttributes =
+ let mutable flags = WellKnownILAttributes.None
+
+ for attr in attrs.AsArray() do
+ flags <- flags ||| classifyILAttrib attr
+
+ flags
+
+ /// Find the first IL attribute matching a specific well-known flag and decode it.
+ let tryFindILAttribByFlag (flag: WellKnownILAttributes) (cattrs: ILAttributes) =
+ cattrs.AsArray()
+ |> Array.tryPick (fun attr ->
+ if classifyILAttrib attr &&& flag <> WellKnownILAttributes.None then
+ Some(decodeILAttribData attr)
+ else
+ None)
+
+ /// Active pattern: find and decode a well-known IL attribute.
+ /// Returns decoded (ILAttribElem list * ILAttributeNamedArg list).
+ []
+ let (|ILAttribDecoded|_|) (flag: WellKnownILAttributes) (cattrs: ILAttributes) =
+ tryFindILAttribByFlag flag cattrs |> ValueOption.ofOption
+
+ type ILAttributesStored with
+
+ member x.HasWellKnownAttribute(g: TcGlobals, flag: WellKnownILAttributes) =
+ x.HasWellKnownAttribute(flag, computeILWellKnownFlags g)
+
+ type ILTypeDef with
+
+ member x.HasWellKnownAttribute(g: TcGlobals, flag: WellKnownILAttributes) =
+ x.CustomAttrsStored.HasWellKnownAttribute(g, flag)
+
+ type ILMethodDef with
+
+ member x.HasWellKnownAttribute(g: TcGlobals, flag: WellKnownILAttributes) =
+ x.CustomAttrsStored.HasWellKnownAttribute(g, flag)
+
+ type ILFieldDef with
+
+ member x.HasWellKnownAttribute(g: TcGlobals, flag: WellKnownILAttributes) =
+ x.CustomAttrsStored.HasWellKnownAttribute(g, flag)
+
+ type ILAttributes with
+
+ /// Non-caching (unlike ILAttributesStored.HasWellKnownAttribute which caches).
+ member x.HasWellKnownAttribute(flag: WellKnownILAttributes) =
+ x.AsArray()
+ |> Array.exists (fun attr -> classifyILAttrib attr &&& flag <> WellKnownILAttributes.None)
+
+[]
+module internal AttributeHelpers =
+
+ /// Resolve the FSharp.Core path for an attribute's type reference.
+ /// Returns struct(bclPath, fsharpCorePath). Exactly one will be ValueSome, or both ValueNone.
+ let inline resolveAttribPath (g: TcGlobals) (tcref: TyconRef) : struct (string[] voption * string[] voption) =
+ if not tcref.IsLocalRef then
+ let nlr = tcref.nlr
+
+ if ccuEq nlr.Ccu g.fslibCcu then
+ struct (ValueNone, ValueSome nlr.Path)
+ else
+ struct (ValueSome nlr.Path, ValueNone)
+ elif g.compilingFSharpCore then
+ match tcref.Deref.PublicPath with
+ | Some(PubPath pp) -> struct (ValueNone, ValueSome pp)
+ | None -> struct (ValueNone, ValueNone)
+ else
+ struct (ValueNone, ValueNone)
+
+ /// Decode a bool-arg attribute and set the appropriate true/false flag.
+ let inline decodeBoolAttribFlag (attrib: Attrib) trueFlag falseFlag defaultFlag =
+ match attrib with
+ | Attrib(_, _, [ AttribBoolArg b ], _, _, _, _) -> if b then trueFlag else falseFlag
+ | _ -> defaultFlag
+
+ /// Classify a single Entity-level attribute, returning its well-known flag (or None).
+ let classifyEntityAttrib (g: TcGlobals) (attrib: Attrib) : WellKnownEntityAttributes =
+ let (Attrib(tcref, _, _, _, _, _, _)) = attrib
+ let struct (bclPath, fsharpCorePath) = resolveAttribPath g tcref
+
+ match bclPath with
+ | ValueSome path ->
+ match path with
+ | [| "System"; "Runtime"; "CompilerServices"; name |] ->
+ match name with
+ | "ExtensionAttribute" -> WellKnownEntityAttributes.ExtensionAttribute
+ | "IsReadOnlyAttribute" -> WellKnownEntityAttributes.IsReadOnlyAttribute
+ | "SkipLocalsInitAttribute" -> WellKnownEntityAttributes.SkipLocalsInitAttribute
+ | "IsByRefLikeAttribute" -> WellKnownEntityAttributes.IsByRefLikeAttribute
+ | _ -> WellKnownEntityAttributes.None
+
+ | [| "System"; "Runtime"; "InteropServices"; name |] ->
+ match name with
+ | "StructLayoutAttribute" -> WellKnownEntityAttributes.StructLayoutAttribute
+ | "DllImportAttribute" -> WellKnownEntityAttributes.DllImportAttribute
+ | "ComVisibleAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownEntityAttributes.ComVisibleAttribute_True
+ WellKnownEntityAttributes.ComVisibleAttribute_False
+ WellKnownEntityAttributes.ComVisibleAttribute_True
+ | "ComImportAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownEntityAttributes.ComImportAttribute_True
+ WellKnownEntityAttributes.None
+ WellKnownEntityAttributes.ComImportAttribute_True
+ | _ -> WellKnownEntityAttributes.None
+
+ | [| "System"; "Diagnostics"; name |] ->
+ match name with
+ | "DebuggerDisplayAttribute" -> WellKnownEntityAttributes.DebuggerDisplayAttribute
+ | "DebuggerTypeProxyAttribute" -> WellKnownEntityAttributes.DebuggerTypeProxyAttribute
+ | _ -> WellKnownEntityAttributes.None
+
+ | [| "System"; "ComponentModel"; name |] ->
+ match name with
+ | "EditorBrowsableAttribute" -> WellKnownEntityAttributes.EditorBrowsableAttribute
+ | _ -> WellKnownEntityAttributes.None
+
+ | [| "System"; name |] ->
+ match name with
+ | "AttributeUsageAttribute" -> WellKnownEntityAttributes.AttributeUsageAttribute
+ | "ObsoleteAttribute" -> WellKnownEntityAttributes.ObsoleteAttribute
+ | _ -> WellKnownEntityAttributes.None
+
+ | _ -> WellKnownEntityAttributes.None
+
+ | ValueNone ->
+
+ match fsharpCorePath with
+ | ValueSome path ->
+ match path with
+ | [| "Microsoft"; "FSharp"; "Core"; name |] ->
+ match name with
+ | "SealedAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownEntityAttributes.SealedAttribute_True
+ WellKnownEntityAttributes.SealedAttribute_False
+ WellKnownEntityAttributes.SealedAttribute_True
+ | "AbstractClassAttribute" -> WellKnownEntityAttributes.AbstractClassAttribute
+ | "RequireQualifiedAccessAttribute" -> WellKnownEntityAttributes.RequireQualifiedAccessAttribute
+ | "AutoOpenAttribute" -> WellKnownEntityAttributes.AutoOpenAttribute
+ | "NoEqualityAttribute" -> WellKnownEntityAttributes.NoEqualityAttribute
+ | "NoComparisonAttribute" -> WellKnownEntityAttributes.NoComparisonAttribute
+ | "StructuralEqualityAttribute" -> WellKnownEntityAttributes.StructuralEqualityAttribute
+ | "StructuralComparisonAttribute" -> WellKnownEntityAttributes.StructuralComparisonAttribute
+ | "CustomEqualityAttribute" -> WellKnownEntityAttributes.CustomEqualityAttribute
+ | "CustomComparisonAttribute" -> WellKnownEntityAttributes.CustomComparisonAttribute
+ | "ReferenceEqualityAttribute" -> WellKnownEntityAttributes.ReferenceEqualityAttribute
+ | "DefaultAugmentationAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownEntityAttributes.DefaultAugmentationAttribute_True
+ WellKnownEntityAttributes.DefaultAugmentationAttribute_False
+ WellKnownEntityAttributes.DefaultAugmentationAttribute_True
+ | "CLIMutableAttribute" -> WellKnownEntityAttributes.CLIMutableAttribute
+ | "AutoSerializableAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownEntityAttributes.AutoSerializableAttribute_True
+ WellKnownEntityAttributes.AutoSerializableAttribute_False
+ WellKnownEntityAttributes.AutoSerializableAttribute_True
+ | "ReflectedDefinitionAttribute" -> WellKnownEntityAttributes.ReflectedDefinitionAttribute
+ | "AllowNullLiteralAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownEntityAttributes.AllowNullLiteralAttribute_True
+ WellKnownEntityAttributes.AllowNullLiteralAttribute_False
+ WellKnownEntityAttributes.AllowNullLiteralAttribute_True
+ | "WarnOnWithoutNullArgumentAttribute" -> WellKnownEntityAttributes.WarnOnWithoutNullArgumentAttribute
+ | "ClassAttribute" -> WellKnownEntityAttributes.ClassAttribute
+ | "InterfaceAttribute" -> WellKnownEntityAttributes.InterfaceAttribute
+ | "StructAttribute" -> WellKnownEntityAttributes.StructAttribute
+ | "MeasureAttribute" -> WellKnownEntityAttributes.MeasureAttribute
+ | "MeasureAnnotatedAbbreviationAttribute" -> WellKnownEntityAttributes.MeasureableAttribute
+ | "CLIEventAttribute" -> WellKnownEntityAttributes.CLIEventAttribute
+ | "CompilerMessageAttribute" -> WellKnownEntityAttributes.CompilerMessageAttribute
+ | "ExperimentalAttribute" -> WellKnownEntityAttributes.ExperimentalAttribute
+ | "UnverifiableAttribute" -> WellKnownEntityAttributes.UnverifiableAttribute
+ | "CompiledNameAttribute" -> WellKnownEntityAttributes.CompiledNameAttribute
+ | "CompilationRepresentationAttribute" ->
+ match attrib with
+ | Attrib(_, _, [ AttribInt32Arg v ], _, _, _, _) ->
+ let mutable flags = WellKnownEntityAttributes.None
+
+ if v &&& 0x01 <> 0 then
+ flags <- flags ||| WellKnownEntityAttributes.CompilationRepresentation_Static
+
+ if v &&& 0x02 <> 0 then
+ flags <- flags ||| WellKnownEntityAttributes.CompilationRepresentation_Instance
+
+ if v &&& 0x04 <> 0 then
+ flags <- flags ||| WellKnownEntityAttributes.CompilationRepresentation_ModuleSuffix
+
+ if v &&& 0x08 <> 0 then
+ flags <- flags ||| WellKnownEntityAttributes.CompilationRepresentation_PermitNull
+
+ flags
+ | _ -> WellKnownEntityAttributes.None
+ | _ -> WellKnownEntityAttributes.None
+ | _ -> WellKnownEntityAttributes.None
+ | ValueNone -> WellKnownEntityAttributes.None
+
+ /// Classify a single assembly-level attribute, returning its well-known flag (or None).
+ let classifyAssemblyAttrib (g: TcGlobals) (attrib: Attrib) : WellKnownAssemblyAttributes =
+ let (Attrib(tcref, _, _, _, _, _, _)) = attrib
+ let struct (bclPath, fsharpCorePath) = resolveAttribPath g tcref
+
+ match bclPath with
+ | ValueSome path ->
+ match path with
+ | [| "System"; "Runtime"; "CompilerServices"; name |] ->
+ match name with
+ | "InternalsVisibleToAttribute" -> WellKnownAssemblyAttributes.InternalsVisibleToAttribute
+ | _ -> WellKnownAssemblyAttributes.None
+ | [| "System"; "Reflection"; name |] ->
+ match name with
+ | "AssemblyCultureAttribute" -> WellKnownAssemblyAttributes.AssemblyCultureAttribute
+ | "AssemblyVersionAttribute" -> WellKnownAssemblyAttributes.AssemblyVersionAttribute
+ | _ -> WellKnownAssemblyAttributes.None
+ | _ -> WellKnownAssemblyAttributes.None
+ | ValueNone ->
+
+ match fsharpCorePath with
+ | ValueSome path ->
+ match path with
+ | [| "Microsoft"; "FSharp"; "Core"; name |] ->
+ match name with
+ | "AutoOpenAttribute" -> WellKnownAssemblyAttributes.AutoOpenAttribute
+ | _ -> WellKnownAssemblyAttributes.None
+ | [| "Microsoft"; "FSharp"; "Core"; "CompilerServices"; name |] ->
+ match name with
+ | "TypeProviderAssemblyAttribute" -> WellKnownAssemblyAttributes.TypeProviderAssemblyAttribute
+ | _ -> WellKnownAssemblyAttributes.None
+ | _ -> WellKnownAssemblyAttributes.None
+ | ValueNone -> WellKnownAssemblyAttributes.None
+
+ // ---------------------------------------------------------------
+ // Well-Known Attribute APIs — Navigation Guide
+ // ---------------------------------------------------------------
+ //
+ // This section provides O(1) cached lookups for well-known attributes.
+ // Choose the right API based on what you have and what you need:
+ //
+ // EXISTENCE CHECKS (cached, O(1) after first call):
+ // EntityHasWellKnownAttribute g flag entity — Entity (type/module)
+ // ValHasWellKnownAttribute g flag v — Val (value/member)
+ // ArgReprInfoHasWellKnownAttribute g flag arg — ArgReprInfo (parameter)
+ //
+ // AD-HOC CHECKS (no cache, re-scans each call):
+ // attribsHaveEntityFlag g flag attribs — raw Attrib list, entity flags
+ // attribsHaveValFlag g flag attribs — raw Attrib list, val flags
+ //
+ // DATA EXTRACTION (active patterns):
+ // (|EntityAttrib|_|) g flag attribs — returns full Attrib
+ // (|ValAttrib|_|) g flag attribs — returns full Attrib
+ // (|EntityAttribInt|_|) g flag attribs — extracts int32 argument
+ // (|EntityAttribString|_|) g flag attribs — extracts string argument
+ // (|ValAttribInt|_|) g flag attribs — extracts int32 argument
+ // (|ValAttribString|_|) g flag attribs — extracts string argument
+ //
+ // BOOL ATTRIBUTE QUERIES (three-state: Some true / Some false / None):
+ // EntityTryGetBoolAttribute g trueFlag falseFlag entity
+ // ValTryGetBoolAttribute g trueFlag falseFlag v
+ //
+ // IL-LEVEL (operates on ILAttribute / ILAttributes):
+ // classifyILAttrib attr — classify a single IL attr
+ // (|ILAttribDecoded|_|) flag cattrs — find & decode by flag
+ // ILAttributes.HasWellKnownAttribute(flag) — existence check (no cache)
+ // ILAttributesStored.HasWellKnownAttribute(g, flag) — cached existence
+ //
+ // CROSS-METADATA (IL + F# + Provided type dispatch):
+ // TyconRefHasWellKnownAttribute g flag tcref
+ // TyconRefAllowsNull g tcref
+ //
+ // CROSS-METADATA (in AttributeChecking.fs):
+ // MethInfoHasWellKnownAttribute g m ilFlag valFlag attribSpec minfo
+ // MethInfoHasWellKnownAttributeSpec g m spec minfo — convenience wrapper
+ //
+ // CLASSIFICATION (maps attribute → flag enum):
+ // classifyEntityAttrib g attrib — Attrib → WellKnownEntityAttributes
+ // classifyValAttrib g attrib — Attrib → WellKnownValAttributes
+ // classifyILAttrib attr — ILAttribute → WellKnownILAttributes
+ // ---------------------------------------------------------------
+
+ /// Shared combinator: find first attrib matching a flag via a classify function.
+ let inline internal tryFindAttribByClassifier
+ ([] classify: TcGlobals -> Attrib -> 'Flag)
+ (none: 'Flag)
+ (g: TcGlobals)
+ (flag: 'Flag)
+ (attribs: Attribs)
+ : Attrib option =
+ attribs |> List.tryFind (fun attrib -> classify g attrib &&& flag <> none)
+
+ /// Shared combinator: check if any attrib in a list matches a flag via a classify function.
+ let inline internal attribsHaveFlag
+ ([] classify: TcGlobals -> Attrib -> 'Flag)
+ (none: 'Flag)
+ (g: TcGlobals)
+ (flag: 'Flag)
+ (attribs: Attribs)
+ : bool =
+ attribs |> List.exists (fun attrib -> classify g attrib &&& flag <> none)
+
+ /// Compute well-known attribute flags for an Entity's Attrib list.
+ let computeEntityWellKnownFlags (g: TcGlobals) (attribs: Attribs) : WellKnownEntityAttributes =
+ let mutable flags = WellKnownEntityAttributes.None
+
+ for attrib in attribs do
+ flags <- flags ||| classifyEntityAttrib g attrib
+
+ flags
+
+ /// Find the first attribute matching a specific well-known entity flag.
+ let tryFindEntityAttribByFlag g flag attribs =
+ tryFindAttribByClassifier classifyEntityAttrib WellKnownEntityAttributes.None g flag attribs
+
+ /// Active pattern: find a well-known entity attribute and return the full Attrib.
+ []
+ let (|EntityAttrib|_|) (g: TcGlobals) (flag: WellKnownEntityAttributes) (attribs: Attribs) =
+ tryFindEntityAttribByFlag g flag attribs |> ValueOption.ofOption
+
+ /// Active pattern: extract a single int32 argument from a well-known entity attribute.
+ []
+ let (|EntityAttribInt|_|) (g: TcGlobals) (flag: WellKnownEntityAttributes) (attribs: Attribs) =
+ match attribs with
+ | EntityAttrib g flag (Attrib(_, _, [ AttribInt32Arg v ], _, _, _, _)) -> ValueSome v
+ | _ -> ValueNone
+
+ /// Active pattern: extract a single string argument from a well-known entity attribute.
+ []
+ let (|EntityAttribString|_|) (g: TcGlobals) (flag: WellKnownEntityAttributes) (attribs: Attribs) =
+ match attribs with
+ | EntityAttrib g flag (Attrib(_, _, [ AttribStringArg s ], _, _, _, _)) -> ValueSome s
+ | _ -> ValueNone
+
+ /// Map a WellKnownILAttributes flag to its entity flag + provided-type AttribInfo equivalents.
+ let mapILFlag (g: TcGlobals) (flag: WellKnownILAttributes) : struct (WellKnownEntityAttributes * BuiltinAttribInfo option) =
+ match flag with
+ | WellKnownILAttributes.IsReadOnlyAttribute ->
+ struct (WellKnownEntityAttributes.IsReadOnlyAttribute, Some g.attrib_IsReadOnlyAttribute)
+ | WellKnownILAttributes.IsByRefLikeAttribute ->
+ struct (WellKnownEntityAttributes.IsByRefLikeAttribute, g.attrib_IsByRefLikeAttribute_opt)
+ | WellKnownILAttributes.ExtensionAttribute ->
+ struct (WellKnownEntityAttributes.ExtensionAttribute, Some g.attrib_ExtensionAttribute)
+ | WellKnownILAttributes.AllowNullLiteralAttribute ->
+ struct (WellKnownEntityAttributes.AllowNullLiteralAttribute_True, Some g.attrib_AllowNullLiteralAttribute)
+ | WellKnownILAttributes.AutoOpenAttribute -> struct (WellKnownEntityAttributes.AutoOpenAttribute, Some g.attrib_AutoOpenAttribute)
+ | WellKnownILAttributes.ReflectedDefinitionAttribute ->
+ struct (WellKnownEntityAttributes.ReflectedDefinitionAttribute, Some g.attrib_ReflectedDefinitionAttribute)
+ | WellKnownILAttributes.ObsoleteAttribute -> struct (WellKnownEntityAttributes.ObsoleteAttribute, None)
+ | _ -> struct (WellKnownEntityAttributes.None, None)
+
+ /// Check if a raw attribute list has a specific well-known entity flag (ad-hoc, non-caching).
+ let attribsHaveEntityFlag g (flag: WellKnownEntityAttributes) (attribs: Attribs) =
+ attribsHaveFlag classifyEntityAttrib WellKnownEntityAttributes.None g flag attribs
+
+ /// Map a WellKnownILAttributes flag to its WellKnownValAttributes equivalent.
+ /// Check if an Entity has a specific well-known attribute, computing and caching flags if needed.
+ let EntityHasWellKnownAttribute (g: TcGlobals) (flag: WellKnownEntityAttributes) (entity: Entity) : bool =
+ entity.HasWellKnownAttribute(flag, computeEntityWellKnownFlags g)
+
+ /// Get the computed well-known attribute flags for an entity.
+ let GetEntityWellKnownFlags (g: TcGlobals) (entity: Entity) : WellKnownEntityAttributes =
+ entity.GetWellKnownEntityFlags(computeEntityWellKnownFlags g)
+
+ /// Classify a single Val-level attribute, returning its well-known flag (or None).
+ let classifyValAttrib (g: TcGlobals) (attrib: Attrib) : WellKnownValAttributes =
+ let (Attrib(tcref, _, _, _, _, _, _)) = attrib
+ let struct (bclPath, fsharpCorePath) = resolveAttribPath g tcref
+
+ match bclPath with
+ | ValueSome path ->
+ match path with
+ | [| "System"; "Runtime"; "CompilerServices"; name |] ->
+ match name with
+ | "SkipLocalsInitAttribute" -> WellKnownValAttributes.SkipLocalsInitAttribute
+ | "ExtensionAttribute" -> WellKnownValAttributes.ExtensionAttribute
+ | "CallerMemberNameAttribute" -> WellKnownValAttributes.CallerMemberNameAttribute
+ | "CallerFilePathAttribute" -> WellKnownValAttributes.CallerFilePathAttribute
+ | "CallerLineNumberAttribute" -> WellKnownValAttributes.CallerLineNumberAttribute
+ | "MethodImplAttribute" -> WellKnownValAttributes.MethodImplAttribute
+ | _ -> WellKnownValAttributes.None
+
+ | [| "System"; "Runtime"; "InteropServices"; name |] ->
+ match name with
+ | "DllImportAttribute" -> WellKnownValAttributes.DllImportAttribute
+ | "InAttribute" -> WellKnownValAttributes.InAttribute
+ | "OutAttribute" -> WellKnownValAttributes.OutAttribute
+ | "MarshalAsAttribute" -> WellKnownValAttributes.MarshalAsAttribute
+ | "DefaultParameterValueAttribute" -> WellKnownValAttributes.DefaultParameterValueAttribute
+ | "OptionalAttribute" -> WellKnownValAttributes.OptionalAttribute
+ | "PreserveSigAttribute" -> WellKnownValAttributes.PreserveSigAttribute
+ | "FieldOffsetAttribute" -> WellKnownValAttributes.FieldOffsetAttribute
+ | _ -> WellKnownValAttributes.None
+
+ | [| "System"; "Diagnostics"; name |] ->
+ match name with
+ | "ConditionalAttribute" -> WellKnownValAttributes.ConditionalAttribute
+ | _ -> WellKnownValAttributes.None
+
+ | [| "System"; name |] ->
+ match name with
+ | "ThreadStaticAttribute" -> WellKnownValAttributes.ThreadStaticAttribute
+ | "ContextStaticAttribute" -> WellKnownValAttributes.ContextStaticAttribute
+ | "ParamArrayAttribute" -> WellKnownValAttributes.ParamArrayAttribute
+ | "NonSerializedAttribute" -> WellKnownValAttributes.NonSerializedAttribute
+ | _ -> WellKnownValAttributes.None
+
+ | _ -> WellKnownValAttributes.None
+
+ | ValueNone ->
+
+ match fsharpCorePath with
+ | ValueSome path ->
+ match path with
+ | [| "Microsoft"; "FSharp"; "Core"; name |] ->
+ match name with
+ | "EntryPointAttribute" -> WellKnownValAttributes.EntryPointAttribute
+ | "LiteralAttribute" -> WellKnownValAttributes.LiteralAttribute
+ | "ReflectedDefinitionAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownValAttributes.ReflectedDefinitionAttribute_True
+ WellKnownValAttributes.ReflectedDefinitionAttribute_False
+ WellKnownValAttributes.ReflectedDefinitionAttribute_False
+ | "RequiresExplicitTypeArgumentsAttribute" -> WellKnownValAttributes.RequiresExplicitTypeArgumentsAttribute
+ | "DefaultValueAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownValAttributes.DefaultValueAttribute_True
+ WellKnownValAttributes.DefaultValueAttribute_False
+ WellKnownValAttributes.DefaultValueAttribute_True
+ | "VolatileFieldAttribute" -> WellKnownValAttributes.VolatileFieldAttribute
+ | "NoDynamicInvocationAttribute" ->
+ decodeBoolAttribFlag
+ attrib
+ WellKnownValAttributes.NoDynamicInvocationAttribute_True
+ WellKnownValAttributes.NoDynamicInvocationAttribute_False
+ WellKnownValAttributes.NoDynamicInvocationAttribute_False
+ | "OptionalArgumentAttribute" -> WellKnownValAttributes.OptionalArgumentAttribute
+ | "ProjectionParameterAttribute" -> WellKnownValAttributes.ProjectionParameterAttribute
+ | "InlineIfLambdaAttribute" -> WellKnownValAttributes.InlineIfLambdaAttribute
+ | "StructAttribute" -> WellKnownValAttributes.StructAttribute
+ | "NoCompilerInliningAttribute" -> WellKnownValAttributes.NoCompilerInliningAttribute
+ | "GeneralizableValueAttribute" -> WellKnownValAttributes.GeneralizableValueAttribute
+ | "CLIEventAttribute" -> WellKnownValAttributes.CLIEventAttribute
+ | "CompiledNameAttribute" -> WellKnownValAttributes.CompiledNameAttribute
+ | "WarnOnWithoutNullArgumentAttribute" -> WellKnownValAttributes.WarnOnWithoutNullArgumentAttribute
+ | "ValueAsStaticPropertyAttribute" -> WellKnownValAttributes.ValueAsStaticPropertyAttribute
+ | "TailCallAttribute" -> WellKnownValAttributes.TailCallAttribute
+ | _ -> WellKnownValAttributes.None
+ | [| "Microsoft"; "FSharp"; "Core"; "CompilerServices"; name |] ->
+ match name with
+ | "NoEagerConstraintApplicationAttribute" -> WellKnownValAttributes.NoEagerConstraintApplicationAttribute
+ | _ -> WellKnownValAttributes.None
+ | _ -> WellKnownValAttributes.None
+ | ValueNone -> WellKnownValAttributes.None
+
+ let computeValWellKnownFlags (g: TcGlobals) (attribs: Attribs) : WellKnownValAttributes =
+ let mutable flags = WellKnownValAttributes.None
+
+ for attrib in attribs do
+ flags <- flags ||| classifyValAttrib g attrib
+
+ flags
+
+ /// Find the first attribute in a list that matches a specific well-known val flag.
+ let tryFindValAttribByFlag g flag attribs =
+ tryFindAttribByClassifier classifyValAttrib WellKnownValAttributes.None g flag attribs
+
+ /// Active pattern: find a well-known val attribute and return the full Attrib.
+ []
+ let (|ValAttrib|_|) (g: TcGlobals) (flag: WellKnownValAttributes) (attribs: Attribs) =
+ tryFindValAttribByFlag g flag attribs |> ValueOption.ofOption
+
+ /// Active pattern: extract a single int32 argument from a well-known val attribute.
+ []
+ let (|ValAttribInt|_|) (g: TcGlobals) (flag: WellKnownValAttributes) (attribs: Attribs) =
+ match attribs with
+ | ValAttrib g flag (Attrib(_, _, [ AttribInt32Arg v ], _, _, _, _)) -> ValueSome v
+ | _ -> ValueNone
+
+ /// Active pattern: extract a single string argument from a well-known val attribute.
+ []
+ let (|ValAttribString|_|) (g: TcGlobals) (flag: WellKnownValAttributes) (attribs: Attribs) =
+ match attribs with
+ | ValAttrib g flag (Attrib(_, _, [ AttribStringArg s ], _, _, _, _)) -> ValueSome s
+ | _ -> ValueNone
+
+ /// Check if a raw attribute list has a specific well-known val flag (ad-hoc, non-caching).
+ let attribsHaveValFlag g (flag: WellKnownValAttributes) (attribs: Attribs) =
+ attribsHaveFlag classifyValAttrib WellKnownValAttributes.None g flag attribs
+
+ /// Filter out well-known attributes from a list. Single-pass using classify functions.
+ /// Attributes matching ANY set bit in entityMask or valMask are removed.
+ let filterOutWellKnownAttribs
+ (g: TcGlobals)
+ (entityMask: WellKnownEntityAttributes)
+ (valMask: WellKnownValAttributes)
+ (attribs: Attribs)
+ =
+ attribs
+ |> List.filter (fun attrib ->
+ (entityMask = WellKnownEntityAttributes.None
+ || classifyEntityAttrib g attrib &&& entityMask = WellKnownEntityAttributes.None)
+ && (valMask = WellKnownValAttributes.None
+ || classifyValAttrib g attrib &&& valMask = WellKnownValAttributes.None))
+
+ /// Check if an ArgReprInfo has a specific well-known attribute, computing and caching flags if needed.
+ let ArgReprInfoHasWellKnownAttribute (g: TcGlobals) (flag: WellKnownValAttributes) (argInfo: ArgReprInfo) : bool =
+ let struct (result, waNew, changed) =
+ argInfo.Attribs.CheckFlag(flag, computeValWellKnownFlags g)
+
+ if changed then
+ argInfo.Attribs <- waNew
+
+ result
+
+ /// Check if a Val has a specific well-known attribute, computing and caching flags if needed.
+ let ValHasWellKnownAttribute (g: TcGlobals) (flag: WellKnownValAttributes) (v: Val) : bool =
+ v.HasWellKnownAttribute(flag, computeValWellKnownFlags g)
+
+ /// Query a three-state bool attribute on an entity. Returns bool option.
+ let EntityTryGetBoolAttribute
+ (g: TcGlobals)
+ (trueFlag: WellKnownEntityAttributes)
+ (falseFlag: WellKnownEntityAttributes)
+ (entity: Entity)
+ : bool option =
+ if not (entity.HasWellKnownAttribute(trueFlag ||| falseFlag, computeEntityWellKnownFlags g)) then
+ Option.None
+ else
+ let struct (hasTrue, _, _) =
+ entity.EntityAttribs.CheckFlag(trueFlag, computeEntityWellKnownFlags g)
+
+ if hasTrue then Some true else Some false
+
+ /// Query a three-state bool attribute on a Val. Returns bool option.
+ let ValTryGetBoolAttribute
+ (g: TcGlobals)
+ (trueFlag: WellKnownValAttributes)
+ (falseFlag: WellKnownValAttributes)
+ (v: Val)
+ : bool option =
+ if not (v.HasWellKnownAttribute(trueFlag ||| falseFlag, computeValWellKnownFlags g)) then
+ Option.None
+ else
+ let struct (hasTrue, _, _) =
+ v.ValAttribs.CheckFlag(trueFlag, computeValWellKnownFlags g)
+
+ if hasTrue then Some true else Some false
+
+ /// Shared core for binding attributes on type definitions, supporting an optional
+ /// WellKnownILAttributes flag for O(1) early exit on the IL metadata path.
+ let private tryBindTyconRefAttributeCore
+ g
+ (m: range)
+ (ilFlag: WellKnownILAttributes voption)
+ (AttribInfo(atref, _) as args)
+ (tcref: TyconRef)
+ f1
+ f2
+ (f3: obj option list * (string * obj option) list -> 'a option)
+ : 'a option =
+ ignore m
+ ignore f3
+
+ match metadataOfTycon tcref.Deref with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info ->
+ let provAttribs =
+ info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)), m)
+
+ match
+ provAttribs.PUntaint(
+ (fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure id, atref.FullName)),
+ m
+ )
+ with
+ | Some args -> f3 args
+ | None -> None
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, tdef)) ->
+ match ilFlag with
+ | ValueSome flag when not (tdef.HasWellKnownAttribute(g, flag)) -> None
+ | _ ->
+ match TryDecodeILAttribute atref tdef.CustomAttrs with
+ | Some attr -> f1 attr
+ | _ -> None
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ match TryFindFSharpAttribute g args tcref.Attribs with
+ | Some attr -> f2 attr
+ | _ -> None
+
+ /// Analyze three cases for attributes declared on type definitions: IL-declared attributes, F#-declared attributes and
+ /// provided attributes.
+ //
+ // This is used for AttributeUsageAttribute, DefaultMemberAttribute and ConditionalAttribute (on attribute types)
+ let TryBindTyconRefAttribute g (m: range) args (tcref: TyconRef) f1 f2 f3 : 'a option =
+ tryBindTyconRefAttributeCore g m ValueNone args tcref f1 f2 f3
+
+ let TryFindTyconRefBoolAttribute g m attribSpec tcref =
+ TryBindTyconRefAttribute
+ g
+ m
+ attribSpec
+ tcref
+ (function
+ | [], _ -> Some true
+ | [ ILAttribElem.Bool v ], _ -> Some v
+ | _ -> None)
+ (function
+ | Attrib(_, _, [], _, _, _, _) -> Some true
+ | Attrib(_, _, [ AttribBoolArg v ], _, _, _, _) -> Some v
+ | _ -> None)
+ (function
+ | [], _ -> Some true
+ | [ Some(:? bool as v: obj) ], _ -> Some v
+ | _ -> None)
+
+ /// Try to find the resolved attributeusage for an type by walking its inheritance tree and picking the correct attribute usage value
+ let TryFindAttributeUsageAttribute g m tcref =
+ [| yield tcref; yield! supersOfTyconRef tcref |]
+ |> Array.tryPick (fun tcref ->
+ TryBindTyconRefAttribute
+ g
+ m
+ g.attrib_AttributeUsageAttribute
+ tcref
+ (fun (_, named) ->
+ named
+ |> List.tryPick (function
+ | "AllowMultiple", _, _, ILAttribElem.Bool res -> Some res
+ | _ -> None))
+ (fun (Attrib(_, _, _, named, _, _, _)) ->
+ named
+ |> List.tryPick (function
+ | AttribNamedArg("AllowMultiple", _, _, AttribBoolArg res) -> Some res
+ | _ -> None))
+ (fun (_, named) ->
+ named
+ |> List.tryPick (function
+ | "AllowMultiple", Some(:? bool as res: obj) -> Some res
+ | _ -> None)))
+
+ /// Try to find a specific attribute on a type definition, where the attribute accepts a string argument.
+ ///
+ /// This is used to detect the 'DefaultMemberAttribute' and 'ConditionalAttribute' attributes (on type definitions)
+ let TryFindTyconRefStringAttribute g m attribSpec tcref =
+ TryBindTyconRefAttribute
+ g
+ m
+ attribSpec
+ tcref
+ (function
+ | [ ILAttribElem.String(Some msg) ], _ -> Some msg
+ | _ -> None)
+ (function
+ | Attrib(_, _, [ AttribStringArg msg ], _, _, _, _) -> Some msg
+ | _ -> None)
+ (function
+ | [ Some(:? string as msg: obj) ], _ -> Some msg
+ | _ -> None)
+
+ /// Like TryBindTyconRefAttribute but with a fast-path flag check on the IL metadata path.
+ /// Skips the full attribute scan if the cached flag indicates the attribute is absent.
+ let TryBindTyconRefAttributeWithILFlag g (m: range) (ilFlag: WellKnownILAttributes) args (tcref: TyconRef) f1 f2 f3 : 'a option =
+ tryBindTyconRefAttributeCore g m (ValueSome ilFlag) args tcref f1 f2 f3
+
+ /// Like TryFindTyconRefStringAttribute but with a fast-path flag check on the IL path.
+ /// Use this when the attribute has a corresponding WellKnownILAttributes flag for O(1) early exit.
+ let TryFindTyconRefStringAttributeFast g m ilFlag attribSpec tcref =
+ TryBindTyconRefAttributeWithILFlag
+ g
+ m
+ ilFlag
+ attribSpec
+ tcref
+ (function
+ | [ ILAttribElem.String(Some msg) ], _ -> Some msg
+ | _ -> None)
+ (function
+ | Attrib(_, _, [ AttribStringArg msg ], _, _, _, _) -> Some msg
+ | _ -> None)
+ (function
+ | [ Some(:? string as msg: obj) ], _ -> Some msg
+ | _ -> None)
+
+ /// Check if a type definition has a specific attribute
+ let TyconRefHasAttribute g m attribSpec tcref =
+ TryBindTyconRefAttribute g m attribSpec tcref (fun _ -> Some()) (fun _ -> Some()) (fun _ -> Some())
+ |> Option.isSome
+
+ /// Check if a TyconRef has a well-known attribute, handling both IL and F# metadata.
+ /// Uses O(1) flag tests on both paths.
+ let TyconRefHasWellKnownAttribute (g: TcGlobals) (flag: WellKnownILAttributes) (tcref: TyconRef) : bool =
+ match metadataOfTycon tcref.Deref with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata _ ->
+ let struct (_, attribInfoOpt) = mapILFlag g flag
+
+ match attribInfoOpt with
+ | Some attribInfo -> TyconRefHasAttribute g tcref.Range attribInfo tcref
+ | None -> false
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, tdef)) -> tdef.HasWellKnownAttribute(g, flag)
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ let struct (entityFlag, _) = mapILFlag g flag
+
+ if entityFlag <> WellKnownEntityAttributes.None then
+ EntityHasWellKnownAttribute g entityFlag tcref.Deref
+ else
+ false
+
+ let HasDefaultAugmentationAttribute g (tcref: TyconRef) =
+ match
+ EntityTryGetBoolAttribute
+ g
+ WellKnownEntityAttributes.DefaultAugmentationAttribute_True
+ WellKnownEntityAttributes.DefaultAugmentationAttribute_False
+ tcref.Deref
+ with
+ | Some b -> b
+ | None -> true
+
+ /// Check if a TyconRef has AllowNullLiteralAttribute, returning Some true/Some false/None.
+ let TyconRefAllowsNull (g: TcGlobals) (tcref: TyconRef) : bool option =
+ match metadataOfTycon tcref.Deref with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata _ -> TryFindTyconRefBoolAttribute g tcref.Range g.attrib_AllowNullLiteralAttribute tcref
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, tdef)) ->
+ if tdef.HasWellKnownAttribute(g, WellKnownILAttributes.AllowNullLiteralAttribute) then
+ Some true
+ else
+ None
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ EntityTryGetBoolAttribute
+ g
+ WellKnownEntityAttributes.AllowNullLiteralAttribute_True
+ WellKnownEntityAttributes.AllowNullLiteralAttribute_False
+ tcref.Deref
+
+ /// Check if a type definition has an attribute with a specific full name
+ let TyconRefHasAttributeByName (m: range) attrFullName (tcref: TyconRef) =
+ ignore m
+
+ match metadataOfTycon tcref.Deref with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info ->
+ let provAttribs =
+ info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)), m)
+
+ provAttribs
+ .PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure id, attrFullName)), m)
+ .IsSome
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, tdef)) ->
+ tdef.CustomAttrs.AsArray()
+ |> Array.exists (fun attr -> isILAttribByName ([], attrFullName) attr)
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ tcref.Attribs
+ |> List.exists (fun attr ->
+ match attr.TyconRef.CompiledRepresentation with
+ | CompiledTypeRepr.ILAsmNamed(typeRef, _, _) -> typeRef.Enclosing.IsEmpty && typeRef.Name = attrFullName
+ | CompiledTypeRepr.ILAsmOpen _ -> false)
+
+ type ValRef with
+ member vref.IsDispatchSlot =
+ match vref.MemberInfo with
+ | Some membInfo -> membInfo.MemberFlags.IsDispatchSlot
+ | None -> false
+
+ []
+ let (|UnopExpr|_|) (_g: TcGlobals) expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, _, [ arg1 ], _) -> ValueSome(vref, arg1)
+ | _ -> ValueNone
+
+ []
+ let (|BinopExpr|_|) (_g: TcGlobals) expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, _, [ arg1; arg2 ], _) -> ValueSome(vref, arg1, arg2)
+ | _ -> ValueNone
+
+ []
+ let (|SpecificUnopExpr|_|) g vrefReqd expr =
+ match expr with
+ | UnopExpr g (vref, arg1) when valRefEq g vref vrefReqd -> ValueSome arg1
+ | _ -> ValueNone
+
+ []
+ let (|SignedConstExpr|_|) expr =
+ match expr with
+ | Expr.Const(Const.Int32 _, _, _)
+ | Expr.Const(Const.SByte _, _, _)
+ | Expr.Const(Const.Int16 _, _, _)
+ | Expr.Const(Const.Int64 _, _, _)
+ | Expr.Const(Const.Single _, _, _)
+ | Expr.Const(Const.Double _, _, _) -> ValueSome()
+ | _ -> ValueNone
+
+ []
+ let (|IntegerConstExpr|_|) expr =
+ match expr with
+ | Expr.Const(Const.Int32 _, _, _)
+ | Expr.Const(Const.SByte _, _, _)
+ | Expr.Const(Const.Int16 _, _, _)
+ | Expr.Const(Const.Int64 _, _, _)
+ | Expr.Const(Const.Byte _, _, _)
+ | Expr.Const(Const.UInt16 _, _, _)
+ | Expr.Const(Const.UInt32 _, _, _)
+ | Expr.Const(Const.UInt64 _, _, _) -> ValueSome()
+ | _ -> ValueNone
+
+ []
+ let (|FloatConstExpr|_|) expr =
+ match expr with
+ | Expr.Const(Const.Single _, _, _)
+ | Expr.Const(Const.Double _, _, _) -> ValueSome()
+ | _ -> ValueNone
+
+ []
+ let (|SpecificBinopExpr|_|) g vrefReqd expr =
+ match expr with
+ | BinopExpr g (vref, arg1, arg2) when valRefEq g vref vrefReqd -> ValueSome(arg1, arg2)
+ | _ -> ValueNone
+
+ []
+ let (|EnumExpr|_|) g expr =
+ match (|SpecificUnopExpr|_|) g g.enum_vref expr with
+ | ValueNone -> (|SpecificUnopExpr|_|) g g.enumOfValue_vref expr
+ | x -> x
+
+ []
+ let (|BitwiseOrExpr|_|) g expr =
+ (|SpecificBinopExpr|_|) g g.bitwise_or_vref expr
+
+ []
+ let (|AttribBitwiseOrExpr|_|) g expr =
+ match expr with
+ | BitwiseOrExpr g (arg1, arg2) -> ValueSome(arg1, arg2)
+ // Special workaround, only used when compiling FSharp.Core.dll. Uses of 'a ||| b' occur before the '|||' bitwise or operator
+ // is defined. These get through type checking because enums implicitly support the '|||' operator through
+ // the automatic resolution of undefined operators (see tc.fs, Item.ImplicitOp). This then compiles as an
+ // application of a lambda to two arguments. We recognize this pattern here
+ | Expr.App(Expr.Lambda _, _, _, [ arg1; arg2 ], _) when g.compilingFSharpCore -> ValueSome(arg1, arg2)
+ | _ -> ValueNone
+
+ let isUncheckedDefaultOfValRef g vref =
+ valRefEq g vref g.unchecked_defaultof_vref
+ // There is an internal version of typeof defined in prim-types.fs that needs to be detected
+ || (g.compilingFSharpCore && vref.LogicalName = "defaultof")
+
+ let isTypeOfValRef g vref =
+ valRefEq g vref g.typeof_vref
+ // There is an internal version of typeof defined in prim-types.fs that needs to be detected
+ || (g.compilingFSharpCore && vref.LogicalName = "typeof")
+
+ let isSizeOfValRef g vref =
+ valRefEq g vref g.sizeof_vref
+ // There is an internal version of typeof defined in prim-types.fs that needs to be detected
+ || (g.compilingFSharpCore && vref.LogicalName = "sizeof")
+
+ let isNameOfValRef g vref =
+ valRefEq g vref g.nameof_vref
+ // There is an internal version of nameof defined in prim-types.fs that needs to be detected
+ || (g.compilingFSharpCore && vref.LogicalName = "nameof")
+
+ let isTypeDefOfValRef g vref =
+ valRefEq g vref g.typedefof_vref
+ // There is an internal version of typedefof defined in prim-types.fs that needs to be detected
+ || (g.compilingFSharpCore && vref.LogicalName = "typedefof")
+
+ []
+ let (|UncheckedDefaultOfExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ ty ], [], _) when isUncheckedDefaultOfValRef g vref -> ValueSome ty
+ | _ -> ValueNone
+
+ []
+ let (|TypeOfExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ ty ], [], _) when isTypeOfValRef g vref -> ValueSome ty
+ | _ -> ValueNone
+
+ []
+ let (|SizeOfExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ ty ], [], _) when isSizeOfValRef g vref -> ValueSome ty
+ | _ -> ValueNone
+
+ []
+ let (|TypeDefOfExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ ty ], [], _) when isTypeDefOfValRef g vref -> ValueSome ty
+ | _ -> ValueNone
+
+ []
+ let (|NameOfExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ ty ], [], _) when isNameOfValRef g vref -> ValueSome ty
+ | _ -> ValueNone
+
+ []
+ let (|SeqExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, _, _, _) when valRefEq g vref g.seq_vref -> ValueSome()
+ | _ -> ValueNone
+
+ //----------------------------------------------------------------------------
+ // CompilationMappingAttribute, SourceConstructFlags
+ //----------------------------------------------------------------------------
+
+ let tnameCompilationSourceNameAttr = Core + ".CompilationSourceNameAttribute"
+
+ let tnameCompilationArgumentCountsAttr =
+ Core + ".CompilationArgumentCountsAttribute"
+
+ let tnameCompilationMappingAttr = Core + ".CompilationMappingAttribute"
+ let tnameSourceConstructFlags = Core + ".SourceConstructFlags"
+
+ let tref_CompilationArgumentCountsAttr (g: TcGlobals) =
+ mkILTyRef (g.fslibCcu.ILScopeRef, tnameCompilationArgumentCountsAttr)
+
+ let tref_CompilationMappingAttr (g: TcGlobals) =
+ mkILTyRef (g.fslibCcu.ILScopeRef, tnameCompilationMappingAttr)
+
+ let tref_CompilationSourceNameAttr (g: TcGlobals) =
+ mkILTyRef (g.fslibCcu.ILScopeRef, tnameCompilationSourceNameAttr)
+
+ let tref_SourceConstructFlags (g: TcGlobals) =
+ mkILTyRef (g.fslibCcu.ILScopeRef, tnameSourceConstructFlags)
+
+ let mkCompilationMappingAttrPrim (g: TcGlobals) k nums =
+ mkILCustomAttribute (
+ tref_CompilationMappingAttr g,
+ ((mkILNonGenericValueTy (tref_SourceConstructFlags g))
+ :: (nums |> List.map (fun _ -> g.ilg.typ_Int32))),
+ ((k :: nums) |> List.map ILAttribElem.Int32),
+ []
+ )
+
+ let mkCompilationMappingAttr g kind = mkCompilationMappingAttrPrim g kind []
+
+ let mkCompilationMappingAttrWithSeqNum g kind seqNum =
+ mkCompilationMappingAttrPrim g kind [ seqNum ]
+
+ let mkCompilationMappingAttrWithVariantNumAndSeqNum g kind varNum seqNum =
+ mkCompilationMappingAttrPrim g kind [ varNum; seqNum ]
+
+ let mkCompilationArgumentCountsAttr (g: TcGlobals) nums =
+ mkILCustomAttribute (
+ tref_CompilationArgumentCountsAttr g,
+ [ mkILArr1DTy g.ilg.typ_Int32 ],
+ [ ILAttribElem.Array(g.ilg.typ_Int32, List.map ILAttribElem.Int32 nums) ],
+ []
+ )
+
+ let mkCompilationSourceNameAttr (g: TcGlobals) n =
+ mkILCustomAttribute (tref_CompilationSourceNameAttr g, [ g.ilg.typ_String ], [ ILAttribElem.String(Some n) ], [])
+
+ let mkCompilationMappingAttrForQuotationResource (g: TcGlobals) (nm, tys: ILTypeRef list) =
+ mkILCustomAttribute (
+ tref_CompilationMappingAttr g,
+ [ g.ilg.typ_String; mkILArr1DTy g.ilg.typ_Type ],
+ [
+ ILAttribElem.String(Some nm)
+ ILAttribElem.Array(g.ilg.typ_Type, [ for ty in tys -> ILAttribElem.TypeRef(Some ty) ])
+ ],
+ []
+ )
+
+ //----------------------------------------------------------------------------
+ // Decode extensible typing attributes
+ //----------------------------------------------------------------------------
+
+#if !NO_TYPEPROVIDERS
+
+ let isTypeProviderAssemblyAttr (cattr: ILAttribute) =
+ cattr.Method.DeclaringType.BasicQualifiedName = !!typeof
+ .FullName
+
+ let TryDecodeTypeProviderAssemblyAttr (cattr: ILAttribute) : (string | null) option =
+ if isTypeProviderAssemblyAttr cattr then
+ let params_, _args = decodeILAttribData cattr
+
+ match params_ with // The first parameter to the attribute is the name of the assembly with the compiler extensions.
+ | ILAttribElem.String(Some assemblyName) :: _ -> Some assemblyName
+ | ILAttribElem.String None :: _ -> Some null
+ | [] -> Some null
+ | _ -> None
+ else
+ None
+
+#endif
+
+ //----------------------------------------------------------------------------
+ // FSharpInterfaceDataVersionAttribute
+ //----------------------------------------------------------------------------
+
+ let tname_SignatureDataVersionAttr = Core + ".FSharpInterfaceDataVersionAttribute"
+
+ let tref_SignatureDataVersionAttr fsharpCoreAssemblyScopeRef =
+ mkILTyRef (fsharpCoreAssemblyScopeRef, tname_SignatureDataVersionAttr)
+
+ let mkSignatureDataVersionAttr (g: TcGlobals) (version: ILVersionInfo) =
+ mkILCustomAttribute (
+ tref_SignatureDataVersionAttr g.ilg.fsharpCoreAssemblyScopeRef,
+ [ g.ilg.typ_Int32; g.ilg.typ_Int32; g.ilg.typ_Int32 ],
+ [
+ ILAttribElem.Int32(int32 version.Major)
+ ILAttribElem.Int32(int32 version.Minor)
+ ILAttribElem.Int32(int32 version.Build)
+ ],
+ []
+ )
+
+ let IsSignatureDataVersionAttr cattr =
+ isILAttribByName ([], tname_SignatureDataVersionAttr) cattr
+
+ let TryFindAutoOpenAttr (cattr: ILAttribute) =
+ if
+ classifyILAttrib cattr &&& WellKnownILAttributes.AutoOpenAttribute
+ <> WellKnownILAttributes.None
+ then
+ match decodeILAttribData cattr with
+ | [ ILAttribElem.String s ], _ -> s
+ | [], _ -> None
+ | _ ->
+ warning (Failure(FSComp.SR.tastUnexpectedDecodeOfAutoOpenAttribute ()))
+ None
+ else
+ None
+
+ let TryFindInternalsVisibleToAttr (cattr: ILAttribute) =
+ if
+ classifyILAttrib cattr &&& WellKnownILAttributes.InternalsVisibleToAttribute
+ <> WellKnownILAttributes.None
+ then
+ match decodeILAttribData cattr with
+ | [ ILAttribElem.String s ], _ -> s
+ | [], _ -> None
+ | _ ->
+ warning (Failure(FSComp.SR.tastUnexpectedDecodeOfInternalsVisibleToAttribute ()))
+ None
+ else
+ None
+
+ let IsMatchingSignatureDataVersionAttr (version: ILVersionInfo) cattr =
+ IsSignatureDataVersionAttr cattr
+ && match decodeILAttribData cattr with
+ | [ ILAttribElem.Int32 u1; ILAttribElem.Int32 u2; ILAttribElem.Int32 u3 ], _ ->
+ (version.Major = uint16 u1)
+ && (version.Minor = uint16 u2)
+ && (version.Build = uint16 u3)
+ | _ ->
+ warning (Failure(FSComp.SR.tastUnexpectedDecodeOfInterfaceDataVersionAttribute ()))
+ false
+
+ let isSealedTy g ty =
+ let ty = stripTyEqnsAndMeasureEqns g ty
+
+ not (isRefTy g ty)
+ || isUnitTy g ty
+ || isArrayTy g ty
+ ||
+
+ match metadataOfTy g ty with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata st -> st.IsSealed
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsSealed
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ if (isFSharpInterfaceTy g ty || isFSharpClassTy g ty) then
+ let tcref = tcrefOfAppTy g ty
+ EntityHasWellKnownAttribute g WellKnownEntityAttributes.SealedAttribute_True tcref.Deref
+ else
+ // All other F# types, array, byref, tuple types are sealed
+ true
+
+ //--------------------------------------------------------------------------
+ // Some unions have null as representations
+ //--------------------------------------------------------------------------
+
+ let TyconHasUseNullAsTrueValueAttribute g (tycon: Tycon) =
+ EntityHasWellKnownAttribute g WellKnownEntityAttributes.CompilationRepresentation_PermitNull tycon
+
+ // WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs
+ let CanHaveUseNullAsTrueValueAttribute (_g: TcGlobals) (tycon: Tycon) =
+ (tycon.IsUnionTycon
+ && let ucs = tycon.UnionCasesArray in
+
+ (ucs.Length = 0
+ || (ucs |> Array.existsOne (fun uc -> uc.IsNullary)
+ && ucs |> Array.exists (fun uc -> not uc.IsNullary))))
+
+ // WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs
+ let IsUnionTypeWithNullAsTrueValue (g: TcGlobals) (tycon: Tycon) =
+ (tycon.IsUnionTycon
+ && let ucs = tycon.UnionCasesArray in
+
+ (ucs.Length = 0
+ || (TyconHasUseNullAsTrueValueAttribute g tycon
+ && ucs |> Array.existsOne (fun uc -> uc.IsNullary)
+ && ucs |> Array.exists (fun uc -> not uc.IsNullary))))
+
+ let TyconCompilesInstanceMembersAsStatic g tycon = IsUnionTypeWithNullAsTrueValue g tycon
+
+ let TcrefCompilesInstanceMembersAsStatic g (tcref: TyconRef) =
+ TyconCompilesInstanceMembersAsStatic g tcref.Deref
+
+ let ModuleNameIsMangled g attrs =
+ attribsHaveEntityFlag g WellKnownEntityAttributes.CompilationRepresentation_ModuleSuffix attrs
+
+ let CompileAsEvent g attrs =
+ attribsHaveValFlag g WellKnownValAttributes.CLIEventAttribute attrs
+
+ let ValCompileAsEvent g (v: Val) =
+ ValHasWellKnownAttribute g WellKnownValAttributes.CLIEventAttribute v
+
+ let MemberIsCompiledAsInstance g parent isExtensionMember (membInfo: ValMemberInfo) attrs =
+ // All extension members are compiled as static members
+ if isExtensionMember then
+ false
+ // Abstract slots, overrides and interface impls are all true to IsInstance
+ elif
+ membInfo.MemberFlags.IsDispatchSlot
+ || membInfo.MemberFlags.IsOverrideOrExplicitImpl
+ || not (isNil membInfo.ImplementedSlotSigs)
+ then
+ membInfo.MemberFlags.IsInstance
+ else
+ // Otherwise check attributes to see if there is an explicit instance or explicit static flag
+ let entityFlags = computeEntityWellKnownFlags g attrs
+
+ let explicitInstance =
+ hasFlag entityFlags WellKnownEntityAttributes.CompilationRepresentation_Instance
+
+ let explicitStatic =
+ hasFlag entityFlags WellKnownEntityAttributes.CompilationRepresentation_Static
+
+ explicitInstance
+ || (membInfo.MemberFlags.IsInstance
+ && not explicitStatic
+ && not (TcrefCompilesInstanceMembersAsStatic g parent))
+
+ let ValSpecIsCompiledAsInstance g (v: Val) =
+ match v.MemberInfo with
+ | Some membInfo ->
+ // Note it doesn't matter if we pass 'v.DeclaringEntity' or 'v.MemberApparentEntity' here.
+ // These only differ if the value is an extension member, and in that case MemberIsCompiledAsInstance always returns
+ // false anyway
+ MemberIsCompiledAsInstance g v.MemberApparentEntity v.IsExtensionMember membInfo v.Attribs
+ | _ -> false
+
+ let ValRefIsCompiledAsInstanceMember g (vref: ValRef) =
+ ValSpecIsCompiledAsInstance g vref.Deref
+
+ let tryFindExtensionAttribute (g: TcGlobals) (attribs: Attrib list) : Attrib option =
+ tryFindEntityAttribByFlag g WellKnownEntityAttributes.ExtensionAttribute attribs
+
+ let tryAddExtensionAttributeIfNotAlreadyPresentForModule
+ (g: TcGlobals)
+ (tryFindExtensionAttributeIn: (Attrib list -> Attrib option) -> Attrib option)
+ (moduleEntity: Entity)
+ : Entity =
+ if Option.isSome (tryFindExtensionAttribute g moduleEntity.Attribs) then
+ moduleEntity
+ else
+ match tryFindExtensionAttributeIn (tryFindExtensionAttribute g) with
+ | None -> moduleEntity
+ | Some extensionAttrib ->
+ { moduleEntity with
+ entity_attribs = moduleEntity.EntityAttribs.Add(extensionAttrib, WellKnownEntityAttributes.ExtensionAttribute)
+ }
+
+ let tryAddExtensionAttributeIfNotAlreadyPresentForType
+ (g: TcGlobals)
+ (tryFindExtensionAttributeIn: (Attrib list -> Attrib option) -> Attrib option)
+ (moduleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref)
+ (typeEntity: Entity)
+ : Entity =
+ if Option.isSome (tryFindExtensionAttribute g typeEntity.Attribs) then
+ typeEntity
+ else
+ match tryFindExtensionAttributeIn (tryFindExtensionAttribute g) with
+ | None -> typeEntity
+ | Some extensionAttrib ->
+ moduleOrNamespaceTypeAccumulator.Value.AllEntitiesByLogicalMangledName.TryFind(typeEntity.LogicalName)
+ |> Option.iter (fun e ->
+ e.entity_attribs <- e.EntityAttribs.Add(extensionAttrib, WellKnownEntityAttributes.ExtensionAttribute))
+
+ typeEntity
+
+[]
+module internal ByrefAndSpanHelpers =
+
+ // See RFC FS-1053.md
+ // Must use name-based matching (not type-identity) because user code can define
+ // its own IsByRefLikeAttribute per RFC FS-1053.
+ let isByrefLikeTyconRef (g: TcGlobals) m (tcref: TyconRef) =
+ tcref.CanDeref
+ && match tcref.TryIsByRefLike with
+ | ValueSome res -> res
+ | _ ->
+ let res =
+ isByrefTyconRef g tcref
+ || (isStructTyconRef tcref
+ && TyconRefHasAttributeByName m tname_IsByRefLikeAttribute tcref)
+
+ tcref.SetIsByRefLike res
+ res
+
+ let isSpanLikeTyconRef g m tcref =
+ isByrefLikeTyconRef g m tcref && not (isByrefTyconRef g tcref)
+
+ let isByrefLikeTy g m ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> isByrefLikeTyconRef g m tcref
+ | _ -> false)
+
+ let isSpanLikeTy g m ty =
+ isByrefLikeTy g m ty && not (isByrefTy g ty)
+
+ let isSpanTyconRef g m tcref =
+ isByrefLikeTyconRef g m tcref
+ && tcref.CompiledRepresentationForNamedType.BasicQualifiedName = "System.Span`1"
+
+ let isSpanTy g m ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> isSpanTyconRef g m tcref
+ | _ -> false)
+
+ let tryDestSpanTy g m ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, [ ty ]) when isSpanTyconRef g m tcref -> Some(tcref, ty)
+ | _ -> None
+
+ let destSpanTy g m ty =
+ match tryDestSpanTy g m ty with
+ | Some(tcref, ty) -> (tcref, ty)
+ | _ -> failwith "destSpanTy"
+
+ let isReadOnlySpanTyconRef g m tcref =
+ isByrefLikeTyconRef g m tcref
+ && tcref.CompiledRepresentationForNamedType.BasicQualifiedName = "System.ReadOnlySpan`1"
+
+ let isReadOnlySpanTy g m ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> isReadOnlySpanTyconRef g m tcref
+ | _ -> false)
+
+ let tryDestReadOnlySpanTy g m ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, [ ty ]) when isReadOnlySpanTyconRef g m tcref -> Some(tcref, ty)
+ | _ -> None
+
+ let destReadOnlySpanTy g m ty =
+ match tryDestReadOnlySpanTy g m ty with
+ | Some(tcref, ty) -> (tcref, ty)
+ | _ -> failwith "destReadOnlySpanTy"
+
+module internal DebugPrint =
+
+ //--------------------------------------------------------------------------
+ // DEBUG layout
+ //---------------------------------------------------------------------------
+ let mutable layoutRanges = false
+ let mutable layoutTypes = false
+ let mutable layoutStamps = false
+ let mutable layoutValReprInfo = false
+
+ let braceBarL l =
+ leftL leftBraceBar ^^ l ^^ rightL rightBraceBar
+
+ let intL (n: int) = wordL (tagNumericLiteral (string n))
+
+ let qlistL f xmap =
+ QueueList.foldBack (fun x z -> z @@ f x) xmap emptyL
+
+ let bracketIfL b lyt = if b then bracketL lyt else lyt
+
+ let lvalopL x =
+ match x with
+ | LAddrOf false -> wordL (tagText "&")
+ | LAddrOf true -> wordL (tagText "&!")
+ | LByrefGet -> wordL (tagText "*")
+ | LSet -> wordL (tagText "LSet")
+ | LByrefSet -> wordL (tagText "LByrefSet")
+
+ let angleBracketL l =
+ leftL (tagText "<") ^^ l ^^ rightL (tagText ">")
+
+ let angleBracketListL l =
+ angleBracketL (sepListL (sepL (tagText ",")) l)
+
+#if DEBUG
+ let layoutMemberFlags (memFlags: SynMemberFlags) =
+ let stat =
+ if memFlags.IsInstance || (memFlags.MemberKind = SynMemberKind.Constructor) then
+ emptyL
+ else
+ wordL (tagText "static")
+
+ let stat =
+ if memFlags.IsDispatchSlot then
+ stat ++ wordL (tagText "abstract")
+ elif memFlags.IsOverrideOrExplicitImpl then
+ stat ++ wordL (tagText "override")
+ else
+ stat
+
+ stat
+#endif
+
+ let stampL (n: Stamp) w =
+ if layoutStamps then
+ w ^^ wordL (tagText ("#" + string n))
+ else
+ w
+
+ let layoutTyconRef (tcref: TyconRef) =
+ wordL (tagText tcref.DisplayNameWithStaticParameters) |> stampL tcref.Stamp
+
+ let rec auxTypeL env ty = auxTypeWrapL env false ty
+
+ and auxTypeAtomL env ty = auxTypeWrapL env true ty
+
+ and auxTyparsL env tcL prefix tinst =
+ match tinst with
+ | [] -> tcL
+ | [ t ] ->
+ let tL = auxTypeAtomL env t
+ if prefix then tcL ^^ angleBracketL tL else tL ^^ tcL
+ | _ ->
+ let tinstL = List.map (auxTypeL env) tinst
+
+ if prefix then
+ tcL ^^ angleBracketListL tinstL
+ else
+ tupleL tinstL ^^ tcL
+
+ and auxAddNullness coreL (nullness: Nullness) =
+ match nullness.Evaluate() with
+ | NullnessInfo.WithNull -> coreL ^^ wordL (tagText "?")
+ | NullnessInfo.WithoutNull -> coreL
+ | NullnessInfo.AmbivalentToNull -> coreL //^^ wordL (tagText "%")
+
+ and auxTypeWrapL env isAtomic ty =
+ let wrap x = bracketIfL isAtomic x in // wrap iff require atomic expr
+
+ match stripTyparEqns ty with
+ | TType_forall(typars, bodyTy) -> (leftL (tagText "!") ^^ layoutTyparDecls typars --- auxTypeL env bodyTy) |> wrap
+
+ | TType_ucase(UnionCaseRef(tcref, _), tinst) ->
+ let prefix = tcref.IsPrefixDisplay
+ let tcL = layoutTyconRef tcref
+ auxTyparsL env tcL prefix tinst
+
+ | TType_app(tcref, tinst, nullness) ->
+ let prefix = tcref.IsPrefixDisplay
+ let tcL = layoutTyconRef tcref
+ let coreL = auxTyparsL env tcL prefix tinst
+ auxAddNullness coreL nullness
+
+ | TType_tuple(_tupInfo, tys) -> sepListL (wordL (tagText "*")) (List.map (auxTypeAtomL env) tys) |> wrap
+
+ | TType_fun(domainTy, rangeTy, nullness) ->
+ let coreL =
+ ((auxTypeAtomL env domainTy ^^ wordL (tagText "->")) --- auxTypeL env rangeTy)
+ |> wrap
+
+ auxAddNullness coreL nullness
+
+ | TType_var(typar, nullness) ->
+ let coreL = auxTyparWrapL env isAtomic typar
+ auxAddNullness coreL nullness
+
+ | TType_anon(anonInfo, tys) ->
+ braceBarL (
+ sepListL
+ (wordL (tagText ";"))
+ (List.map2 (fun nm ty -> wordL (tagField nm) --- auxTypeAtomL env ty) (Array.toList anonInfo.SortedNames) tys)
+ )
+
+ | TType_measure unt ->
+#if DEBUG
+ leftL (tagText "{")
+ ^^ (match global_g with
+ | None -> wordL (tagText "")
+ | Some g ->
+ let sortVars (vs: (Typar * Rational) list) =
+ vs |> List.sortBy (fun (v, _) -> v.DisplayName)
+
+ let sortCons (cs: (TyconRef * Rational) list) =
+ cs |> List.sortBy (fun (c, _) -> c.DisplayName)
+
+ let negvs, posvs =
+ ListMeasureVarOccsWithNonZeroExponents unt
+ |> sortVars
+ |> List.partition (fun (_, e) -> SignRational e < 0)
+
+ let negcs, poscs =
+ ListMeasureConOccsWithNonZeroExponents g false unt
+ |> sortCons
+ |> List.partition (fun (_, e) -> SignRational e < 0)
+
+ let unparL (uv: Typar) = wordL (tagText ("'" + uv.DisplayName))
+ let unconL tcref = layoutTyconRef tcref
+ let rationalL e = wordL (tagText (RationalToString e))
+
+ let measureToPowerL x e =
+ if e = OneRational then
+ x
+ else
+ x -- wordL (tagText "^") -- rationalL e
+
+ let prefix =
+ spaceListL (
+ List.map (fun (v, e) -> measureToPowerL (unparL v) e) posvs
+ @ List.map (fun (c, e) -> measureToPowerL (unconL c) e) poscs
+ )
+
+ let postfix =
+ spaceListL (
+ List.map (fun (v, e) -> measureToPowerL (unparL v) (NegRational e)) negvs
+ @ List.map (fun (c, e) -> measureToPowerL (unconL c) (NegRational e)) negcs
+ )
+
+ match (negvs, negcs) with
+ | [], [] -> prefix
+ | _ -> prefix ^^ sepL (tagText "/") ^^ postfix)
+ ^^ rightL (tagText "}")
+#else
+ unt |> ignore
+ wordL (tagText "")
+#endif
+
+ and auxTyparWrapL (env: SimplifyTypes.TypeSimplificationInfo) isAtomic (typar: Typar) =
+
+ let tpText =
+ prefixOfStaticReq typar.StaticReq
+ + prefixOfInferenceTypar typar
+ + typar.DisplayName
+
+ let tpL = wordL (tagText tpText)
+
+ let varL = tpL |> stampL typar.Stamp
+
+ // There are several cases for pprinting of typar.
+ //
+ // 'a - is multiple occurrence.
+ // #Type - inplace coercion constraint and singleton
+ // ('a :> Type) - inplace coercion constraint not singleton
+ // ('a.opM: S->T) - inplace operator constraint
+ match Zmap.tryFind typar env.inplaceConstraints with
+ | Some typarConstraintTy ->
+ if Zset.contains typar env.singletons then
+ leftL (tagText "#") ^^ auxTyparConstraintTypL env typarConstraintTy
+ else
+ (varL ^^ sepL (tagText ":>") ^^ auxTyparConstraintTypL env typarConstraintTy)
+ |> bracketIfL isAtomic
+ | _ -> varL
+
+ and auxTypar2L env typar = auxTyparWrapL env false typar
+
+ and auxTyparConstraintTypL env ty = auxTypeL env ty
+
+ and auxTraitL env (ttrait: TraitConstraintInfo) =
+#if DEBUG
+ let (TTrait(tys, nm, memFlags, argTys, retTy, _, _)) = ttrait
+
+ match global_g with
+ | None -> wordL (tagText "")
+ | Some g ->
+ let retTy = GetFSharpViewOfReturnType g retTy
+ let stat = layoutMemberFlags memFlags
+ let argsL = sepListL (wordL (tagText "*")) (List.map (auxTypeAtomL env) argTys)
+ let resL = auxTypeL env retTy
+ let methodTypeL = (argsL ^^ wordL (tagText "->")) ++ resL
+
+ bracketL (
+ stat
+ ++ bracketL (sepListL (wordL (tagText "or")) (List.map (auxTypeAtomL env) tys))
+ ++ wordL (tagText "member")
+ --- (wordL (tagText nm) ^^ wordL (tagText ":") -- methodTypeL)
+ )
+#else
+ ignore (env, ttrait)
+ wordL (tagText "trait")
+#endif
+
+ and auxTyparConstraintL env (tp, tpc) =
+ let constraintPrefix l =
+ auxTypar2L env tp ^^ wordL (tagText ":") ^^ l
+
+ match tpc with
+ | TyparConstraint.CoercesTo(typarConstraintTy, _) ->
+ auxTypar2L env tp
+ ^^ wordL (tagText ":>") --- auxTyparConstraintTypL env typarConstraintTy
+ | TyparConstraint.MayResolveMember(traitInfo, _) -> auxTypar2L env tp ^^ wordL (tagText ":") --- auxTraitL env traitInfo
+ | TyparConstraint.DefaultsTo(_, ty, _) ->
+ wordL (tagText "default")
+ ^^ auxTypar2L env tp
+ ^^ wordL (tagText ":")
+ ^^ auxTypeL env ty
+ | TyparConstraint.IsEnum(ty, _) -> auxTyparsL env (wordL (tagText "enum")) true [ ty ] |> constraintPrefix
+ | TyparConstraint.IsDelegate(aty, bty, _) ->
+ auxTyparsL env (wordL (tagText "delegate")) true [ aty; bty ]
+ |> constraintPrefix
+ | TyparConstraint.SupportsNull _ -> wordL (tagText "null") |> constraintPrefix
+ | TyparConstraint.SupportsComparison _ -> wordL (tagText "comparison") |> constraintPrefix
+ | TyparConstraint.SupportsEquality _ -> wordL (tagText "equality") |> constraintPrefix
+ | TyparConstraint.IsNonNullableStruct _ -> wordL (tagText "struct") |> constraintPrefix
+ | TyparConstraint.IsReferenceType _ -> wordL (tagText "not struct") |> constraintPrefix
+ | TyparConstraint.NotSupportsNull _ -> wordL (tagText "not null") |> constraintPrefix
+ | TyparConstraint.IsUnmanaged _ -> wordL (tagText "unmanaged") |> constraintPrefix
+ | TyparConstraint.AllowsRefStruct _ -> wordL (tagText "allows ref struct") |> constraintPrefix
+ | TyparConstraint.SimpleChoice(tys, _) ->
+ bracketL (sepListL (sepL (tagText "|")) (List.map (auxTypeL env) tys))
+ |> constraintPrefix
+ | TyparConstraint.RequiresDefaultConstructor _ ->
+ bracketL (wordL (tagText "new : unit -> ") ^^ (auxTypar2L env tp))
+ |> constraintPrefix
+
+ and auxTyparConstraintsL env x =
+ match x with
+ | [] -> emptyL
+ | cxs -> wordL (tagText "when") --- aboveListL (List.map (auxTyparConstraintL env) cxs)
+
+ and typarL tp =
+ auxTypar2L SimplifyTypes.typeSimplificationInfo0 tp
+
+ and typeAtomL tau =
+ let tau, cxs = tau, []
+ let env = SimplifyTypes.CollectInfo false [ tau ] cxs
+
+ match env.postfixConstraints with
+ | [] -> auxTypeAtomL env tau
+ | _ -> bracketL (auxTypeL env tau --- auxTyparConstraintsL env env.postfixConstraints)
+
+ and typeL tau =
+ let tau, cxs = tau, []
+ let env = SimplifyTypes.CollectInfo false [ tau ] cxs
+
+ match env.postfixConstraints with
+ | [] -> auxTypeL env tau
+ | _ -> (auxTypeL env tau --- auxTyparConstraintsL env env.postfixConstraints)
+
+ and typarDeclL tp =
+ let tau, cxs = mkTyparTy tp, (List.map (fun x -> (tp, x)) tp.Constraints)
+ let env = SimplifyTypes.CollectInfo false [ tau ] cxs
+
+ match env.postfixConstraints with
+ | [] -> auxTypeL env tau
+ | _ -> (auxTypeL env tau --- auxTyparConstraintsL env env.postfixConstraints)
+
+ and layoutTyparDecls tps =
+ match tps with
+ | [] -> emptyL
+ | _ -> angleBracketListL (List.map typarDeclL tps)
+
+ let rangeL m = wordL (tagText (stringOfRange m))
+
+ let instL tyL tys =
+ if layoutTypes then
+ match tys with
+ | [] -> emptyL
+ | tys -> sepL (tagText "@[") ^^ commaListL (List.map tyL tys) ^^ rightL (tagText "]")
+ else
+ emptyL
+
+ let valRefL (vr: ValRef) =
+ wordL (tagText vr.LogicalName) |> stampL vr.Stamp
+
+ let layoutAttrib (Attrib(_, k, _, _, _, _, _)) =
+ leftL (tagText "[<")
+ ^^ (match k with
+ | ILAttrib ilmeth -> wordL (tagText ilmeth.Name)
+ | FSAttrib vref -> valRefL vref)
+ ^^ rightL (tagText ">]")
+
+ let layoutAttribs attribs =
+ aboveListL (List.map layoutAttrib attribs)
+
+ let valReprInfoL (ValReprInfo(tpNames, _, _) as tvd) =
+ let ns = tvd.AritiesOfArgs
+
+ leftL (tagText "<")
+ ^^ intL tpNames.Length
+ ^^ sepL (tagText ">[")
+ ^^ commaListL (List.map intL ns)
+ ^^ rightL (tagText "]")
+
+ let valL (v: Val) =
+ let vsL =
+ wordL (tagText (ConvertValLogicalNameToDisplayNameCore v.LogicalName))
+ |> stampL v.Stamp
+
+ let vsL = vsL -- layoutAttribs v.Attribs
+ vsL
+
+ let typeOfValL (v: Val) =
+ valL v
+ ^^ (if v.ShouldInline then wordL (tagText "inline ") else emptyL)
+ ^^ (if v.IsMutable then wordL (tagText "mutable ") else emptyL)
+ ^^ (if layoutTypes then
+ wordL (tagText ":") ^^ typeL v.Type
+ else
+ emptyL)
+
+#if DEBUG
+ let tslotparamL (TSlotParam(nmOpt, ty, inFlag, outFlag, _, _)) =
+ (optionL (tagText >> wordL) nmOpt)
+ ^^ wordL (tagText ":")
+ ^^ typeL ty
+ ^^ (if inFlag then wordL (tagText "[in]") else emptyL)
+ ^^ (if outFlag then wordL (tagText "[out]") else emptyL)
+ ^^ (if inFlag then wordL (tagText "[opt]") else emptyL)
+#endif
+
+ let slotSigL (slotsig: SlotSig) =
+#if DEBUG
+ let (TSlotSig(nm, ty, tps1, tps2, pms, retTy)) = slotsig
+
+ match global_g with
+ | None -> wordL (tagText "")
+ | Some g ->
+ let retTy = GetFSharpViewOfReturnType g retTy
+
+ (wordL (tagText "slot") --- (wordL (tagText nm))
+ ^^ wordL (tagText "@")
+ ^^ typeL ty)
+ -- (wordL (tagText "LAM") --- spaceListL (List.map typarL tps1)
+ ^^ rightL (tagText "."))
+ --- (wordL (tagText "LAM") --- spaceListL (List.map typarL tps2)
+ ^^ rightL (tagText "."))
+ --- (commaListL (List.map (List.map tslotparamL >> tupleL) pms))
+ ^^ wordL (tagText "-> ") --- (typeL retTy)
+#else
+ ignore slotsig
+ wordL (tagText "slotsig")
+#endif
+
+ let valAtBindL v =
+ let vL = valL v
+ let vL = (if v.IsMutable then wordL (tagText "mutable") ++ vL else vL)
+
+ let vL =
+ if layoutTypes then
+ vL ^^ wordL (tagText ":") ^^ typeL v.Type
+ else
+ vL
+
+ let vL =
+ match v.ValReprInfo with
+ | Some info when layoutValReprInfo -> vL ^^ wordL (tagText "!") ^^ valReprInfoL info
+ | _ -> vL
+
+ vL
+
+ let unionCaseRefL (ucr: UnionCaseRef) = wordL (tagText ucr.CaseName)
+
+ let recdFieldRefL (rfref: RecdFieldRef) = wordL (tagText rfref.FieldName)
+
+ // Note: We need nice printing of constants in order to print literals and attributes
+ let constL c =
+ let str =
+ match c with
+ | Const.Bool x -> if x then "true" else "false"
+ | Const.SByte x -> (x |> string) + "y"
+ | Const.Byte x -> (x |> string) + "uy"
+ | Const.Int16 x -> (x |> string) + "s"
+ | Const.UInt16 x -> (x |> string) + "us"
+ | Const.Int32 x -> (x |> string)
+ | Const.UInt32 x -> (x |> string) + "u"
+ | Const.Int64 x -> (x |> string) + "L"
+ | Const.UInt64 x -> (x |> string) + "UL"
+ | Const.IntPtr x -> (x |> string) + "n"
+ | Const.UIntPtr x -> (x |> string) + "un"
+ | Const.Single d ->
+ (let s = d.ToString("g12", System.Globalization.CultureInfo.InvariantCulture)
+
+ if String.forall (fun c -> Char.IsDigit c || c = '-') s then
+ s + ".0"
+ else
+ s)
+ + "f"
+ | Const.Double d ->
+ let s = d.ToString("g12", System.Globalization.CultureInfo.InvariantCulture)
+
+ if String.forall (fun c -> Char.IsDigit c || c = '-') s then
+ s + ".0"
+ else
+ s
+ | Const.Char c -> "'" + c.ToString() + "'"
+ | Const.String bs -> "\"" + bs + "\""
+ | Const.Unit -> "()"
+ | Const.Decimal bs -> string bs + "M"
+ | Const.Zero -> "default"
+
+ wordL (tagText str)
+
+ let layoutUnionCaseArgTypes argTys =
+ sepListL (wordL (tagText "*")) (List.map typeL argTys)
+
+ let ucaseL prefixL (ucase: UnionCase) =
+ let nmL = wordL (tagText ucase.DisplayName)
+
+ match ucase.RecdFields |> List.map (fun rfld -> rfld.FormalType) with
+ | [] -> (prefixL ^^ nmL)
+ | argTys -> (prefixL ^^ nmL ^^ wordL (tagText "of")) --- layoutUnionCaseArgTypes argTys
+
+ let layoutUnionCases ucases =
+ let prefixL =
+ if not (isNilOrSingleton ucases) then
+ wordL (tagText "|")
+ else
+ emptyL
+
+ List.map (ucaseL prefixL) ucases
+
+ let layoutRecdField (fld: RecdField) =
+ let lhs = wordL (tagText fld.LogicalName)
+
+ let lhs =
+ if fld.IsMutable then
+ wordL (tagText "mutable") --- lhs
+ else
+ lhs
+
+ let lhs =
+ if layoutTypes then
+ lhs ^^ rightL (tagText ":") ^^ typeL fld.FormalType
+ else
+ lhs
+
+ lhs
+
+ let tyconReprL (repr, tycon: Tycon) =
+ match repr with
+ | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } -> tycon.UnionCasesAsList |> layoutUnionCases |> aboveListL
+ | TFSharpTyconRepr r ->
+ match r.fsobjmodel_kind with
+ | TFSharpDelegate _ -> wordL (tagText "delegate ...")
+ | _ ->
+ let start =
+ match r.fsobjmodel_kind with
+ | TFSharpClass -> "class"
+ | TFSharpInterface -> "interface"
+ | TFSharpStruct -> "struct"
+ | TFSharpEnum -> "enum"
+ | _ -> failwith "???"
+
+ let inherits =
+ match r.fsobjmodel_kind, tycon.TypeContents.tcaug_super with
+ | TFSharpClass, Some super -> [ wordL (tagText "inherit") ^^ (typeL super) ]
+ | TFSharpInterface, _ ->
+ tycon.ImmediateInterfacesOfFSharpTycon
+ |> List.filter (fun (_, compgen, _) -> not compgen)
+ |> List.map (fun (ity, _, _) -> wordL (tagText "inherit") ^^ (typeL ity))
+ | _ -> []
+
+ let vsprs =
+ tycon.MembersOfFSharpTyconSorted
+ |> List.filter (fun v -> v.IsDispatchSlot)
+ |> List.map (fun vref -> valAtBindL vref.Deref)
+
+ let vals =
+ tycon.TrueFieldsAsList
+ |> List.map (fun f ->
+ (if f.IsStatic then wordL (tagText "static") else emptyL)
+ ^^ wordL (tagText "val")
+ ^^ layoutRecdField f)
+
+ let alldecls = inherits @ vsprs @ vals
+
+ let emptyMeasure =
+ match tycon.TypeOrMeasureKind with
+ | TyparKind.Measure -> isNil alldecls
+ | _ -> false
+
+ if emptyMeasure then
+ emptyL
+ else
+ (wordL (tagText start) @@-- aboveListL alldecls) @@ wordL (tagText "end")
+
+ | TAsmRepr _ -> wordL (tagText "(# ... #)")
+ | TMeasureableRepr ty -> typeL ty
+ | TILObjectRepr(TILObjectReprData(_, _, td)) -> wordL (tagText td.Name)
+ | _ -> failwith "unreachable"
+
+ let rec bindingL (TBind(v, repr, _)) =
+ (valAtBindL v ^^ wordL (tagText "=")) @@-- exprL repr
+
+ and exprL expr = exprWrapL false expr
+
+ and atomL expr =
+ // true means bracket if needed to be atomic expr
+ exprWrapL true expr
+
+ and letRecL binds bodyL =
+ let eqnsL =
+ binds
+ |> List.mapHeadTail (fun bind -> wordL (tagText "rec") ^^ bindingL bind ^^ wordL (tagText "in")) (fun bind ->
+ wordL (tagText "and") ^^ bindingL bind ^^ wordL (tagText "in"))
+
+ (aboveListL eqnsL @@ bodyL)
+
+ and letL bind bodyL =
+ let eqnL = wordL (tagText "let") ^^ bindingL bind
+ (eqnL @@ bodyL)
+
+ and exprWrapL isAtomic expr =
+ let wrap = bracketIfL isAtomic // wrap iff require atomic expr
+
+ let lay =
+ match expr with
+ | Expr.Const(c, _, _) -> constL c
+
+ | Expr.Val(v, flags, _) ->
+ let xL = valL v.Deref
+
+ let xL =
+ match flags with
+ | PossibleConstrainedCall _ -> xL ^^ rightL (tagText "")
+ | CtorValUsedAsSelfInit -> xL ^^ rightL (tagText "")
+ | CtorValUsedAsSuperInit -> xL ^^ rightL (tagText "")
+ | VSlotDirectCall -> xL ^^ rightL (tagText "")
+ | NormalValUse -> xL
+
+ xL
+
+ | Expr.Sequential(expr1, expr2, flag, _) ->
+ aboveListL
+ [
+ exprL expr1
+ match flag with
+ | NormalSeq -> ()
+ | ThenDoSeq -> wordL (tagText "ThenDo")
+ exprL expr2
+ ]
+ |> wrap
+
+ | Expr.Lambda(_, _, baseValOpt, argvs, body, _, _) ->
+ let formalsL = spaceListL (List.map valAtBindL argvs)
+
+ let bindingL =
+ match baseValOpt with
+ | None -> wordL (tagText "fun") ^^ formalsL ^^ wordL (tagText "->")
+ | Some basev ->
+ wordL (tagText "fun")
+ ^^ (leftL (tagText "base=") ^^ valAtBindL basev) --- formalsL
+ ^^ wordL (tagText "->")
+
+ (bindingL @@-- exprL body) |> wrap
+
+ | Expr.TyLambda(_, tps, body, _, _) ->
+ ((wordL (tagText "FUN") ^^ layoutTyparDecls tps ^^ wordL (tagText "->"))
+ ++ exprL body)
+ |> wrap
+
+ | Expr.TyChoose(tps, body, _) ->
+ ((wordL (tagText "CHOOSE") ^^ layoutTyparDecls tps ^^ wordL (tagText "->"))
+ ++ exprL body)
+ |> wrap
+
+ | Expr.App(f, _, tys, argTys, _) ->
+ let flayout = atomL f
+ appL flayout tys argTys |> wrap
+
+ | Expr.LetRec(binds, body, _, _) -> letRecL binds (exprL body) |> wrap
+
+ | Expr.Let(bind, body, _, _) -> letL bind (exprL body) |> wrap
+
+ | Expr.Link rX -> exprL rX.Value |> wrap
+
+ | Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, rX) ->
+ aboveListL [ wordL (tagText "__debugPoint(") ^^ rangeL m ^^ wordL (tagText ")"); exprL rX ]
+ |> wrap
+
+ | Expr.Match(_, _, dtree, targets, _, _) ->
+ leftL (tagText "[")
+ ^^ (decisionTreeL dtree
+ @@ aboveListL (List.mapi targetL (targets |> Array.toList)) ^^ rightL (tagText "]"))
+
+ | Expr.Op(TOp.UnionCase c, _, args, _) -> (unionCaseRefL c ++ spaceListL (List.map atomL args)) |> wrap
+
+ | Expr.Op(TOp.ExnConstr ecref, _, args, _) -> wordL (tagText ecref.LogicalName) ^^ bracketL (commaListL (List.map atomL args))
+
+ | Expr.Op(TOp.Tuple _, _, xs, _) -> tupleL (List.map exprL xs)
+
+ | Expr.Op(TOp.Recd(ctor, tcref), _, xs, _) ->
+ let fields = tcref.TrueInstanceFieldsAsList
+
+ let lay fs x =
+ (wordL (tagText fs.rfield_id.idText) ^^ sepL (tagText "=")) --- (exprL x)
+
+ let ctorL =
+ match ctor with
+ | RecdExpr -> emptyL
+ | RecdExprIsObjInit -> wordL (tagText "(new)")
+
+ leftL (tagText "{")
+ ^^ aboveListL (List.map2 lay fields xs)
+ ^^ rightL (tagText "}")
+ ^^ ctorL
+
+ | Expr.Op(TOp.ValFieldSet rf, _, [ rx; x ], _) ->
+ (atomL rx --- wordL (tagText "."))
+ ^^ (recdFieldRefL rf ^^ wordL (tagText "<-") --- exprL x)
+
+ | Expr.Op(TOp.ValFieldSet rf, _, [ x ], _) -> recdFieldRefL rf ^^ wordL (tagText "<-") --- exprL x
+
+ | Expr.Op(TOp.ValFieldGet rf, _, [ rx ], _) -> atomL rx ^^ rightL (tagText ".#") ^^ recdFieldRefL rf
+
+ | Expr.Op(TOp.ValFieldGet rf, _, [], _) -> recdFieldRefL rf
+
+ | Expr.Op(TOp.ValFieldGetAddr(rf, _), _, [ rx ], _) ->
+ leftL (tagText "&")
+ ^^ bracketL (atomL rx ^^ rightL (tagText ".!") ^^ recdFieldRefL rf)
+
+ | Expr.Op(TOp.ValFieldGetAddr(rf, _), _, [], _) -> leftL (tagText "&") ^^ (recdFieldRefL rf)
+
+ | Expr.Op(TOp.UnionCaseTagGet tycr, _, [ x ], _) -> wordL (tagText (tycr.LogicalName + ".tag")) ^^ atomL x
+
+ | Expr.Op(TOp.UnionCaseProof c, _, [ x ], _) -> wordL (tagText (c.CaseName + ".proof")) ^^ atomL x
+
+ | Expr.Op(TOp.UnionCaseFieldGet(c, i), _, [ x ], _) -> wordL (tagText (c.CaseName + "." + string i)) --- atomL x
+
+ | Expr.Op(TOp.UnionCaseFieldSet(c, i), _, [ x; y ], _) ->
+ ((atomL x --- (rightL (tagText ("#" + c.CaseName + "." + string i))))
+ ^^ wordL (tagText ":="))
+ --- exprL y
+
+ | Expr.Op(TOp.TupleFieldGet(_, i), _, [ x ], _) -> wordL (tagText ("#" + string i)) --- atomL x
+
+ | Expr.Op(TOp.Coerce, [ ty; _ ], [ x ], _) -> atomL x --- (wordL (tagText ":>") ^^ typeL ty)
+
+ | Expr.Op(TOp.Reraise, [ _ ], [], _) -> wordL (tagText "Reraise")
+
+ | Expr.Op(TOp.ILAsm(instrs, retTypes), tyargs, args, _) ->
+ let instrs = instrs |> List.map (sprintf "%+A" >> tagText >> wordL) |> spaceListL // %+A has + since instrs are from an "internal" type
+ let instrs = leftL (tagText "(#") ^^ instrs ^^ rightL (tagText "#)")
+ let instrL = appL instrs tyargs args
+
+ let instrL =
+ if layoutTypes then
+ instrL ^^ wordL (tagText ":") ^^ spaceListL (List.map typeAtomL retTypes)
+ else
+ instrL
+
+ instrL |> wrap
+
+ | Expr.Op(TOp.LValueOp(lvop, vr), _, args, _) ->
+ (lvalopL lvop ^^ valRefL vr --- bracketL (commaListL (List.map atomL args)))
+ |> wrap
+
+ | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _enclTypeInst, _methInst, _), _tyargs, args, _) ->
+ let meth = ilMethRef.Name
+
+ (wordL (tagText ilMethRef.DeclaringTypeRef.FullName)
+ ^^ sepL (tagText ".")
+ ^^ wordL (tagText meth))
+ ---- (if args.IsEmpty then
+ wordL (tagText "()")
+ else
+ listL exprL args)
+ //if not enclTypeInst.IsEmpty then yield wordL(tagText "tinst ") --- listL typeL enclTypeInst
+ //if not methInst.IsEmpty then yield wordL (tagText "minst ") --- listL typeL methInst
+ //if not tyargs.IsEmpty then yield wordL (tagText "tyargs") --- listL typeL tyargs
+
+ |> wrap
+
+ | Expr.Op(TOp.Array, [ _ ], xs, _) -> leftL (tagText "[|") ^^ commaListL (List.map exprL xs) ^^ rightL (tagText "|]")
+
+ | Expr.Op(TOp.While _, [], [ Expr.Lambda(_, _, _, [ _ ], x1, _, _); Expr.Lambda(_, _, _, [ _ ], x2, _, _) ], _) ->
+ let headerL = wordL (tagText "while") ^^ exprL x1 ^^ wordL (tagText "do")
+ headerL @@-- exprL x2
+
+ | Expr.Op(TOp.IntegerForLoop _,
+ [],
+ [ Expr.Lambda(_, _, _, [ _ ], x1, _, _); Expr.Lambda(_, _, _, [ _ ], x2, _, _); Expr.Lambda(_, _, _, [ _ ], x3, _, _) ],
+ _) ->
+ let headerL =
+ wordL (tagText "for")
+ ^^ exprL x1
+ ^^ wordL (tagText "to")
+ ^^ exprL x2
+ ^^ wordL (tagText "do")
+
+ headerL @@-- exprL x3
+
+ | Expr.Op(TOp.TryWith _,
+ [ _ ],
+ [ Expr.Lambda(_, _, _, [ _ ], x1, _, _); Expr.Lambda(_, _, _, [ _ ], xf, _, _); Expr.Lambda(_, _, _, [ _ ], xh, _, _) ],
+ _) ->
+ (wordL (tagText "try") @@-- exprL x1)
+ @@ (wordL (tagText "with-filter") @@-- exprL xf)
+ @@ (wordL (tagText "with") @@-- exprL xh)
+
+ | Expr.Op(TOp.TryFinally _, [ _ ], [ Expr.Lambda(_, _, _, [ _ ], x1, _, _); Expr.Lambda(_, _, _, [ _ ], x2, _, _) ], _) ->
+ (wordL (tagText "try") @@-- exprL x1)
+ @@ (wordL (tagText "finally") @@-- exprL x2)
+ | Expr.Op(TOp.Bytes _, _, _, _) -> wordL (tagText "bytes++")
+
+ | Expr.Op(TOp.UInt16s _, _, _, _) -> wordL (tagText "uint16++")
+ | Expr.Op(TOp.RefAddrGet _, _tyargs, _args, _) -> wordL (tagText "GetRefLVal...")
+ | Expr.Op(TOp.TraitCall _, _tyargs, _args, _) -> wordL (tagText "traitcall...")
+ | Expr.Op(TOp.ExnFieldGet _, _tyargs, _args, _) -> wordL (tagText "TOp.ExnFieldGet...")
+ | Expr.Op(TOp.ExnFieldSet _, _tyargs, _args, _) -> wordL (tagText "TOp.ExnFieldSet...")
+ | Expr.Op(TOp.TryFinally _, _tyargs, args, _) -> wordL (tagText "unexpected-try-finally") ---- aboveListL (List.map atomL args)
+ | Expr.Op(TOp.TryWith _, _tyargs, args, _) -> wordL (tagText "unexpected-try-with") ---- aboveListL (List.map atomL args)
+ | Expr.Op(TOp.Goto l, _tys, args, _) ->
+ wordL (tagText ("Expr.Goto " + string l))
+ ^^ bracketL (commaListL (List.map atomL args))
+ | Expr.Op(TOp.Label l, _tys, args, _) ->
+ wordL (tagText ("Expr.Label " + string l))
+ ^^ bracketL (commaListL (List.map atomL args))
+ | Expr.Op(_, _tys, args, _) -> wordL (tagText "Expr.Op ...") ^^ bracketL (commaListL (List.map atomL args))
+ | Expr.Quote(a, _, _, _, _) -> leftL (tagText "<@") ^^ atomL a ^^ rightL (tagText "@>")
+
+ | Expr.Obj(_lambdaId, ty, basev, ccall, overrides, iimpls, _) ->
+ (leftL (tagText "{")
+ @@-- ((wordL (tagText "new ") ++ typeL ty)
+ @@-- aboveListL
+ [
+ exprL ccall
+ match basev with
+ | None -> ()
+ | Some b -> valAtBindL b
+ yield! List.map tmethodL overrides
+ yield! List.map iimplL iimpls
+ ]))
+ @@ rightL (tagText "}")
+
+ | Expr.WitnessArg _ -> wordL (tagText "")
+
+ | Expr.StaticOptimization(_tcs, csx, x, _) ->
+ (wordL (tagText "opt") @@- (exprL x))
+ @@-- (wordL (tagText "|") ^^ exprL csx --- wordL (tagText "when..."))
+
+ // For tracking ranges through expr rewrites
+ if layoutRanges then
+ aboveListL [ leftL (tagText "//") ^^ rangeL expr.Range; lay ]
+ else
+ lay
+
+ and appL flayout tys args =
+ let z = flayout
+ let z = if isNil tys then z else z ^^ instL typeL tys
+
+ let z =
+ if isNil args then
+ z
+ else
+ z --- spaceListL (List.map atomL args)
+
+ z
+
+ and decisionTreeL x =
+ match x with
+ | TDBind(bind, body) ->
+ let bind = wordL (tagText "let") ^^ bindingL bind
+ (bind @@ decisionTreeL body)
+ | TDSuccess(args, n) ->
+ wordL (tagText "Success")
+ ^^ leftL (tagText "T")
+ ^^ intL n
+ ^^ tupleL (args |> List.map exprL)
+ | TDSwitch(test, dcases, dflt, _) ->
+ (wordL (tagText "Switch") --- exprL test)
+ @@-- (aboveListL (List.map dcaseL dcases)
+ @@ match dflt with
+ | None -> emptyL
+ | Some dtree -> wordL (tagText "dflt:") --- decisionTreeL dtree)
+
+ and dcaseL (TCase(test, dtree)) =
+ (dtestL test ^^ wordL (tagText "//")) --- decisionTreeL dtree
+
+ and dtestL x =
+ match x with
+ | DecisionTreeTest.UnionCase(c, tinst) -> wordL (tagText "is") ^^ unionCaseRefL c ^^ instL typeL tinst
+ | DecisionTreeTest.ArrayLength(n, ty) -> wordL (tagText "length") ^^ intL n ^^ typeL ty
+ | DecisionTreeTest.Const c -> wordL (tagText "is") ^^ constL c
+ | DecisionTreeTest.IsNull -> wordL (tagText "isnull")
+ | DecisionTreeTest.IsInst(_, ty) -> wordL (tagText "isinst") ^^ typeL ty
+ | DecisionTreeTest.ActivePatternCase(exp, _, _, _, _, _) -> wordL (tagText "query") ^^ exprL exp
+ | DecisionTreeTest.Error _ -> wordL (tagText "error recovery")
+
+ and targetL i (TTarget(argvs, body, _)) =
+ leftL (tagText "T")
+ ^^ intL i
+ ^^ tupleL (flatValsL argvs)
+ ^^ rightL (tagText ":") --- exprL body
+
+ and flatValsL vs = vs |> List.map valL
+
+ and tmethodL (TObjExprMethod(TSlotSig(nm, _, _, _, _, _), _, tps, vs, e, _)) =
+ (wordL (tagText "member")
+ ^^ (wordL (tagText nm))
+ ^^ layoutTyparDecls tps
+ ^^ tupleL (List.map (List.map valAtBindL >> tupleL) vs)
+ ^^ rightL (tagText "="))
+ @@-- exprL e
+
+ and iimplL (ty, tmeths) =
+ wordL (tagText "impl") ^^ aboveListL (typeL ty :: List.map tmethodL tmeths)
+
+ let rec tyconL (tycon: Tycon) =
+
+ let lhsL =
+ wordL (
+ tagText (
+ match tycon.TypeOrMeasureKind with
+ | TyparKind.Measure -> "[] type"
+ | TyparKind.Type -> "type"
+ )
+ )
+ ^^ wordL (tagText tycon.DisplayName)
+ ^^ layoutTyparDecls tycon.TyparsNoRange
+
+ let lhsL = lhsL --- layoutAttribs tycon.Attribs
+
+ let memberLs =
+ let adhoc =
+ tycon.MembersOfFSharpTyconSorted
+ |> List.filter (fun v -> not v.IsDispatchSlot)
+ |> List.filter (fun v -> not v.Deref.IsClassConstructor)
+ // Don't print individual methods forming interface implementations - these are currently never exported
+ |> List.filter (fun v -> isNil (Option.get v.MemberInfo).ImplementedSlotSigs)
+
+ let iimpls =
+ match tycon.TypeReprInfo with
+ | TFSharpTyconRepr r when
+ (match r.fsobjmodel_kind with
+ | TFSharpInterface -> true
+ | _ -> false)
+ ->
+ []
+ | _ -> tycon.ImmediateInterfacesOfFSharpTycon
+
+ let iimpls = iimpls |> List.filter (fun (_, compgen, _) -> not compgen)
+ // if TFSharpInterface, the iimpls should be printed as inherited interfaces
+ if isNil adhoc && isNil iimpls then
+ emptyL
+ else
+ let iimplsLs =
+ iimpls |> List.map (fun (ty, _, _) -> wordL (tagText "interface") --- typeL ty)
+
+ let adhocLs = adhoc |> List.map (fun vref -> valAtBindL vref.Deref)
+
+ (wordL (tagText "with") @@-- aboveListL (iimplsLs @ adhocLs))
+ @@ wordL (tagText "end")
+
+ let reprL =
+ match tycon.TypeReprInfo with
+#if !NO_TYPEPROVIDERS
+ | TProvidedTypeRepr _
+ | TProvidedNamespaceRepr _
+#endif
+ | TNoRepr ->
+ match tycon.TypeAbbrev with
+ | None -> lhsL @@-- memberLs
+ | Some a -> (lhsL ^^ wordL (tagText "=")) --- (typeL a @@ memberLs)
+ | a ->
+ let rhsL = tyconReprL (a, tycon) @@ memberLs
+ (lhsL ^^ wordL (tagText "=")) @@-- rhsL
+
+ reprL
+
+ and entityL (entity: Entity) =
+ if entity.IsModuleOrNamespace then
+ moduleOrNamespaceL entity
+ else
+ tyconL entity
+
+ and mexprL mtyp defs =
+ let resL = mdefL defs
+
+ let resL =
+ if layoutTypes then
+ resL @@- (wordL (tagText ":") @@- moduleOrNamespaceTypeL mtyp)
+ else
+ resL
+
+ resL
+
+ and mdefsL defs =
+ wordL (tagText "Module Defs") @@-- aboveListL (List.map mdefL defs)
+
+ and mdefL x =
+ match x with
+ | TMDefRec(_, _, tycons, mbinds, _) -> aboveListL ((tycons |> List.map tyconL) @ (mbinds |> List.map mbindL))
+ | TMDefLet(bind, _) -> letL bind emptyL
+ | TMDefDo(e, _) -> exprL e
+ | TMDefOpens _ -> wordL (tagText "open ... ")
+ | TMDefs defs -> mdefsL defs
+
+ and mbindL x =
+ match x with
+ | ModuleOrNamespaceBinding.Binding bind -> letL bind emptyL
+ | ModuleOrNamespaceBinding.Module(mspec, rhs) ->
+ let titleL =
+ wordL (tagText (if mspec.IsNamespace then "namespace" else "module"))
+ ^^ (wordL (tagText mspec.DemangledModuleOrNamespaceName) |> stampL mspec.Stamp)
+
+ titleL @@-- mdefL rhs
+
+ and moduleOrNamespaceTypeL (mtyp: ModuleOrNamespaceType) =
+ aboveListL [ qlistL typeOfValL mtyp.AllValsAndMembers; qlistL tyconL mtyp.AllEntities ]
+
+ and moduleOrNamespaceL (ms: ModuleOrNamespace) =
+ let header =
+ wordL (tagText "module")
+ ^^ (wordL (tagText ms.DemangledModuleOrNamespaceName) |> stampL ms.Stamp)
+ ^^ wordL (tagText ":")
+
+ let footer = wordL (tagText "end")
+ let body = moduleOrNamespaceTypeL ms.ModuleOrNamespaceType
+ (header @@-- body) @@ footer
+
+ let implFileL (CheckedImplFile(signature = implFileTy; contents = implFileContents)) =
+ aboveListL
+ [
+ wordL (tagText "top implementation ") @@-- mexprL implFileTy implFileContents
+ ]
+
+ let implFilesL implFiles =
+ aboveListL (List.map implFileL implFiles)
+
+ let showType x = showL (typeL x)
+
+ let showExpr x = showL (exprL x)
+
+ let traitL x =
+ auxTraitL SimplifyTypes.typeSimplificationInfo0 x
+
+ let typarsL x = layoutTyparDecls x
+
+ type TypedTreeNode =
+ {
+ Kind: string
+ Name: string
+ Children: TypedTreeNode list
+ }
+
+ let rec visitEntity (entity: Entity) : TypedTreeNode =
+ let kind =
+ if entity.IsModule then "module"
+ elif entity.IsNamespace then "namespace"
+ else "other"
+
+ let children =
+ if not entity.IsModuleOrNamespace then
+ Seq.empty
+ else
+ seq {
+ yield! Seq.map visitEntity entity.ModuleOrNamespaceType.AllEntities
+ yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers
+ }
+
+ {
+ Kind = kind
+ Name = entity.CompiledName
+ Children = Seq.toList children
+ }
+
+ and visitVal (v: Val) : TypedTreeNode =
+ let children =
+ seq {
+ match v.ValReprInfo with
+ | None -> ()
+ | Some reprInfo ->
+ yield!
+ reprInfo.ArgInfos
+ |> Seq.collect (fun argInfos ->
+ argInfos
+ |> Seq.map (fun argInfo ->
+ {
+ Name = argInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue ""
+ Kind = "ArgInfo"
+ Children = []
+ }))
+
+ yield!
+ v.Typars
+ |> Seq.map (fun typar ->
+ {
+ Name = typar.Name
+ Kind = "Typar"
+ Children = []
+ })
+ }
+
+ {
+ Name = v.CompiledName None
+ Kind = "val"
+ Children = Seq.toList children
+ }
+
+ let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma: bool) (node: TypedTreeNode) =
+ writer.WriteLine("{")
+ // Add indent after opening {
+ writer.Indent <- writer.Indent + 1
+
+ writer.WriteLine($"\"name\": \"{node.Name}\",")
+ writer.WriteLine($"\"kind\": \"{node.Kind}\",")
+
+ if node.Children.IsEmpty then
+ writer.WriteLine("\"children\": []")
+ else
+ writer.WriteLine("\"children\": [")
+
+ // Add indent after opening [
+ writer.Indent <- writer.Indent + 1
+
+ node.Children
+ |> List.iteri (fun idx -> serializeNode writer (idx + 1 < node.Children.Length))
+
+ // Remove indent before closing ]
+ writer.Indent <- writer.Indent - 1
+ writer.WriteLine("]")
+
+ // Remove indent before closing }
+ writer.Indent <- writer.Indent - 1
+
+ if addTrailingComma then
+ writer.WriteLine("},")
+ else
+ writer.WriteLine("}")
+
+ let serializeEntity path (entity: Entity) =
+ let root = visitEntity entity
+ use sw = new System.IO.StringWriter()
+ use writer = new IndentedTextWriter(sw)
+ serializeNode writer false root
+ writer.Flush()
+ let json = sw.ToString()
+
+ use out =
+ FileSystem.OpenFileForWriteShim(path, fileMode = System.IO.FileMode.Create)
+
+ out.WriteAllText(json)
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Attributes.fsi b/src/Compiler/TypedTree/TypedTreeOps.Attributes.fsi
new file mode 100644
index 0000000000..76096c3d65
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Attributes.fsi
@@ -0,0 +1,414 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// TypedTreeOps.Attributes: IL extensions, attribute helpers, and debug printing.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System.Collections.Generic
+open Internal.Utilities.Library
+open FSharp.Compiler
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+
+[]
+module internal ILExtensions =
+
+ val isILAttribByName: string list * string -> ILAttribute -> bool
+
+ val TryDecodeILAttribute: ILTypeRef -> ILAttributes -> (ILAttribElem list * ILAttributeNamedArg list) option
+
+ val IsILAttrib: BuiltinAttribInfo -> ILAttribute -> bool
+
+ val TryFindILAttribute: BuiltinAttribInfo -> ILAttributes -> bool
+
+ val inline hasFlag: flags: ^F -> flag: ^F -> bool when ^F: enum
+
+ /// Compute well-known attribute flags for an ILAttributes collection.
+ val classifyILAttrib: attr: ILAttribute -> WellKnownILAttributes
+
+ val computeILWellKnownFlags: _g: TcGlobals -> attrs: ILAttributes -> WellKnownILAttributes
+
+ val tryFindILAttribByFlag:
+ flag: WellKnownILAttributes -> cattrs: ILAttributes -> (ILAttribElem list * ILAttributeNamedArg list) option
+
+ []
+ val (|ILAttribDecoded|_|):
+ flag: WellKnownILAttributes -> cattrs: ILAttributes -> (ILAttribElem list * ILAttributeNamedArg list) voption
+
+ type ILAttributesStored with
+
+ member HasWellKnownAttribute: g: TcGlobals * flag: WellKnownILAttributes -> bool
+
+ type ILTypeDef with
+
+ member HasWellKnownAttribute: g: TcGlobals * flag: WellKnownILAttributes -> bool
+
+ type ILMethodDef with
+
+ member HasWellKnownAttribute: g: TcGlobals * flag: WellKnownILAttributes -> bool
+
+ type ILFieldDef with
+
+ member HasWellKnownAttribute: g: TcGlobals * flag: WellKnownILAttributes -> bool
+
+ type ILAttributes with
+
+ /// Non-caching (unlike ILAttributesStored.HasWellKnownAttribute which caches).
+ member HasWellKnownAttribute: flag: WellKnownILAttributes -> bool
+
+ val IsMatchingFSharpAttribute: TcGlobals -> BuiltinAttribInfo -> Attrib -> bool
+
+ val HasFSharpAttribute: TcGlobals -> BuiltinAttribInfo -> Attribs -> bool
+
+ val TryFindFSharpAttribute: TcGlobals -> BuiltinAttribInfo -> Attribs -> Attrib option
+
+ []
+ val (|ExtractAttribNamedArg|_|): string -> AttribNamedArg list -> AttribExpr voption
+
+ []
+ val (|ExtractILAttributeNamedArg|_|): string -> ILAttributeNamedArg list -> ILAttribElem voption
+
+ []
+ val (|StringExpr|_|): (Expr -> string voption)
+
+ []
+ val (|AttribInt32Arg|_|): (AttribExpr -> int32 voption)
+
+ []
+ val (|AttribInt16Arg|_|): (AttribExpr -> int16 voption)
+
+ []
+ val (|AttribBoolArg|_|): (AttribExpr -> bool voption)
+
+ []
+ val (|AttribStringArg|_|): (AttribExpr -> string voption)
+
+ val (|AttribElemStringArg|_|): (ILAttribElem -> string option)
+
+[]
+module internal AttributeHelpers =
+
+ val computeEntityWellKnownFlags: g: TcGlobals -> attribs: Attribs -> WellKnownEntityAttributes
+
+ /// Classify a single entity-level attrib to its well-known flag (or None).
+ val classifyEntityAttrib: g: TcGlobals -> attrib: Attrib -> WellKnownEntityAttributes
+
+ /// Classify a single val-level attrib to its well-known flag (or None).
+ val classifyValAttrib: g: TcGlobals -> attrib: Attrib -> WellKnownValAttributes
+
+ /// Classify a single assembly-level attrib to its well-known flag (or None).
+ val classifyAssemblyAttrib: g: TcGlobals -> attrib: Attrib -> WellKnownAssemblyAttributes
+
+ /// Check if an Entity has a specific well-known attribute, computing and caching flags if needed.
+ val attribsHaveEntityFlag: g: TcGlobals -> flag: WellKnownEntityAttributes -> attribs: Attribs -> bool
+
+ val filterOutWellKnownAttribs:
+ g: TcGlobals ->
+ entityMask: WellKnownEntityAttributes ->
+ valMask: WellKnownValAttributes ->
+ attribs: Attribs ->
+ Attribs
+
+ val tryFindEntityAttribByFlag: g: TcGlobals -> flag: WellKnownEntityAttributes -> attribs: Attribs -> Attrib option
+
+ []
+ val (|EntityAttrib|_|): g: TcGlobals -> flag: WellKnownEntityAttributes -> attribs: Attribs -> Attrib voption
+
+ []
+ val (|EntityAttribInt|_|): g: TcGlobals -> flag: WellKnownEntityAttributes -> attribs: Attribs -> int voption
+
+ []
+ val (|EntityAttribString|_|): g: TcGlobals -> flag: WellKnownEntityAttributes -> attribs: Attribs -> string voption
+
+ val attribsHaveValFlag: g: TcGlobals -> flag: WellKnownValAttributes -> attribs: Attribs -> bool
+
+ val tryFindValAttribByFlag: g: TcGlobals -> flag: WellKnownValAttributes -> attribs: Attribs -> Attrib option
+
+ []
+ val (|ValAttrib|_|): g: TcGlobals -> flag: WellKnownValAttributes -> attribs: Attribs -> Attrib voption
+
+ []
+ val (|ValAttribInt|_|): g: TcGlobals -> flag: WellKnownValAttributes -> attribs: Attribs -> int voption
+
+ []
+ val (|ValAttribString|_|): g: TcGlobals -> flag: WellKnownValAttributes -> attribs: Attribs -> string voption
+
+ val EntityHasWellKnownAttribute: g: TcGlobals -> flag: WellKnownEntityAttributes -> entity: Entity -> bool
+
+ /// Get the computed well-known attribute flags for an entity.
+ val GetEntityWellKnownFlags: g: TcGlobals -> entity: Entity -> WellKnownEntityAttributes
+
+ /// Map a WellKnownILAttributes flag to its entity flag + provided-type AttribInfo equivalents.
+ val mapILFlag:
+ g: TcGlobals -> flag: WellKnownILAttributes -> struct (WellKnownEntityAttributes * BuiltinAttribInfo option)
+
+ val computeValWellKnownFlags: g: TcGlobals -> attribs: Attribs -> WellKnownValAttributes
+
+ /// Check if an ArgReprInfo has a specific well-known attribute, computing and caching flags if needed.
+ val ArgReprInfoHasWellKnownAttribute: g: TcGlobals -> flag: WellKnownValAttributes -> argInfo: ArgReprInfo -> bool
+
+ /// Check if a Val has a specific well-known attribute, computing and caching flags if needed.
+ val ValHasWellKnownAttribute: g: TcGlobals -> flag: WellKnownValAttributes -> v: Val -> bool
+
+ /// Query a three-state bool attribute on an entity. Returns bool option.
+ val EntityTryGetBoolAttribute:
+ g: TcGlobals ->
+ trueFlag: WellKnownEntityAttributes ->
+ falseFlag: WellKnownEntityAttributes ->
+ entity: Entity ->
+ bool option
+
+ /// Query a three-state bool attribute on a Val. Returns bool option.
+ val ValTryGetBoolAttribute:
+ g: TcGlobals -> trueFlag: WellKnownValAttributes -> falseFlag: WellKnownValAttributes -> v: Val -> bool option
+
+ /// Try to find a specific attribute on a type definition, where the attribute accepts a string argument.
+ ///
+ /// This is used to detect the 'DefaultMemberAttribute' and 'ConditionalAttribute' attributes (on type definitions)
+ val TryFindTyconRefStringAttribute: TcGlobals -> range -> BuiltinAttribInfo -> TyconRef -> string option
+
+ /// Like TryFindTyconRefStringAttribute but with a fast-path flag check on the IL path.
+ /// Use this when the attribute has a corresponding WellKnownILAttributes flag for O(1) early exit.
+ val TryFindTyconRefStringAttributeFast:
+ TcGlobals -> range -> WellKnownILAttributes -> BuiltinAttribInfo -> TyconRef -> string option
+
+ /// Try to find a specific attribute on a type definition, where the attribute accepts a bool argument.
+ val TryFindTyconRefBoolAttribute: TcGlobals -> range -> BuiltinAttribInfo -> TyconRef -> bool option
+
+ /// Try to find a specific attribute on a type definition
+ val TyconRefHasAttribute: TcGlobals -> range -> BuiltinAttribInfo -> TyconRef -> bool
+
+ /// Try to find an attribute with a specific full name on a type definition
+ val TyconRefHasAttributeByName: range -> string -> TyconRef -> bool
+
+ /// Check if a TyconRef has a well-known attribute, handling both IL and F# metadata with O(1) flag tests.
+ val TyconRefHasWellKnownAttribute: g: TcGlobals -> flag: WellKnownILAttributes -> tcref: TyconRef -> bool
+
+ /// Check if a TyconRef has AllowNullLiteralAttribute, returning Some true/Some false/None.
+ val TyconRefAllowsNull: g: TcGlobals -> tcref: TyconRef -> bool option
+
+ /// Try to find the AttributeUsage attribute, looking for the value of the AllowMultiple named parameter
+ val TryFindAttributeUsageAttribute: TcGlobals -> range -> TyconRef -> bool option
+
+ val (|AttribBitwiseOrExpr|_|): TcGlobals -> Expr -> (Expr * Expr) voption
+
+ []
+ val (|EnumExpr|_|): TcGlobals -> Expr -> Expr voption
+
+ []
+ val (|TypeOfExpr|_|): TcGlobals -> Expr -> TType voption
+
+ []
+ val (|TypeDefOfExpr|_|): TcGlobals -> Expr -> TType voption
+
+ val isNameOfValRef: TcGlobals -> ValRef -> bool
+
+ []
+ val (|NameOfExpr|_|): TcGlobals -> Expr -> TType voption
+
+ []
+ val (|SeqExpr|_|): TcGlobals -> Expr -> unit voption
+
+ val HasDefaultAugmentationAttribute: g: TcGlobals -> tcref: TyconRef -> bool
+
+ []
+ val (|UnopExpr|_|): TcGlobals -> Expr -> (ValRef * Expr) voption
+
+ []
+ val (|BinopExpr|_|): TcGlobals -> Expr -> (ValRef * Expr * Expr) voption
+
+ []
+ val (|SpecificUnopExpr|_|): TcGlobals -> ValRef -> Expr -> Expr voption
+
+ []
+ val (|SpecificBinopExpr|_|): TcGlobals -> ValRef -> Expr -> (Expr * Expr) voption
+
+ []
+ val (|SignedConstExpr|_|): Expr -> unit voption
+
+ []
+ val (|IntegerConstExpr|_|): Expr -> unit voption
+
+ []
+ val (|FloatConstExpr|_|): Expr -> unit voption
+
+ []
+ val (|UncheckedDefaultOfExpr|_|): TcGlobals -> Expr -> TType voption
+
+ []
+ val (|SizeOfExpr|_|): TcGlobals -> Expr -> TType voption
+
+ val mkCompilationMappingAttr: TcGlobals -> int -> ILAttribute
+
+ val mkCompilationMappingAttrWithSeqNum: TcGlobals -> int -> int -> ILAttribute
+
+ val mkCompilationMappingAttrWithVariantNumAndSeqNum: TcGlobals -> int -> int -> int -> ILAttribute
+
+ val mkCompilationArgumentCountsAttr: TcGlobals -> int list -> ILAttribute
+
+ val mkCompilationSourceNameAttr: TcGlobals -> string -> ILAttribute
+
+ val mkCompilationMappingAttrForQuotationResource: TcGlobals -> string * ILTypeRef list -> ILAttribute
+
+#if !NO_TYPEPROVIDERS
+ /// returns Some(assemblyName) for success
+ val TryDecodeTypeProviderAssemblyAttr: ILAttribute -> (string | null) option
+#endif
+
+ val IsSignatureDataVersionAttr: ILAttribute -> bool
+
+ val TryFindAutoOpenAttr: ILAttribute -> string option
+
+ val TryFindInternalsVisibleToAttr: ILAttribute -> string option
+
+ val IsMatchingSignatureDataVersionAttr: ILVersionInfo -> ILAttribute -> bool
+
+ val mkSignatureDataVersionAttr: TcGlobals -> ILVersionInfo -> ILAttribute
+
+ val isSealedTy: TcGlobals -> TType -> bool
+
+ val IsUnionTypeWithNullAsTrueValue: TcGlobals -> Tycon -> bool
+
+ val TyconHasUseNullAsTrueValueAttribute: TcGlobals -> Tycon -> bool
+
+ val CanHaveUseNullAsTrueValueAttribute: TcGlobals -> Tycon -> bool
+
+ val ModuleNameIsMangled: TcGlobals -> Attribs -> bool
+
+ val CompileAsEvent: TcGlobals -> Attribs -> bool
+
+ val ValCompileAsEvent: TcGlobals -> Val -> bool
+
+ val MemberIsCompiledAsInstance: TcGlobals -> TyconRef -> bool -> ValMemberInfo -> Attribs -> bool
+
+ val ValSpecIsCompiledAsInstance: TcGlobals -> Val -> bool
+
+ val ValRefIsCompiledAsInstanceMember: TcGlobals -> ValRef -> bool
+
+ val tryFindExtensionAttribute: g: TcGlobals -> attribs: Attrib list -> Attrib option
+
+ /// Add an System.Runtime.CompilerServices.ExtensionAttribute to the module Entity if found via predicate and not already present.
+ val tryAddExtensionAttributeIfNotAlreadyPresentForModule:
+ g: TcGlobals ->
+ tryFindExtensionAttributeIn: ((Attrib list -> Attrib option) -> Attrib option) ->
+ moduleEntity: Entity ->
+ Entity
+
+ /// Add an System.Runtime.CompilerServices.ExtensionAttribute to the type Entity if found via predicate and not already present.
+ val tryAddExtensionAttributeIfNotAlreadyPresentForType:
+ g: TcGlobals ->
+ tryFindExtensionAttributeIn: ((Attrib list -> Attrib option) -> Attrib option) ->
+ moduleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref ->
+ typeEntity: Entity ->
+ Entity
+
+[]
+module internal ByrefAndSpanHelpers =
+
+ val isByrefLikeTyconRef: TcGlobals -> range -> TyconRef -> bool
+
+ val isSpanLikeTyconRef: TcGlobals -> range -> TyconRef -> bool
+
+ val isByrefLikeTy: TcGlobals -> range -> TType -> bool
+
+ /// Check if the type is a byref-like but not a byref.
+ val isSpanLikeTy: TcGlobals -> range -> TType -> bool
+
+ val isSpanTy: TcGlobals -> range -> TType -> bool
+
+ val tryDestSpanTy: TcGlobals -> range -> TType -> (TyconRef * TType) option
+
+ val destSpanTy: TcGlobals -> range -> TType -> (TyconRef * TType)
+
+ val isReadOnlySpanTy: TcGlobals -> range -> TType -> bool
+
+ val tryDestReadOnlySpanTy: TcGlobals -> range -> TType -> (TyconRef * TType) option
+
+ val destReadOnlySpanTy: TcGlobals -> range -> TType -> (TyconRef * TType)
+
+module internal DebugPrint =
+
+ /// A global flag indicating whether debug output should include ValReprInfo
+ val mutable layoutValReprInfo: bool
+
+ /// A global flag indicating whether debug output should include stamps of Val and Entity
+ val mutable layoutStamps: bool
+
+ /// A global flag indicating whether debug output should include ranges
+ val mutable layoutRanges: bool
+
+ /// A global flag indicating whether debug output should include type information
+ val mutable layoutTypes: bool
+
+ /// Convert a type to a string for debugging purposes
+ val showType: TType -> string
+
+ /// Convert an expression to a string for debugging purposes
+ val showExpr: Expr -> string
+
+ /// Debug layout for a reference to a value
+ val valRefL: ValRef -> Layout
+
+ /// Debug layout for a reference to a union case
+ val unionCaseRefL: UnionCaseRef -> Layout
+
+ /// Debug layout for an value definition at its binding site
+ val valAtBindL: Val -> Layout
+
+ /// Debug layout for an integer
+ val intL: int -> Layout
+
+ /// Debug layout for a value definition
+ val valL: Val -> Layout
+
+ /// Debug layout for a type parameter definition
+ val typarDeclL: Typar -> Layout
+
+ /// Debug layout for a trait constraint
+ val traitL: TraitConstraintInfo -> Layout
+
+ /// Debug layout for a type parameter
+ val typarL: Typar -> Layout
+
+ /// Debug layout for a set of type parameters
+ val typarsL: Typars -> Layout
+
+ /// Debug layout for a type
+ val typeL: TType -> Layout
+
+ /// Debug layout for a method slot signature
+ val slotSigL: SlotSig -> Layout
+
+ /// Debug layout for a module or namespace definition
+ val entityL: ModuleOrNamespace -> Layout
+
+ /// Debug layout for a binding of an expression to a value
+ val bindingL: Binding -> Layout
+
+ /// Debug layout for an expression
+ val exprL: Expr -> Layout
+
+ /// Debug layout for a type definition
+ val tyconL: Tycon -> Layout
+
+ /// Debug layout for a decision tree
+ val decisionTreeL: DecisionTree -> Layout
+
+ /// Debug layout for an implementation file
+ val implFileL: CheckedImplFile -> Layout
+
+ /// Debug layout for a list of implementation files
+ val implFilesL: CheckedImplFile list -> Layout
+
+ /// Debug layout for class and record fields
+ val recdFieldRefL: RecdFieldRef -> Layout
+
+ /// Serialize an entity to a very basic json structure.
+ val serializeEntity: path: string -> entity: Entity -> unit
diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprConstruction.fs b/src/Compiler/TypedTree/TypedTreeOps.ExprConstruction.fs
new file mode 100644
index 0000000000..0076153812
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.ExprConstruction.fs
@@ -0,0 +1,1562 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal ExprConstruction =
+
+ //---------------------------------------------------------------------------
+ // Standard orderings, e.g. for order set/map keys
+ //---------------------------------------------------------------------------
+
+ let valOrder =
+ { new IComparer with
+ member _.Compare(v1, v2) = compareBy v1 v2 _.Stamp
+ }
+
+ let tyconOrder =
+ { new IComparer with
+ member _.Compare(tycon1, tycon2) = compareBy tycon1 tycon2 _.Stamp
+ }
+
+ let recdFieldRefOrder =
+ { new IComparer with
+ member _.Compare(RecdFieldRef(tcref1, nm1), RecdFieldRef(tcref2, nm2)) =
+ let c = tyconOrder.Compare(tcref1.Deref, tcref2.Deref)
+ if c <> 0 then c else compare nm1 nm2
+ }
+
+ let unionCaseRefOrder =
+ { new IComparer with
+ member _.Compare(UnionCaseRef(tcref1, nm1), UnionCaseRef(tcref2, nm2)) =
+ let c = tyconOrder.Compare(tcref1.Deref, tcref2.Deref)
+ if c <> 0 then c else compare nm1 nm2
+ }
+
+ let mkLambdaTy g tps tys bodyTy =
+ mkForallTyIfNeeded tps (mkIteratedFunTy g tys bodyTy)
+
+ let mkLambdaArgTy m tys =
+ match tys with
+ | [] -> error (InternalError("mkLambdaArgTy", m))
+ | [ h ] -> h
+ | _ -> mkRawRefTupleTy tys
+
+ let typeOfLambdaArg m vs = mkLambdaArgTy m (typesOfVals vs)
+
+ let mkMultiLambdaTy g m vs bodyTy = mkFunTy g (typeOfLambdaArg m vs) bodyTy
+
+ /// When compiling FSharp.Core.dll we have to deal with the non-local references into
+ /// the library arising from env.fs. Part of this means that we have to be able to resolve these
+ /// references. This function artificially forces the existence of a module or namespace at a
+ /// particular point in order to do this.
+ let ensureCcuHasModuleOrNamespaceAtPath (ccu: CcuThunk) path (CompPath(_, sa, cpath)) xml =
+ let scoref = ccu.ILScopeRef
+
+ let rec loop prior_cpath (path: Ident list) cpath (modul: ModuleOrNamespace) =
+ let mtype = modul.ModuleOrNamespaceType
+
+ match path, cpath with
+ | hpath :: tpath, (_, mkind) :: tcpath ->
+ let modName = hpath.idText
+
+ if not (Map.containsKey modName mtype.AllEntitiesByCompiledAndLogicalMangledNames) then
+ let mty = Construct.NewEmptyModuleOrNamespaceType mkind
+ let cpath = CompPath(scoref, sa, prior_cpath)
+
+ let smodul =
+ Construct.NewModuleOrNamespace (Some cpath) taccessPublic hpath xml [] (MaybeLazy.Strict mty)
+
+ mtype.AddModuleOrNamespaceByMutation smodul
+
+ let modul = Map.find modName mtype.AllEntitiesByCompiledAndLogicalMangledNames
+ loop (prior_cpath @ [ (modName, Namespace true) ]) tpath tcpath modul
+
+ | _ -> ()
+
+ loop [] path cpath ccu.Contents
+
+ //---------------------------------------------------------------------------
+ // Primitive destructors
+ //---------------------------------------------------------------------------
+
+ /// Look through the Expr.Link nodes arising from type inference
+ let rec stripExpr e =
+ match e with
+ | Expr.Link eref -> stripExpr eref.Value
+ | _ -> e
+
+ let rec stripDebugPoints expr =
+ match stripExpr expr with
+ | Expr.DebugPoint(_, innerExpr) -> stripDebugPoints innerExpr
+ | expr -> expr
+
+ // Strip debug points and remember how to recreate them
+ let (|DebugPoints|) expr =
+ let rec loop expr debug =
+ match stripExpr expr with
+ | Expr.DebugPoint(dp, innerExpr) -> loop innerExpr (debug << fun e -> Expr.DebugPoint(dp, e))
+ | expr -> expr, debug
+
+ loop expr id
+
+ let mkCase (a, b) = TCase(a, b)
+
+ let isRefTupleExpr e =
+ match e with
+ | Expr.Op(TOp.Tuple tupInfo, _, _, _) -> not (evalTupInfoIsStruct tupInfo)
+ | _ -> false
+
+ let tryDestRefTupleExpr e =
+ match e with
+ | Expr.Op(TOp.Tuple tupInfo, _, es, _) when not (evalTupInfoIsStruct tupInfo) -> es
+ | _ -> [ e ]
+
+ //---------------------------------------------------------------------------
+ // Build nodes in decision graphs
+ //---------------------------------------------------------------------------
+
+ let primMkMatch (spBind, mExpr, tree, targets, mMatch, ty) =
+ Expr.Match(spBind, mExpr, tree, targets, mMatch, ty)
+
+ type MatchBuilder(spBind, inpRange: range) =
+
+ let targets = ResizeArray<_>(10)
+
+ member x.AddTarget tg =
+ let n = targets.Count
+ targets.Add tg
+ n
+
+ member x.AddResultTarget(e) =
+ TDSuccess([], x.AddTarget(TTarget([], e, None)))
+
+ member _.CloseTargets() = targets |> ResizeArray.toList
+
+ member _.Close(dtree, m, ty) =
+ primMkMatch (spBind, inpRange, dtree, targets.ToArray(), m, ty)
+
+ let mkBoolSwitch m g t e =
+ TDSwitch(g, [ TCase(DecisionTreeTest.Const(Const.Bool true), t) ], Some e, m)
+
+ let primMkCond spBind m ty e1 e2 e3 =
+ let mbuilder = MatchBuilder(spBind, m)
+
+ let dtree =
+ mkBoolSwitch m e1 (mbuilder.AddResultTarget(e2)) (mbuilder.AddResultTarget(e3))
+
+ mbuilder.Close(dtree, m, ty)
+
+ let mkCond spBind m ty e1 e2 e3 = primMkCond spBind m ty e1 e2 e3
+
+ //---------------------------------------------------------------------------
+ // Primitive constructors
+ //---------------------------------------------------------------------------
+
+ let exprForValRef m vref = Expr.Val(vref, NormalValUse, m)
+ let exprForVal m v = exprForValRef m (mkLocalValRef v)
+
+ let mkLocalAux m s ty mut compgen =
+ let thisv =
+ Construct.NewVal(
+ s,
+ m,
+ None,
+ ty,
+ mut,
+ compgen,
+ None,
+ taccessPublic,
+ ValNotInRecScope,
+ None,
+ NormalVal,
+ [],
+ ValInline.Optional,
+ XmlDoc.Empty,
+ false,
+ false,
+ false,
+ false,
+ false,
+ false,
+ None,
+ ParentNone
+ )
+
+ thisv, exprForVal m thisv
+
+ let mkLocal m s ty = mkLocalAux m s ty Immutable false
+ let mkCompGenLocal m s ty = mkLocalAux m s ty Immutable true
+ let mkMutableCompGenLocal m s ty = mkLocalAux m s ty Mutable true
+
+ // Type gives return type. For type-lambdas this is the formal return type.
+ let mkMultiLambda m vs (body, bodyTy) =
+ Expr.Lambda(newUnique (), None, None, vs, body, m, bodyTy)
+
+ let rebuildLambda m ctorThisValOpt baseValOpt vs (body, bodyTy) =
+ Expr.Lambda(newUnique (), ctorThisValOpt, baseValOpt, vs, body, m, bodyTy)
+
+ let mkLambda m v (body, bodyTy) = mkMultiLambda m [ v ] (body, bodyTy)
+
+ let mkTypeLambda m vs (body, bodyTy) =
+ match vs with
+ | [] -> body
+ | _ -> Expr.TyLambda(newUnique (), vs, body, m, bodyTy)
+
+ let mkTypeChoose m vs body =
+ match vs with
+ | [] -> body
+ | _ -> Expr.TyChoose(vs, body, m)
+
+ let mkObjExpr (ty, basev, basecall, overrides, iimpls, m) =
+ Expr.Obj(newUnique (), ty, basev, basecall, overrides, iimpls, m)
+
+ let mkLambdas g m tps (vs: Val list) (body, bodyTy) =
+ mkTypeLambda m tps (List.foldBack (fun v (e, ty) -> mkLambda m v (e, ty), mkFunTy g v.Type ty) vs (body, bodyTy))
+
+ let mkMultiLambdasCore g m vsl (body, bodyTy) =
+ List.foldBack (fun v (e, ty) -> mkMultiLambda m v (e, ty), mkFunTy g (typeOfLambdaArg m v) ty) vsl (body, bodyTy)
+
+ let mkMultiLambdas g m tps vsl (body, bodyTy) =
+ mkTypeLambda m tps (mkMultiLambdasCore g m vsl (body, bodyTy))
+
+ let mkMemberLambdas g m tps ctorThisValOpt baseValOpt vsl (body, bodyTy) =
+ let expr =
+ match ctorThisValOpt, baseValOpt with
+ | None, None -> mkMultiLambdasCore g m vsl (body, bodyTy)
+ | _ ->
+ match vsl with
+ | [] -> error (InternalError("mk_basev_multi_lambdas_core: can't attach a basev to a non-lambda expression", m))
+ | h :: t ->
+ let body, bodyTy = mkMultiLambdasCore g m t (body, bodyTy)
+ (rebuildLambda m ctorThisValOpt baseValOpt h (body, bodyTy), (mkFunTy g (typeOfLambdaArg m h) bodyTy))
+
+ mkTypeLambda m tps expr
+
+ let mkMultiLambdaBind g v letSeqPtOpt m tps vsl (body, bodyTy) =
+ TBind(v, mkMultiLambdas g m tps vsl (body, bodyTy), letSeqPtOpt)
+
+ let mkBind seqPtOpt v e = TBind(v, e, seqPtOpt)
+
+ let mkLetBind m bind body =
+ Expr.Let(bind, body, m, Construct.NewFreeVarsCache())
+
+ let mkLetsBind m binds body = List.foldBack (mkLetBind m) binds body
+
+ let mkLetsFromBindings m binds body = List.foldBack (mkLetBind m) binds body
+
+ let mkLet seqPtOpt m v x body = mkLetBind m (mkBind seqPtOpt v x) body
+
+ /// Make sticky bindings that are compiler generated (though the variables may not be - e.g. they may be lambda arguments in a beta reduction)
+ let mkCompGenBind v e =
+ TBind(v, e, DebugPointAtBinding.NoneAtSticky)
+
+ let mkCompGenBinds (vs: Val list) (es: Expr list) = List.map2 mkCompGenBind vs es
+
+ let mkCompGenLet m v x body = mkLetBind m (mkCompGenBind v x) body
+
+ let mkInvisibleBind v e =
+ TBind(v, e, DebugPointAtBinding.NoneAtInvisible)
+
+ let mkInvisibleBinds (vs: Val list) (es: Expr list) = List.map2 mkInvisibleBind vs es
+
+ let mkInvisibleLet m v x body = mkLetBind m (mkInvisibleBind v x) body
+
+ let mkInvisibleLets m vs xs body =
+ mkLetsBind m (mkInvisibleBinds vs xs) body
+
+ let mkInvisibleLetsFromBindings m vs xs body =
+ mkLetsFromBindings m (mkInvisibleBinds vs xs) body
+
+ let mkLetRecBinds m binds body =
+ if isNil binds then
+ body
+ else
+ Expr.LetRec(binds, body, m, Construct.NewFreeVarsCache())
+
+ //-------------------------------------------------------------------------
+ // Type schemes...
+ //-------------------------------------------------------------------------
+
+ // Type parameters may be have been equated to other tps in equi-recursive type inference
+ // and unit type inference. Normalize them here
+ let NormalizeDeclaredTyparsForEquiRecursiveInference g tps =
+ match tps with
+ | [] -> []
+ | tps ->
+ tps
+ |> List.map (fun tp ->
+ let ty = mkTyparTy tp
+
+ match tryAnyParTy g ty with
+ | ValueSome anyParTy -> anyParTy
+ | ValueNone -> tp)
+
+ type GeneralizedType = GeneralizedType of Typars * TType
+
+ let mkGenericBindRhs g m generalizedTyparsForRecursiveBlock typeScheme bodyExpr =
+ let (GeneralizedType(generalizedTypars, tauTy)) = typeScheme
+
+ // Normalize the generalized typars
+ let generalizedTypars =
+ NormalizeDeclaredTyparsForEquiRecursiveInference g generalizedTypars
+
+ // Some recursive bindings result in free type variables, e.g.
+ // let rec f (x:'a) = ()
+ // and g() = f y |> ignore
+ // What is the type of y? Type inference equates it to 'a.
+ // But "g" is not polymorphic in 'a. Hence we get a free choice of "'a"
+ // in the scope of "g". Thus at each individual recursive binding we record all
+ // type variables for which we have a free choice, which is precisely the difference
+ // between the union of all sets of generalized type variables and the set generalized
+ // at each particular binding.
+ //
+ // We record an expression node that indicates that a free choice can be made
+ // for these. This expression node effectively binds the type variables.
+ let freeChoiceTypars =
+ ListSet.subtract typarEq generalizedTyparsForRecursiveBlock generalizedTypars
+
+ mkTypeLambda m generalizedTypars (mkTypeChoose m freeChoiceTypars bodyExpr, tauTy)
+
+ let isBeingGeneralized tp typeScheme =
+ let (GeneralizedType(generalizedTypars, _)) = typeScheme
+ ListSet.contains typarRefEq tp generalizedTypars
+
+ //-------------------------------------------------------------------------
+ // Build conditional expressions...
+ //-------------------------------------------------------------------------
+
+ let mkBool (g: TcGlobals) m b = Expr.Const(Const.Bool b, m, g.bool_ty)
+
+ let mkTrue g m = mkBool g m true
+
+ let mkFalse g m = mkBool g m false
+
+ let mkLazyOr (g: TcGlobals) m e1 e2 =
+ mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e1 (mkTrue g m) e2
+
+ let mkLazyAnd (g: TcGlobals) m e1 e2 =
+ mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e1 e2 (mkFalse g m)
+
+ let mkCoerceExpr (e, toTy, m, fromTy) =
+ Expr.Op(TOp.Coerce, [ toTy; fromTy ], [ e ], m)
+
+ let mkAsmExpr (code, tinst, args, rettys, m) =
+ Expr.Op(TOp.ILAsm(code, rettys), tinst, args, m)
+
+ let mkUnionCaseExpr (uc, tinst, args, m) =
+ Expr.Op(TOp.UnionCase uc, tinst, args, m)
+
+ let mkExnExpr (uc, args, m) = Expr.Op(TOp.ExnConstr uc, [], args, m)
+
+ let mkTupleFieldGetViaExprAddr (tupInfo, e, tinst, i, m) =
+ Expr.Op(TOp.TupleFieldGet(tupInfo, i), tinst, [ e ], m)
+
+ let mkAnonRecdFieldGetViaExprAddr (anonInfo, e, tinst, i, m) =
+ Expr.Op(TOp.AnonRecdGet(anonInfo, i), tinst, [ e ], m)
+
+ let mkRecdFieldGetViaExprAddr (e, fref, tinst, m) =
+ Expr.Op(TOp.ValFieldGet fref, tinst, [ e ], m)
+
+ let mkRecdFieldGetAddrViaExprAddr (readonly, e, fref, tinst, m) =
+ Expr.Op(TOp.ValFieldGetAddr(fref, readonly), tinst, [ e ], m)
+
+ let mkStaticRecdFieldGetAddr (readonly, fref, tinst, m) =
+ Expr.Op(TOp.ValFieldGetAddr(fref, readonly), tinst, [], m)
+
+ let mkStaticRecdFieldGet (fref, tinst, m) =
+ Expr.Op(TOp.ValFieldGet fref, tinst, [], m)
+
+ let mkStaticRecdFieldSet (fref, tinst, e, m) =
+ Expr.Op(TOp.ValFieldSet fref, tinst, [ e ], m)
+
+ let mkArrayElemAddress g (readonly, ilInstrReadOnlyAnnotation, isNativePtr, shape, elemTy, exprs, m) =
+ Expr.Op(
+ TOp.ILAsm(
+ [ I_ldelema(ilInstrReadOnlyAnnotation, isNativePtr, shape, mkILTyvarTy 0us) ],
+ [ mkByrefTyWithFlag g readonly elemTy ]
+ ),
+ [ elemTy ],
+ exprs,
+ m
+ )
+
+ let mkRecdFieldSetViaExprAddr (e1, fref, tinst, e2, m) =
+ Expr.Op(TOp.ValFieldSet fref, tinst, [ e1; e2 ], m)
+
+ let mkUnionCaseTagGetViaExprAddr (e1, cref, tinst, m) =
+ Expr.Op(TOp.UnionCaseTagGet cref, tinst, [ e1 ], m)
+
+ /// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions)
+ let mkUnionCaseProof (e1, cref: UnionCaseRef, tinst, m) =
+ if cref.Tycon.IsStructOrEnumTycon then
+ e1
+ else
+ Expr.Op(TOp.UnionCaseProof cref, tinst, [ e1 ], m)
+
+ /// Build a 'TOp.UnionCaseFieldGet' expression for something we've already determined to be a particular union case. For ref-unions,
+ /// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions,
+ /// the input should be the address of the expression.
+ let mkUnionCaseFieldGetProvenViaExprAddr (e1, cref, tinst, j, m) =
+ Expr.Op(TOp.UnionCaseFieldGet(cref, j), tinst, [ e1 ], m)
+
+ /// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions,
+ /// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions,
+ /// the input should be the address of the expression.
+ let mkUnionCaseFieldGetAddrProvenViaExprAddr (readonly, e1, cref, tinst, j, m) =
+ Expr.Op(TOp.UnionCaseFieldGetAddr(cref, j, readonly), tinst, [ e1 ], m)
+
+ /// Build a 'get' expression for something we've already determined to be a particular union case, but where
+ /// the static type of the input is not yet proven to be that particular union case. This requires a type
+ /// cast to 'prove' the condition.
+ let mkUnionCaseFieldGetUnprovenViaExprAddr (e1, cref, tinst, j, m) =
+ mkUnionCaseFieldGetProvenViaExprAddr (mkUnionCaseProof (e1, cref, tinst, m), cref, tinst, j, m)
+
+ let mkUnionCaseFieldSet (e1, cref, tinst, j, e2, m) =
+ Expr.Op(TOp.UnionCaseFieldSet(cref, j), tinst, [ e1; e2 ], m)
+
+ let mkExnCaseFieldGet (e1, ecref, j, m) =
+ Expr.Op(TOp.ExnFieldGet(ecref, j), [], [ e1 ], m)
+
+ let mkExnCaseFieldSet (e1, ecref, j, e2, m) =
+ Expr.Op(TOp.ExnFieldSet(ecref, j), [], [ e1; e2 ], m)
+
+ let mkDummyLambda (g: TcGlobals) (bodyExpr: Expr, bodyExprTy) =
+ let m = bodyExpr.Range
+ mkLambda m (fst (mkCompGenLocal m "unitVar" g.unit_ty)) (bodyExpr, bodyExprTy)
+
+ let mkWhile (g: TcGlobals) (spWhile, marker, guardExpr, bodyExpr, m) =
+ Expr.Op(
+ TOp.While(spWhile, marker),
+ [],
+ [
+ mkDummyLambda g (guardExpr, g.bool_ty)
+ mkDummyLambda g (bodyExpr, g.unit_ty)
+ ],
+ m
+ )
+
+ let mkIntegerForLoop (g: TcGlobals) (spFor, spIn, v, startExpr, dir, finishExpr, bodyExpr: Expr, m) =
+ Expr.Op(
+ TOp.IntegerForLoop(spFor, spIn, dir),
+ [],
+ [
+ mkDummyLambda g (startExpr, g.int_ty)
+ mkDummyLambda g (finishExpr, g.int_ty)
+ mkLambda bodyExpr.Range v (bodyExpr, g.unit_ty)
+ ],
+ m
+ )
+
+ let mkTryWith g (bodyExpr, filterVal, filterExpr: Expr, handlerVal, handlerExpr: Expr, m, ty, spTry, spWith) =
+ Expr.Op(
+ TOp.TryWith(spTry, spWith),
+ [ ty ],
+ [
+ mkDummyLambda g (bodyExpr, ty)
+ mkLambda filterExpr.Range filterVal (filterExpr, ty)
+ mkLambda handlerExpr.Range handlerVal (handlerExpr, ty)
+ ],
+ m
+ )
+
+ let mkTryFinally (g: TcGlobals) (bodyExpr, finallyExpr, m, ty, spTry, spFinally) =
+ Expr.Op(TOp.TryFinally(spTry, spFinally), [ ty ], [ mkDummyLambda g (bodyExpr, ty); mkDummyLambda g (finallyExpr, g.unit_ty) ], m)
+
+ let mkDefault (m, ty) = Expr.Const(Const.Zero, m, ty)
+
+ let mkValSet m vref e =
+ Expr.Op(TOp.LValueOp(LSet, vref), [], [ e ], m)
+
+ let mkAddrSet m vref e =
+ Expr.Op(TOp.LValueOp(LByrefSet, vref), [], [ e ], m)
+
+ let mkAddrGet m vref =
+ Expr.Op(TOp.LValueOp(LByrefGet, vref), [], [], m)
+
+ let mkValAddr m readonly vref =
+ Expr.Op(TOp.LValueOp(LAddrOf readonly, vref), [], [], m)
+
+ let valOfBind (b: Binding) = b.Var
+
+ let valsOfBinds (binds: Bindings) = binds |> List.map (fun b -> b.Var)
+
+ let mkDebugPoint m expr =
+ Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, expr)
+
+ // Used to remove Expr.Link for inner expressions in pattern matches
+ let (|InnerExprPat|) expr = stripExpr expr
+
+[]
+module internal TypedTreeCollections =
+
+ //--------------------------------------------------------------------------
+ // Maps tracking extra information for values
+ //--------------------------------------------------------------------------
+
+ []
+ type ValHash<'T> =
+ | ValHash of Dictionary
+
+ member ht.Values =
+ let (ValHash t) = ht
+ t.Values :> seq<'T>
+
+ member ht.TryFind(v: Val) =
+ let (ValHash t) = ht
+
+ match t.TryGetValue v.Stamp with
+ | true, v -> Some v
+ | _ -> None
+
+ member ht.Add(v: Val, x) =
+ let (ValHash t) = ht
+ t[v.Stamp] <- x
+
+ static member Create() = ValHash(new Dictionary<_, 'T>(11))
+
+ []
+ type ValMultiMap<'T>(contents: StampMap<'T list>) =
+
+ member _.ContainsKey(v: Val) = contents.ContainsKey v.Stamp
+
+ member _.Find(v: Val) =
+ match contents |> Map.tryFind v.Stamp with
+ | Some vals -> vals
+ | _ -> []
+
+ member m.Add(v: Val, x) =
+ ValMultiMap<'T>(contents.Add(v.Stamp, x :: m.Find v))
+
+ member _.Remove(v: Val) =
+ ValMultiMap<'T>(contents.Remove v.Stamp)
+
+ member _.Contents = contents
+
+ static member Empty = ValMultiMap<'T>(Map.empty)
+
+ []
+ type TyconRefMultiMap<'T>(contents: TyconRefMap<'T list>) =
+
+ member _.Find v =
+ match contents.TryFind v with
+ | Some vals -> vals
+ | _ -> []
+
+ member m.Add(v, x) =
+ TyconRefMultiMap<'T>(contents.Add v (x :: m.Find v))
+
+ static member Empty = TyconRefMultiMap<'T>(TyconRefMap<_>.Empty)
+
+ static member OfList vs =
+ (vs, TyconRefMultiMap<'T>.Empty)
+ ||> List.foldBack (fun (x, y) acc -> acc.Add(x, y))
+
+[]
+module internal TypeTesters =
+
+ //--------------------------------------------------------------------------
+ // From Ref_private to Ref_nonlocal when exporting data.
+ //--------------------------------------------------------------------------
+
+ /// Try to create a EntityRef suitable for accessing the given Entity from another assembly
+ let tryRescopeEntity viewedCcu (entity: Entity) : EntityRef voption =
+ match entity.PublicPath with
+ | Some pubpath -> ValueSome(ERefNonLocal(rescopePubPath viewedCcu pubpath))
+ | None -> ValueNone
+
+ /// Try to create a ValRef suitable for accessing the given Val from another assembly
+ let tryRescopeVal viewedCcu (entityRemap: Remap) (vspec: Val) : ValRef voption =
+ match vspec.PublicPath with
+ | Some(ValPubPath(p, fullLinkageKey)) ->
+ // The type information in the val linkage doesn't need to keep any information to trait solutions.
+ let entityRemap =
+ { entityRemap with
+ removeTraitSolutions = true
+ }
+
+ let fullLinkageKey = remapValLinkage entityRemap fullLinkageKey
+
+ let vref =
+ // This compensates for the somewhat poor design decision in the F# compiler and metadata where
+ // members are stored as values under the enclosing namespace/module rather than under the type.
+ // This stems from the days when types and namespace/modules were separated constructs in the
+ // compiler implementation.
+ if vspec.IsIntrinsicMember then
+ mkNonLocalValRef (rescopePubPathToParent viewedCcu p) fullLinkageKey
+ else
+ mkNonLocalValRef (rescopePubPath viewedCcu p) fullLinkageKey
+
+ ValueSome vref
+ | _ -> ValueNone
+
+ //---------------------------------------------------------------------------
+ // Type information about records, constructors etc.
+ //---------------------------------------------------------------------------
+
+ let actualTyOfRecdField inst (fspec: RecdField) = instType inst fspec.FormalType
+
+ let actualTysOfRecdFields inst rfields =
+ List.map (actualTyOfRecdField inst) rfields
+
+ let actualTysOfInstanceRecdFields inst (tcref: TyconRef) =
+ tcref.AllInstanceFieldsAsList |> actualTysOfRecdFields inst
+
+ let actualTysOfUnionCaseFields inst (x: UnionCaseRef) =
+ actualTysOfRecdFields inst x.AllFieldsAsList
+
+ let actualResultTyOfUnionCase tinst (x: UnionCaseRef) =
+ instType (mkTyconRefInst x.TyconRef tinst) x.ReturnType
+
+ let recdFieldsOfExnDefRef x =
+ (stripExnEqns x).TrueInstanceFieldsAsList
+
+ let recdFieldOfExnDefRefByIdx x n = (stripExnEqns x).GetFieldByIndex n
+
+ let recdFieldTysOfExnDefRef x =
+ actualTysOfRecdFields [] (recdFieldsOfExnDefRef x)
+
+ let recdFieldTyOfExnDefRefByIdx x j =
+ actualTyOfRecdField [] (recdFieldOfExnDefRefByIdx x j)
+
+ let actualTyOfRecdFieldForTycon tycon tinst (fspec: RecdField) =
+ instType (mkTyconInst tycon tinst) fspec.FormalType
+
+ let actualTyOfRecdFieldRef (fref: RecdFieldRef) tinst =
+ actualTyOfRecdFieldForTycon fref.Tycon tinst fref.RecdField
+
+ let actualTyOfUnionFieldRef (fref: UnionCaseRef) n tinst =
+ actualTyOfRecdFieldForTycon fref.Tycon tinst (fref.FieldByIndex n)
+
+ //---------------------------------------------------------------------------
+ // Apply type functions to types
+ //---------------------------------------------------------------------------
+
+ let destForallTy g ty =
+ let tps, tau = primDestForallTy g ty
+ // tps may be have been equated to other tps in equi-recursive type inference
+ // and unit type inference. Normalize them here
+ let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps
+ tps, tau
+
+ let tryDestForallTy g ty =
+ if isForallTy g ty then destForallTy g ty else [], ty
+
+ let rec stripFunTy g ty =
+ if isFunTy g ty then
+ let domainTy, rangeTy = destFunTy g ty
+ let more, retTy = stripFunTy g rangeTy
+ domainTy :: more, retTy
+ else
+ [], ty
+
+ let applyForallTy g ty tyargs =
+ let tps, tau = destForallTy g ty
+ instType (mkTyparInst tps tyargs) tau
+
+ let reduceIteratedFunTy g ty args =
+ List.fold
+ (fun ty _ ->
+ if not (isFunTy g ty) then
+ failwith "reduceIteratedFunTy"
+
+ snd (destFunTy g ty))
+ ty
+ args
+
+ let applyTyArgs g ty tyargs =
+ if isForallTy g ty then applyForallTy g ty tyargs else ty
+
+ let applyTys g funcTy (tyargs, argTys) =
+ let afterTyappTy = applyTyArgs g funcTy tyargs
+ reduceIteratedFunTy g afterTyappTy argTys
+
+ let formalApplyTys g funcTy (tyargs, args) =
+ reduceIteratedFunTy g (if isNil tyargs then funcTy else snd (destForallTy g funcTy)) args
+
+ let rec stripFunTyN g n ty =
+ assert (n >= 0)
+
+ if n > 0 && isFunTy g ty then
+ let d, r = destFunTy g ty
+ let more, retTy = stripFunTyN g (n - 1) r
+ d :: more, retTy
+ else
+ [], ty
+
+ let tryDestAnyTupleTy g ty =
+ if isAnyTupleTy g ty then
+ destAnyTupleTy g ty
+ else
+ tupInfoRef, [ ty ]
+
+ let tryDestRefTupleTy g ty =
+ if isRefTupleTy g ty then destRefTupleTy g ty else [ ty ]
+
+ type UncurriedArgInfos = (TType * ArgReprInfo) list
+
+ type CurriedArgInfos = (TType * ArgReprInfo) list list
+
+ type TraitWitnessInfos = TraitWitnessInfo list
+
+ // A 'tau' type is one with its type parameters stripped off
+ let GetTopTauTypeInFSharpForm g (curriedArgInfos: ArgReprInfo list list) tau m =
+ let nArgInfos = curriedArgInfos.Length
+ let argTys, retTy = stripFunTyN g nArgInfos tau
+
+ if nArgInfos <> argTys.Length then
+ error (Error(FSComp.SR.tastInvalidMemberSignature (), m))
+
+ let argTysl =
+ (curriedArgInfos, argTys)
+ ||> List.map2 (fun argInfos argTy ->
+ match argInfos with
+ | [] -> [ (g.unit_ty, ValReprInfo.unnamedTopArg1) ]
+ | [ argInfo ] -> [ (argTy, argInfo) ]
+ | _ -> List.zip (destRefTupleTy g argTy) argInfos)
+
+ argTysl, retTy
+
+ let destTopForallTy g (ValReprInfo(ntps, _, _)) ty =
+ let tps, tau = (if isNil ntps then [], ty else tryDestForallTy g ty)
+ // tps may be have been equated to other tps in equi-recursive type inference. Normalize them here
+ let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps
+ tps, tau
+
+ let GetValReprTypeInFSharpForm g (ValReprInfo(_, argInfos, retInfo) as valReprInfo) ty m =
+ let tps, tau = destTopForallTy g valReprInfo ty
+ let curriedArgTys, returnTy = GetTopTauTypeInFSharpForm g argInfos tau m
+ tps, curriedArgTys, returnTy, retInfo
+
+ let IsCompiledAsStaticProperty g (v: Val) =
+ match v.ValReprInfo with
+ | Some valReprInfoValue ->
+ match GetValReprTypeInFSharpForm g valReprInfoValue v.Type v.Range with
+ | [], [], _, _ when not v.IsMember -> true
+ | _ -> false
+ | _ -> false
+
+ let IsCompiledAsStaticPropertyWithField g (v: Val) =
+ not v.IsCompiledAsStaticPropertyWithoutField && IsCompiledAsStaticProperty g v
+
+ //-------------------------------------------------------------------------
+ // Multi-dimensional array types...
+ //-------------------------------------------------------------------------
+
+ let isArrayTyconRef (g: TcGlobals) tcref =
+ g.il_arr_tcr_map |> Array.exists (tyconRefEq g tcref)
+
+ let rankOfArrayTyconRef (g: TcGlobals) tcref =
+ match g.il_arr_tcr_map |> Array.tryFindIndex (tyconRefEq g tcref) with
+ | Some idx -> idx + 1
+ | None -> failwith "rankOfArrayTyconRef: unsupported array rank"
+
+ //-------------------------------------------------------------------------
+ // Misc functions on F# types
+ //-------------------------------------------------------------------------
+
+ let destArrayTy (g: TcGlobals) ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, [ ty ]) when isArrayTyconRef g tcref -> ty
+ | _ -> failwith "destArrayTy"
+
+ let destListTy (g: TcGlobals) ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, [ ty ]) when tyconRefEq g tcref g.list_tcr_canon -> ty
+ | _ -> failwith "destListTy"
+
+ let tyconRefEqOpt g tcrefOpt tcref =
+ match tcrefOpt with
+ | None -> false
+ | Some tcref2 -> tyconRefEq g tcref2 tcref
+
+ let isStringTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g tcref g.system_String_tcref
+ | _ -> false)
+
+ let isListTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g tcref g.list_tcr_canon
+ | _ -> false)
+
+ let isArrayTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> isArrayTyconRef g tcref
+ | _ -> false)
+
+ let isArray1DTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g tcref g.il_arr_tcr_map[0]
+ | _ -> false)
+
+ let isUnitTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g g.unit_tcr_canon tcref
+ | _ -> false)
+
+ let isObjTyAnyNullness g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g g.system_Object_tcref tcref
+ | _ -> false)
+
+ let isObjNullTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, n) when
+ (not g.checkNullness)
+ || (n.TryEvaluate() <> ValueSome(NullnessInfo.WithoutNull))
+ ->
+ tyconRefEq g g.system_Object_tcref tcref
+ | _ -> false)
+
+ let isObjTyWithoutNull (g: TcGlobals) ty =
+ g.checkNullness
+ && ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, n) when (n.TryEvaluate() = ValueSome(NullnessInfo.WithoutNull)) -> tyconRefEq g g.system_Object_tcref tcref
+ | _ -> false)
+
+ let isValueTypeTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g g.system_Value_tcref tcref
+ | _ -> false)
+
+ let isVoidTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g g.system_Void_tcref tcref
+ | _ -> false)
+
+ let isILAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsILTycon
+ | _ -> false)
+
+ let isNativePtrTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g g.nativeptr_tcr tcref
+ | _ -> false)
+
+ let isByrefTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) when g.byref2_tcr.CanDeref -> tyconRefEq g g.byref2_tcr tcref
+ | TType_app(tcref, _, _) -> tyconRefEq g g.byref_tcr tcref
+ | _ -> false)
+
+ let isInByrefTag g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, [], _) -> tyconRefEq g g.byrefkind_In_tcr tcref
+ | _ -> false)
+
+ let isInByrefTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, [ _; tagTy ], _) when g.byref2_tcr.CanDeref -> tyconRefEq g g.byref2_tcr tcref && isInByrefTag g tagTy
+ | _ -> false)
+
+ let isOutByrefTag g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, [], _) -> tyconRefEq g g.byrefkind_Out_tcr tcref
+ | _ -> false)
+
+ let isOutByrefTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, [ _; tagTy ], _) when g.byref2_tcr.CanDeref -> tyconRefEq g g.byref2_tcr tcref && isOutByrefTag g tagTy
+ | _ -> false)
+
+#if !NO_TYPEPROVIDERS
+ let extensionInfoOfTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.TypeReprInfo
+ | _ -> TNoRepr)
+#endif
+
+ type TypeDefMetadata =
+ | ILTypeMetadata of TILObjectReprData
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata of TProvidedTypeInfo
+#endif
+
+ let metadataOfTycon (tycon: Tycon) =
+#if !NO_TYPEPROVIDERS
+ match tycon.TypeReprInfo with
+ | TProvidedTypeRepr info -> ProvidedTypeMetadata info
+ | _ ->
+#endif
+ if tycon.IsILTycon then
+ ILTypeMetadata tycon.ILTyconInfo
+ else
+ FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata
+
+ let metadataOfTy g ty =
+#if !NO_TYPEPROVIDERS
+ match extensionInfoOfTy g ty with
+ | TProvidedTypeRepr info -> ProvidedTypeMetadata info
+ | _ ->
+#endif
+ if isILAppTy g ty then
+ let tcref = tcrefOfAppTy g ty
+ ILTypeMetadata tcref.ILTyconInfo
+ else
+ FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata
+
+ let isILReferenceTy g ty =
+ match metadataOfTy g ty with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info -> not info.IsStructOrEnum
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, td)) -> not td.IsStructOrEnum
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isArrayTy g ty
+
+ let isILInterfaceTycon (tycon: Tycon) =
+ match metadataOfTycon tycon with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info -> info.IsInterface
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsInterface
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> false
+
+ let rankOfArrayTy g ty =
+ rankOfArrayTyconRef g (tcrefOfAppTy g ty)
+
+ let isFSharpObjModelRefTy g ty =
+ isFSharpObjModelTy g ty
+ && let tcref = tcrefOfAppTy g ty in
+
+ match tcref.FSharpTyconRepresentationData.fsobjmodel_kind with
+ | TFSharpClass
+ | TFSharpInterface
+ | TFSharpDelegate _ -> true
+ | TFSharpUnion
+ | TFSharpRecord
+ | TFSharpStruct
+ | TFSharpEnum -> false
+
+ let isFSharpClassTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.Deref.IsFSharpClassTycon
+ | _ -> false
+
+ let isFSharpStructTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.Deref.IsFSharpStructOrEnumTycon
+ | _ -> false
+
+ let isFSharpInterfaceTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.Deref.IsFSharpInterfaceTycon
+ | _ -> false
+
+ let isDelegateTy g ty =
+ match metadataOfTy g ty with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info -> info.IsDelegate()
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsDelegate
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.Deref.IsFSharpDelegateTycon
+ | _ -> false
+
+ let isInterfaceTy g ty =
+ match metadataOfTy g ty with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info -> info.IsInterface
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsInterface
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpInterfaceTy g ty
+
+ let isFSharpDelegateTy g ty =
+ isDelegateTy g ty && isFSharpObjModelTy g ty
+
+ let isClassTy g ty =
+ match metadataOfTy g ty with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info -> info.IsClass
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsClass
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpClassTy g ty
+
+ let isStructOrEnumTyconTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.Deref.IsStructOrEnumTycon
+ | _ -> false
+
+ let isStructRecordOrUnionTyconTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.Deref.IsStructRecordOrUnionTycon
+ | _ -> false
+
+ let isStructTyconRef (tcref: TyconRef) =
+ let tycon = tcref.Deref
+ tycon.IsStructRecordOrUnionTycon || tycon.IsStructOrEnumTycon
+
+ let isStructTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> isStructTyconRef tcref
+ | _ -> isStructAnonRecdTy g ty || isStructTupleTy g ty
+
+ let isMeasureableValueType g ty =
+ match stripTyEqns g ty with
+ | TType_app(tcref, _, _) when tcref.IsMeasureableReprTycon ->
+ let erasedTy = stripTyEqnsAndMeasureEqns g ty
+ isStructTy g erasedTy
+ | _ -> false
+
+ let isRefTy g ty =
+ not (isStructOrEnumTyconTy g ty)
+ && (isUnionTy g ty
+ || isRefTupleTy g ty
+ || isRecdTy g ty
+ || isILReferenceTy g ty
+ || isFunTy g ty
+ || isReprHiddenTy g ty
+ || isFSharpObjModelRefTy g ty
+ || isUnitTy g ty
+ || (isAnonRecdTy g ty && not (isStructAnonRecdTy g ty)))
+
+ let isForallFunctionTy g ty =
+ let _, tau = tryDestForallTy g ty
+ isFunTy g tau
+
+ // An unmanaged-type is any type that isn't a reference-type, a type-parameter, or a generic struct-type and
+ // contains no fields whose type is not an unmanaged-type. In other words, an unmanaged-type is one of the
+ // following:
+ // - sbyte, byte, short, ushort, int, uint, long, ulong, char, float, double, decimal, or bool.
+ // - Any enum-type.
+ // - Any pointer-type.
+ // - Any generic user-defined struct-type that can be statically determined to be 'unmanaged' at construction.
+ let rec isUnmanagedTy g ty =
+ let isUnmanagedRecordField tinst rf =
+ isUnmanagedTy g (actualTyOfRecdField tinst rf)
+
+ let ty = stripTyEqnsAndMeasureEqns g ty
+
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref ->
+ let isEq tcref2 = tyconRefEq g tcref tcref2
+
+ if
+ isEq g.nativeptr_tcr
+ || isEq g.nativeint_tcr
+ || isEq g.sbyte_tcr
+ || isEq g.byte_tcr
+ || isEq g.int16_tcr
+ || isEq g.uint16_tcr
+ || isEq g.int32_tcr
+ || isEq g.uint32_tcr
+ || isEq g.int64_tcr
+ || isEq g.uint64_tcr
+ || isEq g.char_tcr
+ || isEq g.voidptr_tcr
+ || isEq g.float32_tcr
+ || isEq g.float_tcr
+ || isEq g.decimal_tcr
+ || isEq g.bool_tcr
+ then
+ true
+ else
+ let tycon = tcref.Deref
+
+ if tycon.IsEnumTycon then
+ true
+ elif isStructUnionTy g ty then
+ let tinst = mkInstForAppTy g ty
+
+ tcref.UnionCasesAsRefList
+ |> List.forall (fun c -> c |> actualTysOfUnionCaseFields tinst |> List.forall (isUnmanagedTy g))
+ elif tycon.IsStructOrEnumTycon then
+ let tinst = mkInstForAppTy g ty
+ tycon.AllInstanceFieldsAsList |> List.forall (isUnmanagedRecordField tinst)
+ else
+ false
+ | ValueNone ->
+ if isStructTupleTy g ty then
+ (destStructTupleTy g ty) |> List.forall (isUnmanagedTy g)
+ else if isStructAnonRecdTy g ty then
+ (destStructAnonRecdTy g ty) |> List.forall (isUnmanagedTy g)
+ else
+ false
+
+ let isInterfaceTycon x =
+ isILInterfaceTycon x || x.IsFSharpInterfaceTycon
+
+ let isInterfaceTyconRef (tcref: TyconRef) = isInterfaceTycon tcref.Deref
+
+ let isEnumTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tcref.IsEnumTycon
+
+ let isSignedIntegerTy g ty =
+ typeEquivAux EraseMeasures g g.sbyte_ty ty
+ || typeEquivAux EraseMeasures g g.int16_ty ty
+ || typeEquivAux EraseMeasures g g.int32_ty ty
+ || typeEquivAux EraseMeasures g g.nativeint_ty ty
+ || typeEquivAux EraseMeasures g g.int64_ty ty
+
+ let isUnsignedIntegerTy g ty =
+ typeEquivAux EraseMeasures g g.byte_ty ty
+ || typeEquivAux EraseMeasures g g.uint16_ty ty
+ || typeEquivAux EraseMeasures g g.uint32_ty ty
+ || typeEquivAux EraseMeasures g g.unativeint_ty ty
+ || typeEquivAux EraseMeasures g g.uint64_ty ty
+
+ let isIntegerTy g ty =
+ isSignedIntegerTy g ty || isUnsignedIntegerTy g ty
+
+ /// float or float32 or float<_> or float32<_>
+ let isFpTy g ty =
+ typeEquivAux EraseMeasures g g.float_ty ty
+ || typeEquivAux EraseMeasures g g.float32_ty ty
+
+ /// decimal or decimal<_>
+ let isDecimalTy g ty =
+ typeEquivAux EraseMeasures g g.decimal_ty ty
+
+ let isNonDecimalNumericType g ty = isIntegerTy g ty || isFpTy g ty
+
+ let isNumericType g ty =
+ isNonDecimalNumericType g ty || isDecimalTy g ty
+
+ let actualReturnTyOfSlotSig parentTyInst methTyInst (TSlotSig(_, _, parentFormalTypars, methFormalTypars, _, formalRetTy)) =
+ let methTyInst = mkTyparInst methFormalTypars methTyInst
+ let parentTyInst = mkTyparInst parentFormalTypars parentTyInst
+ Option.map (instType (parentTyInst @ methTyInst)) formalRetTy
+
+ let slotSigHasVoidReturnTy (TSlotSig(_, _, _, _, _, formalRetTy)) = Option.isNone formalRetTy
+
+ let returnTyOfMethod g (TObjExprMethod(TSlotSig(_, parentTy, _, _, _, _) as ss, _, methFormalTypars, _, _, _)) =
+ let tinst = argsOfAppTy g parentTy
+ let methTyInst = generalizeTypars methFormalTypars
+ actualReturnTyOfSlotSig tinst methTyInst ss
+
+ /// Is the type 'abstract' in C#-speak
+ let isAbstractTycon (tycon: Tycon) =
+ if tycon.IsFSharpObjectModelTycon then
+ not tycon.IsFSharpDelegateTycon && tycon.TypeContents.tcaug_abstract
+ else
+ tycon.IsILTycon && tycon.ILTyconRawMetadata.IsAbstract
+
+ //---------------------------------------------------------------------------
+ // Determine if a member/Val/ValRef is an explicit impl
+ //---------------------------------------------------------------------------
+
+ let MemberIsExplicitImpl g (membInfo: ValMemberInfo) =
+ membInfo.MemberFlags.IsOverrideOrExplicitImpl
+ && match membInfo.ImplementedSlotSigs with
+ | [] -> false
+ | slotsigs -> slotsigs |> List.forall (fun slotsig -> isInterfaceTy g slotsig.DeclaringType)
+
+ let ValIsExplicitImpl g (v: Val) =
+ match v.MemberInfo with
+ | Some membInfo -> MemberIsExplicitImpl g membInfo
+ | _ -> false
+
+ let ValRefIsExplicitImpl g (vref: ValRef) = ValIsExplicitImpl g vref.Deref
+
+ // Get measure of type, float<_> or float32<_> or decimal<_> but not float=float<1> or float32=float32<1> or decimal=decimal<1>
+ let getMeasureOfType g ty =
+ match ty with
+ | AppTy g (tcref, [ tyarg ]) ->
+ match stripTyEqns g tyarg with
+ | TType_measure ms when not (measureEquiv g ms (Measure.One(tcref.Range))) -> Some(tcref, ms)
+ | _ -> None
+ | _ -> None
+
+ let isErasedType g ty =
+ match stripTyEqns g ty with
+#if !NO_TYPEPROVIDERS
+ | TType_app(tcref, _, _) -> tcref.IsProvidedErasedTycon
+#endif
+ | _ -> false
+
+ // Return all components of this type expression that cannot be tested at runtime
+ let rec getErasedTypes g ty checkForNullness =
+ let ty = stripTyEqns g ty
+
+ if isErasedType g ty then
+ [ ty ]
+ else
+ match ty with
+ | TType_forall(_, bodyTy) -> getErasedTypes g bodyTy checkForNullness
+
+ | TType_var(tp, nullness) ->
+ match checkForNullness, nullness.Evaluate() with
+ | true, NullnessInfo.WithNull -> [ ty ] // with-null annotations can't be tested at runtime, Nullable<> is not part of Nullness feature as of now.
+ | _ -> if tp.IsErased then [ ty ] else []
+
+ | TType_app(_, b, nullness) ->
+ match checkForNullness, nullness.Evaluate() with
+ | true, NullnessInfo.WithNull -> [ ty ]
+ | _ -> List.foldBack (fun ty tys -> getErasedTypes g ty false @ tys) b []
+
+ | TType_ucase(_, b)
+ | TType_anon(_, b)
+ | TType_tuple(_, b) -> List.foldBack (fun ty tys -> getErasedTypes g ty false @ tys) b []
+
+ | TType_fun(domainTy, rangeTy, nullness) ->
+ match checkForNullness, nullness.Evaluate() with
+ | true, NullnessInfo.WithNull -> [ ty ]
+ | _ -> getErasedTypes g domainTy false @ getErasedTypes g rangeTy false
+ | TType_measure _ -> [ ty ]
+
+ let underlyingTypeOfEnumTy (g: TcGlobals) ty =
+ assert (isEnumTy g ty)
+
+ match metadataOfTy g ty with
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata info -> info.UnderlyingTypeOfEnum()
+#endif
+ | ILTypeMetadata(TILObjectReprData(_, _, tdef)) ->
+
+ let info = computeILEnumInfo (tdef.Name, tdef.Fields)
+ let ilTy = getTyOfILEnumInfo info
+
+ match ilTy.TypeSpec.Name with
+ | "System.Byte" -> g.byte_ty
+ | "System.SByte" -> g.sbyte_ty
+ | "System.Int16" -> g.int16_ty
+ | "System.Int32" -> g.int32_ty
+ | "System.Int64" -> g.int64_ty
+ | "System.UInt16" -> g.uint16_ty
+ | "System.UInt32" -> g.uint32_ty
+ | "System.UInt64" -> g.uint64_ty
+ | "System.Single" -> g.float32_ty
+ | "System.Double" -> g.float_ty
+ | "System.Char" -> g.char_ty
+ | "System.Boolean" -> g.bool_ty
+ | _ -> g.int32_ty
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
+ let tycon = (tcrefOfAppTy g ty).Deref
+
+ match tycon.GetFieldByName "value__" with
+ | Some rf -> rf.FormalType
+ | None -> error (InternalError("no 'value__' field found for enumeration type " + tycon.LogicalName, tycon.Range))
+
+ let normalizeEnumTy g ty =
+ (if isEnumTy g ty then underlyingTypeOfEnumTy g ty else ty)
+
+ let isResumableCodeTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tyconRefEq g tcref g.ResumableCode_tcr
+ | _ -> false)
+
+ let rec isReturnsResumableCodeTy g ty =
+ if isFunTy g ty then
+ isReturnsResumableCodeTy g (rangeOfFunTy g ty)
+ else
+ isResumableCodeTy g ty
+
+ let ComputeUseMethodImpl g (v: Val) =
+ v.ImplementedSlotSigs
+ |> List.exists (fun slotsig ->
+ let oty = slotsig.DeclaringType
+ let otcref = tcrefOfAppTy g oty
+ let tcref = v.MemberApparentEntity
+
+ // REVIEW: it would be good to get rid of this special casing of Compare and GetHashCode
+ isInterfaceTy g oty
+ &&
+
+ (let isCompare =
+ tcref.GeneratedCompareToValues.IsSome
+ && (typeEquiv g oty g.mk_IComparable_ty
+ || tyconRefEq g g.system_GenericIComparable_tcref otcref)
+
+ not isCompare)
+ &&
+
+ (let isGenericEquals =
+ tcref.GeneratedHashAndEqualsWithComparerValues.IsSome
+ && tyconRefEq g g.system_GenericIEquatable_tcref otcref
+
+ not isGenericEquals)
+ &&
+
+ (let isStructural =
+ (tcref.GeneratedCompareToWithComparerValues.IsSome
+ && typeEquiv g oty g.mk_IStructuralComparable_ty)
+ || (tcref.GeneratedHashAndEqualsWithComparerValues.IsSome
+ && typeEquiv g oty g.mk_IStructuralEquatable_ty)
+
+ not isStructural))
+
+ let useGenuineField (tycon: Tycon) (f: RecdField) =
+ Option.isSome f.LiteralValue
+ || tycon.IsEnumTycon
+ || f.rfield_secret
+ || (not f.IsStatic && f.rfield_mutable && not tycon.IsRecordTycon)
+
+ let ComputeFieldName tycon f =
+ if useGenuineField tycon f then
+ f.rfield_id.idText
+ else
+ CompilerGeneratedName f.rfield_id.idText
+
+[]
+module internal CommonContainers =
+
+ let isByrefTyconRef (g: TcGlobals) (tcref: TyconRef) =
+ (g.byref_tcr.CanDeref && tyconRefEq g g.byref_tcr tcref)
+ || (g.byref2_tcr.CanDeref && tyconRefEq g g.byref2_tcr tcref)
+ || (g.inref_tcr.CanDeref && tyconRefEq g g.inref_tcr tcref)
+ || (g.outref_tcr.CanDeref && tyconRefEq g g.outref_tcr tcref)
+ || tyconRefEqOpt g g.system_TypedReference_tcref tcref
+ || tyconRefEqOpt g g.system_ArgIterator_tcref tcref
+ || tyconRefEqOpt g g.system_RuntimeArgumentHandle_tcref tcref
+
+ //-------------------------------------------------------------------------
+ // List and reference types...
+ //-------------------------------------------------------------------------
+
+ let destByrefTy g ty =
+ match ty |> stripTyEqns g with
+ | TType_app(tcref, [ x; _ ], _) when g.byref2_tcr.CanDeref && tyconRefEq g g.byref2_tcr tcref -> x // Check sufficient FSharp.Core
+ | TType_app(tcref, [ x ], _) when tyconRefEq g g.byref_tcr tcref -> x // all others
+ | _ -> failwith "destByrefTy: not a byref type"
+
+ []
+ let (|ByrefTy|_|) g ty =
+ // Because of byref = byref2 it is better to write this using is/dest
+ if isByrefTy g ty then
+ ValueSome(destByrefTy g ty)
+ else
+ ValueNone
+
+ let destNativePtrTy g ty =
+ match ty |> stripTyEqns g with
+ | TType_app(tcref, [ x ], _) when tyconRefEq g g.nativeptr_tcr tcref -> x
+ | _ -> failwith "destNativePtrTy: not a native ptr type"
+
+ let isRefCellTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tyconRefEq g g.refcell_tcr_canon tcref
+
+ let destRefCellTy g ty =
+ match ty |> stripTyEqns g with
+ | TType_app(tcref, [ x ], _) when tyconRefEq g g.refcell_tcr_canon tcref -> x
+ | _ -> failwith "destRefCellTy: not a ref type"
+
+ let StripSelfRefCell (g: TcGlobals, baseOrThisInfo: ValBaseOrThisInfo, tau: TType) : TType =
+ if baseOrThisInfo = CtorThisVal && isRefCellTy g tau then
+ destRefCellTy g tau
+ else
+ tau
+
+ let mkRefCellTy (g: TcGlobals) ty =
+ TType_app(g.refcell_tcr_nice, [ ty ], g.knownWithoutNull)
+
+ let mkLazyTy (g: TcGlobals) ty =
+ TType_app(g.lazy_tcr_nice, [ ty ], g.knownWithoutNull)
+
+ let mkPrintfFormatTy (g: TcGlobals) aty bty cty dty ety =
+ TType_app(g.format_tcr, [ aty; bty; cty; dty; ety ], g.knownWithoutNull)
+
+ let mkOptionTy (g: TcGlobals) ty =
+ TType_app(g.option_tcr_nice, [ ty ], g.knownWithoutNull)
+
+ let mkValueOptionTy (g: TcGlobals) ty =
+ TType_app(g.valueoption_tcr_nice, [ ty ], g.knownWithoutNull)
+
+ let mkNullableTy (g: TcGlobals) ty =
+ TType_app(g.system_Nullable_tcref, [ ty ], g.knownWithoutNull)
+
+ let mkListTy (g: TcGlobals) ty =
+ TType_app(g.list_tcr_nice, [ ty ], g.knownWithoutNull)
+
+ let isBoolTy (g: TcGlobals) ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tyconRefEq g g.system_Bool_tcref tcref || tyconRefEq g g.bool_tcr tcref
+
+ let isValueOptionTy (g: TcGlobals) ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tyconRefEq g g.valueoption_tcr_canon tcref
+
+ let isOptionTy (g: TcGlobals) ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tyconRefEq g g.option_tcr_canon tcref
+
+ let isChoiceTy (g: TcGlobals) ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref ->
+ tyconRefEq g g.choice2_tcr tcref
+ || tyconRefEq g g.choice3_tcr tcref
+ || tyconRefEq g g.choice4_tcr tcref
+ || tyconRefEq g g.choice5_tcr tcref
+ || tyconRefEq g g.choice6_tcr tcref
+ || tyconRefEq g g.choice7_tcr tcref
+
+ let tryDestOptionTy g ty =
+ match argsOfAppTy g ty with
+ | [ ty1 ] when isOptionTy g ty -> ValueSome ty1
+ | _ -> ValueNone
+
+ let tryDestValueOptionTy g ty =
+ match argsOfAppTy g ty with
+ | [ ty1 ] when isValueOptionTy g ty -> ValueSome ty1
+ | _ -> ValueNone
+
+ let tryDestChoiceTy g ty idx =
+ match argsOfAppTy g ty with
+ | ls when isChoiceTy g ty && ls.Length > idx -> ValueSome ls[idx]
+ | _ -> ValueNone
+
+ let destOptionTy g ty =
+ match tryDestOptionTy g ty with
+ | ValueSome ty -> ty
+ | ValueNone -> failwith "destOptionTy: not an option type"
+
+ let destValueOptionTy g ty =
+ match tryDestValueOptionTy g ty with
+ | ValueSome ty -> ty
+ | ValueNone -> failwith "destValueOptionTy: not a value option type"
+
+ let destChoiceTy g ty idx =
+ match tryDestChoiceTy g ty idx with
+ | ValueSome ty -> ty
+ | ValueNone -> failwith "destChoiceTy: not a Choice type"
+
+ let isNullableTy (g: TcGlobals) ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tyconRefEq g g.system_Nullable_tcref tcref
+
+ let tryDestNullableTy g ty =
+ match argsOfAppTy g ty with
+ | [ ty1 ] when isNullableTy g ty -> ValueSome ty1
+ | _ -> ValueNone
+
+ let destNullableTy g ty =
+ match tryDestNullableTy g ty with
+ | ValueSome ty -> ty
+ | ValueNone -> failwith "destNullableTy: not a Nullable type"
+
+ []
+ let (|NullableTy|_|) g ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, [ tyarg ]) when tyconRefEq g tcref g.system_Nullable_tcref -> ValueSome tyarg
+ | _ -> ValueNone
+
+ let (|StripNullableTy|) g ty =
+ match tryDestNullableTy g ty with
+ | ValueSome tyarg -> tyarg
+ | _ -> ty
+
+ let isLinqExpressionTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> tyconRefEq g g.system_LinqExpression_tcref tcref
+
+ let tryDestLinqExpressionTy g ty =
+ match argsOfAppTy g ty with
+ | [ ty1 ] when isLinqExpressionTy g ty -> Some ty1
+ | _ -> None
+
+ let destLinqExpressionTy g ty =
+ match tryDestLinqExpressionTy g ty with
+ | Some ty -> ty
+ | None -> failwith "destLinqExpressionTy: not an expression type"
+
+ let mkNoneCase (g: TcGlobals) =
+ mkUnionCaseRef g.option_tcr_canon "None"
+
+ let mkSomeCase (g: TcGlobals) =
+ mkUnionCaseRef g.option_tcr_canon "Some"
+
+ let mkSome g ty arg m =
+ mkUnionCaseExpr (mkSomeCase g, [ ty ], [ arg ], m)
+
+ let mkNone g ty m =
+ mkUnionCaseExpr (mkNoneCase g, [ ty ], [], m)
+
+ let mkValueNoneCase (g: TcGlobals) =
+ mkUnionCaseRef g.valueoption_tcr_canon "ValueNone"
+
+ let mkValueSomeCase (g: TcGlobals) =
+ mkUnionCaseRef g.valueoption_tcr_canon "ValueSome"
+
+ let mkAnySomeCase g isStruct =
+ (if isStruct then mkValueSomeCase g else mkSomeCase g)
+
+ let mkValueSome g ty arg m =
+ mkUnionCaseExpr (mkValueSomeCase g, [ ty ], [ arg ], m)
+
+ let mkValueNone g ty m =
+ mkUnionCaseExpr (mkValueNoneCase g, [ ty ], [], m)
+
+ let isFSharpExceptionTy g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tcref.IsFSharpException
+ | _ -> false
diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprConstruction.fsi b/src/Compiler/TypedTree/TypedTreeOps.ExprConstruction.fsi
new file mode 100644
index 0000000000..36942be52f
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.ExprConstruction.fsi
@@ -0,0 +1,774 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.TypedTreeOps
+
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Rational
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Text
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TcGlobals
+
+[]
+module internal ExprConstruction =
+
+ /// An ordering for value definitions, based on stamp
+ val valOrder: IComparer
+
+ /// An ordering for type definitions, based on stamp
+ val tyconOrder: IComparer
+
+ val recdFieldRefOrder: IComparer
+
+ val unionCaseRefOrder: IComparer
+
+ val mkLambdaTy: TcGlobals -> Typars -> TTypes -> TType -> TType
+
+ val mkLambdaArgTy: range -> TTypes -> TType
+
+ /// Get the natural type of a single argument amongst a set of curried arguments
+ val typeOfLambdaArg: range -> Val list -> TType
+
+ /// Get the curried type corresponding to a lambda
+ val mkMultiLambdaTy: TcGlobals -> range -> Val list -> TType -> TType
+
+ /// Module publication, used while compiling fslib.
+ val ensureCcuHasModuleOrNamespaceAtPath: CcuThunk -> Ident list -> CompilationPath -> XmlDoc -> unit
+
+ /// Ignore 'Expr.Link' in an expression
+ val stripExpr: Expr -> Expr
+
+ /// Ignore 'Expr.Link' and 'Expr.DebugPoint' in an expression
+ val stripDebugPoints: Expr -> Expr
+
+ /// Match any 'Expr.Link' and 'Expr.DebugPoint' in an expression, providing the inner expression and a function to rebuild debug points
+ val (|DebugPoints|): Expr -> Expr * (Expr -> Expr)
+
+ val mkCase: DecisionTreeTest * DecisionTree -> DecisionTreeCase
+
+ val isRefTupleExpr: Expr -> bool
+
+ val tryDestRefTupleExpr: Expr -> Exprs
+
+ val primMkMatch: DebugPointAtBinding * range * DecisionTree * DecisionTreeTarget array * range * TType -> Expr
+
+ /// Build decision trees imperatively
+ type MatchBuilder =
+
+ /// Create a new builder
+ new: DebugPointAtBinding * range -> MatchBuilder
+
+ /// Add a new destination target
+ member AddTarget: DecisionTreeTarget -> int
+
+ /// Add a new destination target that is an expression result
+ member AddResultTarget: Expr -> DecisionTree
+
+ /// Finish the targets
+ member CloseTargets: unit -> DecisionTreeTarget list
+
+ /// Build the overall expression
+ member Close: DecisionTree * range * TType -> Expr
+
+ /// Add an if-then-else boolean conditional node into a decision tree
+ val mkBoolSwitch: range -> Expr -> DecisionTree -> DecisionTree -> DecisionTree
+
+ /// Build a conditional expression
+ val primMkCond: DebugPointAtBinding -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ /// Build a conditional expression
+ val mkCond: DebugPointAtBinding -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ /// Build an expression corresponding to the use of a reference to a value
+ val exprForValRef: range -> ValRef -> Expr
+
+ /// Build an expression corresponding to the use of a value
+ /// Note: try to use exprForValRef or the expression returned from mkLocal instead of this.
+ val exprForVal: range -> Val -> Expr
+
+ val mkLocalAux: range -> string -> TType -> ValMutability -> bool -> Val * Expr
+
+ /// Make a new local value and build an expression to reference it
+ val mkLocal: range -> string -> TType -> Val * Expr
+
+ /// Make a new compiler-generated local value and build an expression to reference it
+ val mkCompGenLocal: range -> string -> TType -> Val * Expr
+
+ /// Make a new mutable compiler-generated local value and build an expression to reference it
+ val mkMutableCompGenLocal: range -> string -> TType -> Val * Expr
+
+ /// Build a lambda expression taking multiple values
+ val mkMultiLambda: range -> Val list -> Expr * TType -> Expr
+
+ /// Rebuild a lambda during an expression tree traversal
+ val rebuildLambda: range -> Val option -> Val option -> Val list -> Expr * TType -> Expr
+
+ /// Build a lambda expression taking a single value
+ val mkLambda: range -> Val -> Expr * TType -> Expr
+
+ /// Build a generic lambda expression (type abstraction)
+ val mkTypeLambda: range -> Typars -> Expr * TType -> Expr
+
+ /// Build an type-chose expression, indicating that a local free choice of a type variable
+ val mkTypeChoose: range -> Typars -> Expr -> Expr
+
+ /// Build an object expression
+ val mkObjExpr: TType * Val option * Expr * ObjExprMethod list * (TType * ObjExprMethod list) list * range -> Expr
+
+ /// Build an iterated (curried) lambda expression
+ val mkLambdas: TcGlobals -> range -> Typars -> Val list -> Expr * TType -> Expr
+
+ /// Build an iterated (tupled+curried) lambda expression
+ val mkMultiLambdasCore: TcGlobals -> range -> Val list list -> Expr * TType -> Expr * TType
+
+ /// Build an iterated generic (type abstraction + tupled+curried) lambda expression
+ val mkMultiLambdas: TcGlobals -> range -> Typars -> Val list list -> Expr * TType -> Expr
+
+ /// Build a lambda expression that corresponds to the implementation of a member
+ val mkMemberLambdas:
+ TcGlobals -> range -> Typars -> Val option -> Val option -> Val list list -> Expr * TType -> Expr
+
+ /// Make a binding that binds a function value to a lambda taking multiple arguments
+ val mkMultiLambdaBind:
+ TcGlobals -> Val -> DebugPointAtBinding -> range -> Typars -> Val list list -> Expr * TType -> Binding
+
+ /// Build a user-level value binding
+ val mkBind: DebugPointAtBinding -> Val -> Expr -> Binding
+
+ /// Build a user-level let-binding
+ val mkLetBind: range -> Binding -> Expr -> Expr
+
+ /// Build a user-level value sequence of let bindings
+ val mkLetsBind: range -> Binding list -> Expr -> Expr
+
+ /// Build a user-level value sequence of let bindings
+ val mkLetsFromBindings: range -> Bindings -> Expr -> Expr
+
+ /// Build a user-level let expression
+ val mkLet: DebugPointAtBinding -> range -> Val -> Expr -> Expr -> Expr
+
+ // Compiler generated bindings may involve a user variable.
+ // Compiler generated bindings may give rise to a sequence point if they are part of
+ // an SPAlways expression. Compiler generated bindings can arise from for example, inlining.
+ val mkCompGenBind: Val -> Expr -> Binding
+
+ /// Make a set of bindings that bind compiler generated values to corresponding expressions.
+ /// Compiler-generated bindings do not give rise to a sequence point in debugging.
+ val mkCompGenBinds: Val list -> Exprs -> Bindings
+
+ /// Make a let-expression that locally binds a compiler-generated value to an expression.
+ /// Compiler-generated bindings do not give rise to a sequence point in debugging.
+ val mkCompGenLet: range -> Val -> Expr -> Expr -> Expr
+
+ /// Make a binding that binds a value to an expression in an "invisible" way.
+ /// Invisible bindings are not given a sequence point and should not have side effects.
+ val mkInvisibleBind: Val -> Expr -> Binding
+
+ /// Make a set of bindings that bind values to expressions in an "invisible" way.
+ /// Invisible bindings are not given a sequence point and should not have side effects.
+ val mkInvisibleBinds: Vals -> Exprs -> Bindings
+
+ /// Make a let-expression that locally binds a value to an expression in an "invisible" way.
+ /// Invisible bindings are not given a sequence point and should not have side effects.
+ val mkInvisibleLet: range -> Val -> Expr -> Expr -> Expr
+
+ val mkInvisibleLets: range -> Vals -> Exprs -> Expr -> Expr
+
+ val mkInvisibleLetsFromBindings: range -> Vals -> Exprs -> Expr -> Expr
+
+ /// Make a let-rec expression that locally binds values to expressions where self-reference back to the values is possible.
+ val mkLetRecBinds: range -> Bindings -> Expr -> Expr
+
+ val NormalizeDeclaredTyparsForEquiRecursiveInference: TcGlobals -> Typars -> Typars
+
+ /// GeneralizedType (generalizedTypars, tauTy)
+ ///
+ /// generalizedTypars -- the truly generalized type parameters
+ /// tauTy -- the body of the generalized type. A 'tau' type is one with its type parameters stripped off.
+ type GeneralizedType = GeneralizedType of Typars * TType
+
+ /// Make the right-hand side of a generalized binding, incorporating the generalized generic parameters from the type
+ /// scheme into the right-hand side as type generalizations.
+ val mkGenericBindRhs: TcGlobals -> range -> Typars -> GeneralizedType -> Expr -> Expr
+
+ /// Test if the type parameter is one of those being generalized by a type scheme.
+ val isBeingGeneralized: Typar -> GeneralizedType -> bool
+
+ val mkBool: TcGlobals -> range -> bool -> Expr
+
+ val mkTrue: TcGlobals -> range -> Expr
+
+ val mkFalse: TcGlobals -> range -> Expr
+
+ /// Make the expression corresponding to 'expr1 || expr2'
+ val mkLazyOr: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ /// Make the expression corresponding to 'expr1 && expr2'
+ val mkLazyAnd: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ val mkCoerceExpr: Expr * TType * range * TType -> Expr
+
+ /// Make an expression that is IL assembly code
+ val mkAsmExpr: ILInstr list * TypeInst * Exprs * TTypes * range -> Expr
+
+ /// Make an expression that constructs a union case, e.g. 'Some(expr)'
+ val mkUnionCaseExpr: UnionCaseRef * TypeInst * Exprs * range -> Expr
+
+ /// Make an expression that constructs an exception value
+ val mkExnExpr: TyconRef * Exprs * range -> Expr
+
+ val mkTupleFieldGetViaExprAddr: TupInfo * Expr * TypeInst * int * range -> Expr
+
+ /// Make an expression that gets an item from an anonymous record (via the address of the value if it is a struct)
+ val mkAnonRecdFieldGetViaExprAddr: AnonRecdTypeInfo * Expr * TypeInst * int * range -> Expr
+
+ /// Make an expression that gets an instance field from a record or class (via the address of the value if it is a struct)
+ val mkRecdFieldGetViaExprAddr: Expr * RecdFieldRef * TypeInst * range -> Expr
+
+ /// Make an expression that gets the address of an instance field from a record or class (via the address of the value if it is a struct)
+ val mkRecdFieldGetAddrViaExprAddr: readonly: bool * Expr * RecdFieldRef * TypeInst * range -> Expr
+
+ /// Make an expression that gets the address of a static field in a record or class
+ val mkStaticRecdFieldGetAddr: readonly: bool * RecdFieldRef * TypeInst * range -> Expr
+
+ /// Make an expression that gets a static field from a record or class
+ val mkStaticRecdFieldGet: RecdFieldRef * TypeInst * range -> Expr
+
+ /// Make an expression that sets a static field in a record or class
+ val mkStaticRecdFieldSet: RecdFieldRef * TypeInst * Expr * range -> Expr
+
+ /// Make an expression that gets the address of an element in an array
+ val mkArrayElemAddress:
+ TcGlobals -> readonly: bool * ILReadonly * bool * ILArrayShape * TType * Expr list * range -> Expr
+
+ /// Make an expression that sets an instance the field of a record or class (via the address of the value if it is a struct)
+ val mkRecdFieldSetViaExprAddr: Expr * RecdFieldRef * TypeInst * Expr * range -> Expr
+
+ /// Make an expression that gets the tag of a union value (via the address of the value if it is a struct)
+ val mkUnionCaseTagGetViaExprAddr: Expr * TyconRef * TypeInst * range -> Expr
+
+ /// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions)
+ val mkUnionCaseProof: Expr * UnionCaseRef * TypeInst * range -> Expr
+
+ /// Build a 'TOp.UnionCaseFieldGet' expression for something we've already determined to be a particular union case. For ref-unions,
+ /// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions,
+ /// the input should be the address of the expression.
+ val mkUnionCaseFieldGetProvenViaExprAddr: Expr * UnionCaseRef * TypeInst * int * range -> Expr
+
+ /// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions,
+ /// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions,
+ /// the input should be the address of the expression.
+ val mkUnionCaseFieldGetAddrProvenViaExprAddr: readonly: bool * Expr * UnionCaseRef * TypeInst * int * range -> Expr
+
+ /// Build a 'get' expression for something we've already determined to be a particular union case, but where
+ /// the static type of the input is not yet proven to be that particular union case. This requires a type
+ /// cast to 'prove' the condition.
+ val mkUnionCaseFieldGetUnprovenViaExprAddr: Expr * UnionCaseRef * TypeInst * int * range -> Expr
+
+ val mkUnionCaseFieldSet: Expr * UnionCaseRef * TypeInst * int * Expr * range -> Expr
+
+ /// Make an expression that gets an instance field from an F# exception value
+ val mkExnCaseFieldGet: Expr * TyconRef * int * range -> Expr
+
+ /// Make an expression that sets an instance field in an F# exception value
+ val mkExnCaseFieldSet: Expr * TyconRef * int * Expr * range -> Expr
+
+ val mkDummyLambda: TcGlobals -> Expr * TType -> Expr
+
+ /// Build a 'while' loop expression
+ val mkWhile: TcGlobals -> DebugPointAtWhile * SpecialWhileLoopMarker * Expr * Expr * range -> Expr
+
+ /// Build a 'for' loop expression
+ val mkIntegerForLoop:
+ TcGlobals -> DebugPointAtFor * DebugPointAtInOrTo * Val * Expr * ForLoopStyle * Expr * Expr * range -> Expr
+
+ /// Build a 'try/with' expression
+ val mkTryWith:
+ TcGlobals ->
+ Expr (* filter val *) *
+ Val (* filter expr *) *
+ Expr (* handler val *) *
+ Val (* handler expr *) *
+ Expr *
+ range *
+ TType *
+ DebugPointAtTry *
+ DebugPointAtWith ->
+ Expr
+
+ /// Build a 'try/finally' expression
+ val mkTryFinally: TcGlobals -> Expr * Expr * range * TType * DebugPointAtTry * DebugPointAtFinally -> Expr
+
+ val mkDefault: range * TType -> Expr
+
+ /// Build an expression to mutate a local
+ /// localv <- e
+ val mkValSet: range -> ValRef -> Expr -> Expr
+
+ /// Build an expression to mutate the contents of a local pointer
+ /// *localv_ptr = e
+ val mkAddrSet: range -> ValRef -> Expr -> Expr
+
+ /// Build an expression to dereference a local pointer
+ /// *localv_ptr
+ val mkAddrGet: range -> ValRef -> Expr
+
+ /// Build an expression to take the address of a local
+ /// &localv
+ val mkValAddr: range -> readonly: bool -> ValRef -> Expr
+
+ val valOfBind: Binding -> Val
+
+ /// Get the values for a set of bindings
+ val valsOfBinds: Bindings -> Vals
+
+ val mkDebugPoint: m: range -> expr: Expr -> Expr
+
+ []
+ val (|InnerExprPat|): Expr -> Expr
+
+[]
+module internal TypedTreeCollections =
+
+ /// Mutable data structure mapping Val's to T based on stamp keys
+ []
+ type ValHash<'T> =
+
+ member Values: seq<'T>
+
+ member TryFind: Val -> 'T option
+
+ member Add: Val * 'T -> unit
+
+ static member Create: unit -> ValHash<'T>
+
+ /// Maps Val's to list of T based on stamp keys
+ []
+ type ValMultiMap<'T> =
+
+ member ContainsKey: Val -> bool
+
+ member Find: Val -> 'T list
+
+ member Add: Val * 'T -> ValMultiMap<'T>
+
+ member Remove: Val -> ValMultiMap<'T>
+
+ member Contents: StampMap<'T list>
+
+ static member Empty: ValMultiMap<'T>
+
+ /// Maps TyconRef to list of T based on stamp keys
+ []
+ type TyconRefMultiMap<'T> =
+
+ /// Fetch the entries for the given type definition
+ member Find: TyconRef -> 'T list
+
+ /// Make a new map, containing a new entry for the given type definition
+ member Add: TyconRef * 'T -> TyconRefMultiMap<'T>
+
+ /// The empty map
+ static member Empty: TyconRefMultiMap<'T>
+
+ /// Make a new map, containing a entries for the given type definitions
+ static member OfList: (TyconRef * 'T) list -> TyconRefMultiMap<'T>
+
+[]
+module internal TypeTesters =
+
+ /// Try to create a EntityRef suitable for accessing the given Entity from another assembly
+ val tryRescopeEntity: CcuThunk -> Entity -> EntityRef voption
+
+ /// Try to create a ValRef suitable for accessing the given Val from another assembly
+ val tryRescopeVal: CcuThunk -> Remap -> Val -> ValRef voption
+
+ val actualTyOfRecdField: TyparInstantiation -> RecdField -> TType
+
+ val actualTysOfRecdFields: TyparInstantiation -> RecdField list -> TType list
+
+ val actualTysOfInstanceRecdFields: TyparInstantiation -> TyconRef -> TType list
+
+ val actualTysOfUnionCaseFields: TyparInstantiation -> UnionCaseRef -> TType list
+
+ val actualResultTyOfUnionCase: TypeInst -> UnionCaseRef -> TType
+
+ val recdFieldsOfExnDefRef: TyconRef -> RecdField list
+
+ val recdFieldOfExnDefRefByIdx: TyconRef -> int -> RecdField
+
+ val recdFieldTysOfExnDefRef: TyconRef -> TType list
+
+ val recdFieldTyOfExnDefRefByIdx: TyconRef -> int -> TType
+
+ val actualTyOfRecdFieldForTycon: Tycon -> TypeInst -> RecdField -> TType
+
+ val actualTyOfRecdFieldRef: RecdFieldRef -> TypeInst -> TType
+
+ val actualTyOfUnionFieldRef: UnionCaseRef -> int -> TypeInst -> TType
+
+ val destForallTy: TcGlobals -> TType -> Typars * TType
+
+ val tryDestForallTy: TcGlobals -> TType -> Typars * TType
+
+ val stripFunTy: TcGlobals -> TType -> TType list * TType
+
+ val applyForallTy: TcGlobals -> TType -> TypeInst -> TType
+
+ val reduceIteratedFunTy: TcGlobals -> TType -> 'T list -> TType
+
+ val applyTyArgs: TcGlobals -> TType -> TType list -> TType
+
+ val applyTys: TcGlobals -> TType -> TType list * 'T list -> TType
+
+ val formalApplyTys: TcGlobals -> TType -> 'a list * 'b list -> TType
+
+ val stripFunTyN: TcGlobals -> int -> TType -> TType list * TType
+
+ val tryDestAnyTupleTy: TcGlobals -> TType -> TupInfo * TType list
+
+ val tryDestRefTupleTy: TcGlobals -> TType -> TType list
+
+ type UncurriedArgInfos = (TType * ArgReprInfo) list
+
+ type CurriedArgInfos = (TType * ArgReprInfo) list list
+
+ type TraitWitnessInfos = TraitWitnessInfo list
+
+ val GetTopTauTypeInFSharpForm: TcGlobals -> ArgReprInfo list list -> TType -> range -> CurriedArgInfos * TType
+
+ val destTopForallTy: TcGlobals -> ValReprInfo -> TType -> Typars * TType
+
+ val GetValReprTypeInFSharpForm:
+ TcGlobals -> ValReprInfo -> TType -> range -> Typars * CurriedArgInfos * TType * ArgReprInfo
+
+ val IsCompiledAsStaticProperty: TcGlobals -> Val -> bool
+
+ val IsCompiledAsStaticPropertyWithField: TcGlobals -> Val -> bool
+
+ /// Check if a type definition is one of the artificial type definitions used for array types of different ranks
+ val isArrayTyconRef: TcGlobals -> TyconRef -> bool
+
+ /// Determine the rank of one of the artificial type definitions used for array types
+ val rankOfArrayTyconRef: TcGlobals -> TyconRef -> int
+
+ /// Get the element type of an array type
+ val destArrayTy: TcGlobals -> TType -> TType
+
+ /// Get the element type of an F# list type
+ val destListTy: TcGlobals -> TType -> TType
+
+ val tyconRefEqOpt: TcGlobals -> TyconRef option -> TyconRef -> bool
+
+ /// Determine if a type is the System.String type
+ val isStringTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an F# list type
+ val isListTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is any kind of array type
+ val isArrayTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a single-dimensional array type
+ val isArray1DTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is the F# unit type
+ val isUnitTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is the System.Object type with any nullness qualifier
+ val isObjTyAnyNullness: TcGlobals -> TType -> bool
+
+ /// Determine if a type is the (System.Object | null) type. Allows either nullness if null checking is disabled.
+ val isObjNullTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a strictly non-nullable System.Object type. If nullness checking is disabled, this returns false.
+ val isObjTyWithoutNull: TcGlobals -> TType -> bool
+
+ /// Determine if a type is the System.ValueType type
+ val isValueTypeTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is the System.Void type
+ val isVoidTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a nominal .NET type
+ val isILAppTy: TcGlobals -> TType -> bool
+
+ val isNativePtrTy: TcGlobals -> TType -> bool
+
+ val isByrefTy: TcGlobals -> TType -> bool
+
+ val isInByrefTag: TcGlobals -> TType -> bool
+
+ val isInByrefTy: TcGlobals -> TType -> bool
+
+ val isOutByrefTag: TcGlobals -> TType -> bool
+
+ val isOutByrefTy: TcGlobals -> TType -> bool
+
+#if !NO_TYPEPROVIDERS
+ val extensionInfoOfTy: TcGlobals -> TType -> TyconRepresentation
+#endif
+
+ /// Represents metadata extracted from a nominal type
+ type TypeDefMetadata =
+ | ILTypeMetadata of TILObjectReprData
+ | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata
+#if !NO_TYPEPROVIDERS
+ | ProvidedTypeMetadata of TProvidedTypeInfo
+#endif
+
+ /// Extract metadata from a type definition
+ val metadataOfTycon: Tycon -> TypeDefMetadata
+
+ /// Extract metadata from a type
+ val metadataOfTy: TcGlobals -> TType -> TypeDefMetadata
+
+ val isILReferenceTy: TcGlobals -> TType -> bool
+
+ val isILInterfaceTycon: Tycon -> bool
+
+ /// Get the rank of an array type
+ val rankOfArrayTy: TcGlobals -> TType -> int
+
+ val isFSharpObjModelRefTy: TcGlobals -> TType -> bool
+
+ val isFSharpClassTy: TcGlobals -> TType -> bool
+
+ val isFSharpStructTy: TcGlobals -> TType -> bool
+
+ val isFSharpInterfaceTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a delegate type
+ val isDelegateTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an interface type
+ val isInterfaceTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a delegate type defined in F#
+ val isFSharpDelegateTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a class type
+ val isClassTy: TcGlobals -> TType -> bool
+
+ val isStructOrEnumTyconTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a struct, record or union type
+ val isStructRecordOrUnionTyconTy: TcGlobals -> TType -> bool
+
+ /// Determine if TyconRef is to a struct type
+ val isStructTyconRef: TyconRef -> bool
+
+ /// Determine if a type is a struct type
+ val isStructTy: TcGlobals -> TType -> bool
+
+ /// Check if a type is a measureable type (like int) whose underlying type is a value type.
+ val isMeasureableValueType: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a reference type
+ val isRefTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a function (including generic). Not the same as isFunTy.
+ val isForallFunctionTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an unmanaged type
+ val isUnmanagedTy: TcGlobals -> TType -> bool
+
+ val isInterfaceTycon: Tycon -> bool
+
+ /// Determine if a reference to a type definition is an interface type
+ val isInterfaceTyconRef: TyconRef -> bool
+
+ /// Determine if a type is an enum type
+ val isEnumTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a signed integer type
+ val isSignedIntegerTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an unsigned integer type
+ val isUnsignedIntegerTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an integer type
+ val isIntegerTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a floating point type
+ val isFpTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a decimal type
+ val isDecimalTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a non-decimal numeric type type
+ val isNonDecimalNumericType: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a numeric type type
+ val isNumericType: TcGlobals -> TType -> bool
+
+ val actualReturnTyOfSlotSig: TypeInst -> TypeInst -> SlotSig -> TType option
+
+ val slotSigHasVoidReturnTy: SlotSig -> bool
+
+ val returnTyOfMethod: TcGlobals -> ObjExprMethod -> TType option
+
+ /// Is the type 'abstract' in C#-speak
+ val isAbstractTycon: Tycon -> bool
+
+ val MemberIsExplicitImpl: TcGlobals -> ValMemberInfo -> bool
+
+ val ValIsExplicitImpl: TcGlobals -> Val -> bool
+
+ val ValRefIsExplicitImpl: TcGlobals -> ValRef -> bool
+
+ /// Get the unit of measure for an annotated type
+ val getMeasureOfType: TcGlobals -> TType -> (TyconRef * Measure) option
+
+ // Return true if this type is a nominal type that is an erased provided type
+ val isErasedType: TcGlobals -> TType -> bool
+
+ // Return all components of this type expression that cannot be tested at runtime
+ val getErasedTypes: TcGlobals -> TType -> checkForNullness: bool -> TType list
+
+ /// Determine the underlying type of an enum type (normally int32)
+ val underlyingTypeOfEnumTy: TcGlobals -> TType -> TType
+
+ /// If the input type is an enum type, then convert to its underlying type, otherwise return the input type
+ val normalizeEnumTy: TcGlobals -> TType -> TType
+
+ /// Any delegate type with ResumableCode attribute, or any function returning such a delegate type
+ val isResumableCodeTy: TcGlobals -> TType -> bool
+
+ /// The delegate type ResumableCode, or any function returning this a delegate type
+ val isReturnsResumableCodeTy: TcGlobals -> TType -> bool
+
+ /// Determine if a value is a method implementing an interface dispatch slot using a private method impl
+ val ComputeUseMethodImpl: g: TcGlobals -> v: Val -> bool
+
+ val useGenuineField: Tycon -> RecdField -> bool
+
+ val ComputeFieldName: Tycon -> RecdField -> string
+
+[]
+module internal CommonContainers =
+
+ //-------------------------------------------------------------------------
+ // More common type construction
+ //-------------------------------------------------------------------------
+
+ val destByrefTy: TcGlobals -> TType -> TType
+
+ val destNativePtrTy: TcGlobals -> TType -> TType
+
+ val isByrefTyconRef: TcGlobals -> TyconRef -> bool
+
+ val isRefCellTy: TcGlobals -> TType -> bool
+
+ /// Get the element type of an FSharpRef type
+ val destRefCellTy: TcGlobals -> TType -> TType
+
+ /// Create the FSharpRef type for a given element type
+ val mkRefCellTy: TcGlobals -> TType -> TType
+
+ val StripSelfRefCell: TcGlobals * ValBaseOrThisInfo * TType -> TType
+
+ val isBoolTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is a value option type
+ val isValueOptionTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an option type
+ val isOptionTy: TcGlobals -> TType -> bool
+
+ /// Determine if a type is an Choice type
+ val isChoiceTy: TcGlobals -> TType -> bool
+
+ /// Take apart an option type
+ val destOptionTy: TcGlobals -> TType -> TType
+
+ /// Try to take apart an option type
+ val tryDestOptionTy: TcGlobals -> TType -> TType voption
+
+ /// Try to take apart an option type
+ val destValueOptionTy: TcGlobals -> TType -> TType
+
+ /// Take apart an Choice type
+ val tryDestChoiceTy: TcGlobals -> TType -> int -> TType voption
+
+ /// Try to take apart an Choice type
+ val destChoiceTy: TcGlobals -> TType -> int -> TType
+
+ /// Determine is a type is a System.Nullable type
+ val isNullableTy: TcGlobals -> TType -> bool
+
+ /// Try to take apart a System.Nullable type
+ val tryDestNullableTy: TcGlobals -> TType -> TType voption
+
+ /// Take apart a System.Nullable type
+ val destNullableTy: TcGlobals -> TType -> TType
+
+ /// Determine if a type is a System.Linq.Expression type
+ val isLinqExpressionTy: TcGlobals -> TType -> bool
+
+ /// Take apart a System.Linq.Expression type
+ val destLinqExpressionTy: TcGlobals -> TType -> TType
+
+ /// Try to take apart a System.Linq.Expression type
+ val tryDestLinqExpressionTy: TcGlobals -> TType -> TType option
+
+ val mkLazyTy: TcGlobals -> TType -> TType
+
+ /// Build an PrintFormat type
+ val mkPrintfFormatTy: TcGlobals -> TType -> TType -> TType -> TType -> TType -> TType
+
+ val (|NullableTy|_|): TcGlobals -> TType -> TType voption
+
+ /// An active pattern to transform System.Nullable types to their input, otherwise leave the input unchanged
+ []
+ val (|StripNullableTy|): TcGlobals -> TType -> TType
+
+ /// Matches any byref type, yielding the target type
+ []
+ val (|ByrefTy|_|): TcGlobals -> TType -> TType voption
+
+ val mkListTy: TcGlobals -> TType -> TType
+
+ /// Create the option type for a given element type
+ val mkOptionTy: TcGlobals -> TType -> TType
+
+ /// Create the voption type for a given element type
+ val mkValueOptionTy: TcGlobals -> TType -> TType
+
+ /// Create the Nullable type for a given element type
+ val mkNullableTy: TcGlobals -> TType -> TType
+
+ /// Create the union case 'None' for an option type
+ val mkNoneCase: TcGlobals -> UnionCaseRef
+
+ /// Create the union case 'Some(expr)' for an option type
+ val mkSomeCase: TcGlobals -> UnionCaseRef
+
+ /// Create the struct union case 'ValueNone' for a voption type
+ val mkValueNoneCase: TcGlobals -> UnionCaseRef
+
+ /// Create the struct union case 'ValueSome(expr)' for a voption type
+ val mkValueSomeCase: TcGlobals -> UnionCaseRef
+
+ /// Create the struct union case 'Some' or 'ValueSome(expr)' for a voption type
+ val mkAnySomeCase: TcGlobals -> isStruct: bool -> UnionCaseRef
+
+ val mkSome: TcGlobals -> TType -> Expr -> range -> Expr
+
+ val mkNone: TcGlobals -> TType -> range -> Expr
+
+ /// Create the expression 'ValueSome(expr)'
+ val mkValueSome: TcGlobals -> TType -> Expr -> range -> Expr
+
+ /// Create the struct expression 'ValueNone' for an voption type
+ val mkValueNone: TcGlobals -> TType -> range -> Expr
+
+ /// Indicates if an F# type is the type associated with an F# exception declaration
+ val isFSharpExceptionTy: g: TcGlobals -> ty: TType -> bool
diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs
new file mode 100644
index 0000000000..bdebaf40ff
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs
@@ -0,0 +1,2362 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// TypedTreeOps.ExprOps: address-of operations, expression folding, intrinsic call wrappers, and higher-level expression helpers.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal AddressOps =
+
+ //-------------------------------------------------------------------------
+ // mkExprAddrOfExprAux
+ //-------------------------------------------------------------------------
+
+ type Mutates =
+ | AddressOfOp
+ | DefinitelyMutates
+ | PossiblyMutates
+ | NeverMutates
+
+ exception DefensiveCopyWarning of string * range
+
+ let isRecdOrStructTyconRefAssumedImmutable (g: TcGlobals) (tcref: TyconRef) =
+ (tcref.CanDeref && not (isRecdOrUnionOrStructTyconRefDefinitelyMutable tcref))
+ || tyconRefEq g tcref g.decimal_tcr
+ || tyconRefEq g tcref g.date_tcr
+
+ let isTyconRefReadOnly g (m: range) (tcref: TyconRef) =
+ ignore m
+
+ tcref.CanDeref
+ && if
+ match tcref.TryIsReadOnly with
+ | ValueSome res -> res
+ | _ ->
+ let res =
+ TyconRefHasWellKnownAttribute g WellKnownILAttributes.IsReadOnlyAttribute tcref
+
+ tcref.SetIsReadOnly res
+ res
+ then
+ true
+ else
+ tcref.IsEnumTycon
+
+ let isTyconRefAssumedReadOnly g (tcref: TyconRef) =
+ tcref.CanDeref
+ && match tcref.TryIsAssumedReadOnly with
+ | ValueSome res -> res
+ | _ ->
+ let res = isRecdOrStructTyconRefAssumedImmutable g tcref
+ tcref.SetIsAssumedReadOnly res
+ res
+
+ let isRecdOrStructTyconRefReadOnlyAux g m isInref (tcref: TyconRef) =
+ if isInref && tcref.IsILStructOrEnumTycon then
+ isTyconRefReadOnly g m tcref
+ else
+ isTyconRefReadOnly g m tcref || isTyconRefAssumedReadOnly g tcref
+
+ let isRecdOrStructTyconRefReadOnly g m tcref =
+ isRecdOrStructTyconRefReadOnlyAux g m false tcref
+
+ let isRecdOrStructTyReadOnlyAux (g: TcGlobals) m isInref ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueNone -> false
+ | ValueSome tcref -> isRecdOrStructTyconRefReadOnlyAux g m isInref tcref
+
+ let isRecdOrStructTyReadOnly g m ty =
+ isRecdOrStructTyReadOnlyAux g m false ty
+
+ let CanTakeAddressOf g m isInref ty mut =
+ match mut with
+ | NeverMutates -> true
+ | PossiblyMutates -> isRecdOrStructTyReadOnlyAux g m isInref ty
+ | DefinitelyMutates -> false
+ | AddressOfOp -> true // you can take the address but you might get a (readonly) inref as a result
+
+ // We can take the address of values of struct type even if the value is immutable
+ // under certain conditions
+ // - all instances of the type are known to be immutable; OR
+ // - the operation is known not to mutate
+ //
+ // Note this may be taking the address of a closure field, i.e. a copy
+ // of the original struct, e.g. for
+ // let f () =
+ // let g1 = A.G(1)
+ // (fun () -> g1.x1)
+ //
+ // Note: isRecdOrStructTyReadOnly implies PossiblyMutates or NeverMutates
+ //
+ // We only do this for true local or closure fields because we can't take addresses of immutable static
+ // fields across assemblies.
+ let CanTakeAddressOfImmutableVal (g: TcGlobals) m (vref: ValRef) mut =
+ // We can take the address of values of struct type if the operation doesn't mutate
+ // and the value is a true local or closure field.
+ not vref.IsMutable
+ && not vref.IsMemberOrModuleBinding
+ &&
+ // Note: We can't add this:
+ // || valRefInThisAssembly g.compilingFSharpCore vref
+ // This is because we don't actually guarantee to generate static backing fields for all values like these, e.g. simple constants "let x = 1".
+ // We always generate a static property but there is no field to take an address of
+ CanTakeAddressOf g m false vref.Type mut
+
+ let MustTakeAddressOfVal (g: TcGlobals) (vref: ValRef) =
+ vref.IsMutable
+ &&
+ // We can only take the address of mutable values in the same assembly
+ valRefInThisAssembly g.compilingFSharpCore vref
+
+ let MustTakeAddressOfByrefGet (g: TcGlobals) (vref: ValRef) =
+ isByrefTy g vref.Type && not (isInByrefTy g vref.Type)
+
+ let CanTakeAddressOfByrefGet (g: TcGlobals) (vref: ValRef) mut =
+ isInByrefTy g vref.Type
+ && CanTakeAddressOf g vref.Range true (destByrefTy g vref.Type) mut
+
+ let MustTakeAddressOfRecdField (rfref: RecdField) =
+ // Static mutable fields must be private, hence we don't have to take their address
+ not rfref.IsStatic && rfref.IsMutable
+
+ let MustTakeAddressOfRecdFieldRef (rfref: RecdFieldRef) =
+ MustTakeAddressOfRecdField rfref.RecdField
+
+ let CanTakeAddressOfRecdFieldRef (g: TcGlobals) m (rfref: RecdFieldRef) tinst mut =
+ // We only do this if the field is defined in this assembly because we can't take addresses across assemblies for immutable fields
+ entityRefInThisAssembly g.compilingFSharpCore rfref.TyconRef
+ && not rfref.RecdField.IsMutable
+ && CanTakeAddressOf g m false (actualTyOfRecdFieldRef rfref tinst) mut
+
+ let CanTakeAddressOfUnionFieldRef (g: TcGlobals) m (uref: UnionCaseRef) cidx tinst mut =
+ // We only do this if the field is defined in this assembly because we can't take addresses across assemblies for immutable fields
+ entityRefInThisAssembly g.compilingFSharpCore uref.TyconRef
+ && let rfref = uref.FieldByIndex cidx in
+
+ not rfref.IsMutable
+ && CanTakeAddressOf g m false (actualTyOfUnionFieldRef uref cidx tinst) mut
+
+ let mkDerefAddrExpr mAddrGet expr mExpr exprTy =
+ let v, _ = mkCompGenLocal mAddrGet "byrefReturn" exprTy
+ mkCompGenLet mExpr v expr (mkAddrGet mAddrGet (mkLocalValRef v))
+
+ /// Make the address-of expression and return a wrapper that adds any allocated locals at an appropriate scope.
+ /// Also return a flag that indicates if the resulting pointer is a not a pointer where writing is allowed and will
+ /// have intended effect (i.e. is a readonly pointer and/or a defensive copy).
+ let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut expr addrExprVal m =
+ if mustTakeAddress then
+ let isNativePtr =
+ match addrExprVal with
+ | Some vf -> valRefEq g vf g.addrof2_vref
+ | _ -> false
+
+ // If we are taking the native address using "&&" to get a nativeptr, disallow if it's readonly.
+ let checkTakeNativeAddress readonly =
+ if isNativePtr && readonly then
+ error (Error(FSComp.SR.tastValueMustBeMutable (), m))
+
+ match expr with
+ // LVALUE of "*x" where "x" is byref is just the byref itself
+ | Expr.Op(TOp.LValueOp(LByrefGet, vref), _, [], m) when MustTakeAddressOfByrefGet g vref || CanTakeAddressOfByrefGet g vref mut ->
+ let readonly = not (MustTakeAddressOfByrefGet g vref)
+ let writeonly = isOutByrefTy g vref.Type
+ None, exprForValRef m vref, readonly, writeonly
+
+ // LVALUE of "x" where "x" is mutable local, mutable intra-assembly module/static binding, or operation doesn't mutate.
+ // Note: we can always take the address of mutable intra-assembly values
+ | Expr.Val(vref, _, m) when MustTakeAddressOfVal g vref || CanTakeAddressOfImmutableVal g m vref mut ->
+ let readonly = not (MustTakeAddressOfVal g vref)
+ let writeonly = false
+ checkTakeNativeAddress readonly
+ None, mkValAddr m readonly vref, readonly, writeonly
+
+ // LVALUE of "e.f" where "f" is an instance F# field or record field.
+ | Expr.Op(TOp.ValFieldGet rfref, tinst, [ objExpr ], m) when
+ MustTakeAddressOfRecdFieldRef rfref
+ || CanTakeAddressOfRecdFieldRef g m rfref tinst mut
+ ->
+ let objTy = tyOfExpr g objExpr
+ let takeAddrOfObjExpr = isStructTy g objTy // It seems this will always be false - the address will already have been taken
+
+ let wrap, expra, readonly, writeonly =
+ mkExprAddrOfExprAux g takeAddrOfObjExpr false mut objExpr None m
+
+ let readonly =
+ readonly || isInByrefTy g objTy || not (MustTakeAddressOfRecdFieldRef rfref)
+
+ let writeonly = writeonly || isOutByrefTy g objTy
+ wrap, mkRecdFieldGetAddrViaExprAddr (readonly, expra, rfref, tinst, m), readonly, writeonly
+
+ // LVALUE of "f" where "f" is a static F# field.
+ | Expr.Op(TOp.ValFieldGet rfref, tinst, [], m) when
+ MustTakeAddressOfRecdFieldRef rfref
+ || CanTakeAddressOfRecdFieldRef g m rfref tinst mut
+ ->
+ let readonly = not (MustTakeAddressOfRecdFieldRef rfref)
+ let writeonly = false
+ None, mkStaticRecdFieldGetAddr (readonly, rfref, tinst, m), readonly, writeonly
+
+ // LVALUE of "e.f" where "f" is an F# union field.
+ | Expr.Op(TOp.UnionCaseFieldGet(uref, cidx), tinst, [ objExpr ], m) when
+ MustTakeAddressOfRecdField(uref.FieldByIndex cidx)
+ || CanTakeAddressOfUnionFieldRef g m uref cidx tinst mut
+ ->
+ let objTy = tyOfExpr g objExpr
+ let takeAddrOfObjExpr = isStructTy g objTy // It seems this will always be false - the address will already have been taken
+
+ let wrap, expra, readonly, writeonly =
+ mkExprAddrOfExprAux g takeAddrOfObjExpr false mut objExpr None m
+
+ let readonly =
+ readonly
+ || isInByrefTy g objTy
+ || not (MustTakeAddressOfRecdField(uref.FieldByIndex cidx))
+
+ let writeonly = writeonly || isOutByrefTy g objTy
+ wrap, mkUnionCaseFieldGetAddrProvenViaExprAddr (readonly, expra, uref, tinst, cidx, m), readonly, writeonly
+
+ // LVALUE of "f" where "f" is a .NET static field.
+ | Expr.Op(TOp.ILAsm([ I_ldsfld(_vol, fspec) ], [ ty2 ]), tinst, [], m) ->
+ let readonly = false // we never consider taking the address of a .NET static field to give an inref pointer
+ let writeonly = false
+ None, Expr.Op(TOp.ILAsm([ I_ldsflda fspec ], [ mkByrefTy g ty2 ]), tinst, [], m), readonly, writeonly
+
+ // LVALUE of "e.f" where "f" is a .NET instance field.
+ | Expr.Op(TOp.ILAsm([ I_ldfld(_align, _vol, fspec) ], [ ty2 ]), tinst, [ objExpr ], m) ->
+ let objTy = tyOfExpr g objExpr
+ let takeAddrOfObjExpr = isStructTy g objTy // It seems this will always be false - the address will already have been taken
+ // we never consider taking the address of an .NET instance field to give an inref pointer, unless the object pointer is an inref pointer
+ let wrap, expra, readonly, writeonly =
+ mkExprAddrOfExprAux g takeAddrOfObjExpr false mut objExpr None m
+
+ let readonly = readonly || isInByrefTy g objTy
+ let writeonly = writeonly || isOutByrefTy g objTy
+ wrap, Expr.Op(TOp.ILAsm([ I_ldflda fspec ], [ mkByrefTyWithFlag g readonly ty2 ]), tinst, [ expra ], m), readonly, writeonly
+
+ // LVALUE of "e.[n]" where e is an array of structs
+ | Expr.App(Expr.Val(vf, _, _), _, [ elemTy ], [ aexpr; nexpr ], _) when (valRefEq g vf g.array_get_vref) ->
+
+ let readonly = false // array address is never forced to be readonly
+ let writeonly = false
+ let shape = ILArrayShape.SingleDimensional
+
+ let ilInstrReadOnlyAnnotation =
+ if isTyparTy g elemTy && useReadonlyForGenericArrayAddress then
+ ReadonlyAddress
+ else
+ NormalAddress
+
+ None,
+ mkArrayElemAddress g (readonly, ilInstrReadOnlyAnnotation, isNativePtr, shape, elemTy, [ aexpr; nexpr ], m),
+ readonly,
+ writeonly
+
+ // LVALUE of "e.[n1, n2]", "e.[n1, n2, n3]", "e.[n1, n2, n3, n4]" where e is an array of structs
+ | Expr.App(Expr.Val(vref, _, _), _, [ elemTy ], aexpr :: args, _) when
+ (valRefEq g vref g.array2D_get_vref
+ || valRefEq g vref g.array3D_get_vref
+ || valRefEq g vref g.array4D_get_vref)
+ ->
+
+ let readonly = false // array address is never forced to be readonly
+ let writeonly = false
+ let shape = ILArrayShape.FromRank args.Length
+
+ let ilInstrReadOnlyAnnotation =
+ if isTyparTy g elemTy && useReadonlyForGenericArrayAddress then
+ ReadonlyAddress
+ else
+ NormalAddress
+
+ None,
+ mkArrayElemAddress g (readonly, ilInstrReadOnlyAnnotation, isNativePtr, shape, elemTy, (aexpr :: args), m),
+ readonly,
+ writeonly
+
+ // LVALUE: "&meth(args)" where meth has a byref or inref return. Includes "&span.[idx]".
+ | Expr.Let(TBind(vref, e, _), Expr.Op(TOp.LValueOp(LByrefGet, vref2), _, _, _), _, _) when
+ (valRefEq g (mkLocalValRef vref) vref2)
+ && (MustTakeAddressOfByrefGet g vref2 || CanTakeAddressOfByrefGet g vref2 mut)
+ ->
+ let ty = tyOfExpr g e
+ let readonly = isInByrefTy g ty
+ let writeonly = isOutByrefTy g ty
+ None, e, readonly, writeonly
+
+ // Give a nice error message for address-of-byref
+ | Expr.Val(vref, _, m) when isByrefTy g vref.Type -> error (Error(FSComp.SR.tastUnexpectedByRef (), m))
+
+ // Give a nice error message for DefinitelyMutates of address-of on mutable values in other assemblies
+ | Expr.Val(vref, _, m) when (mut = DefinitelyMutates || mut = AddressOfOp) && vref.IsMutable ->
+ error (Error(FSComp.SR.tastInvalidAddressOfMutableAcrossAssemblyBoundary (), m))
+
+ // Give a nice error message for AddressOfOp on immutable values
+ | Expr.Val _ when mut = AddressOfOp -> error (Error(FSComp.SR.tastValueMustBeLocal (), m))
+
+ // Give a nice error message for mutating a value we can't take the address of
+ | Expr.Val _ when mut = DefinitelyMutates -> error (Error(FSComp.SR.tastValueMustBeMutable (), m))
+
+ | _ ->
+ let ty = tyOfExpr g expr
+
+ if isStructTy g ty then
+ match mut with
+ | NeverMutates
+ | AddressOfOp -> ()
+ | DefinitelyMutates ->
+ // Give a nice error message for mutating something we can't take the address of
+ errorR (Error(FSComp.SR.tastInvalidMutationOfConstant (), m))
+ | PossiblyMutates ->
+ // Warn on defensive copy of something we can't take the address of
+ warning (DefensiveCopyWarning(FSComp.SR.tastValueHasBeenCopied (), m))
+
+ match mut with
+ | NeverMutates
+ | DefinitelyMutates
+ | PossiblyMutates -> ()
+ | AddressOfOp ->
+ // we get an inref
+ errorR (Error(FSComp.SR.tastCantTakeAddressOfExpression (), m))
+
+ // Take a defensive copy
+ let tmp, _ =
+ match mut with
+ | NeverMutates -> mkCompGenLocal m WellKnownNames.CopyOfStruct ty
+ | _ -> mkMutableCompGenLocal m WellKnownNames.CopyOfStruct ty
+
+ // This local is special in that it ignore byref scoping rules.
+ tmp.SetIgnoresByrefScope()
+
+ let readonly = true
+ let writeonly = false
+ Some(tmp, expr), (mkValAddr m readonly (mkLocalValRef tmp)), readonly, writeonly
+ else
+ None, expr, false, false
+
+ let mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m =
+ let optBind, addre, readonly, writeonly =
+ mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m
+
+ match optBind with
+ | None -> id, addre, readonly, writeonly
+ | Some(tmp, rval) -> (fun x -> mkCompGenLet m tmp rval x), addre, readonly, writeonly
+
+ let mkTupleFieldGet g (tupInfo, e, tinst, i, m) =
+ let wrap, eR, _readonly, _writeonly =
+ mkExprAddrOfExpr g (evalTupInfoIsStruct tupInfo) false NeverMutates e None m
+
+ wrap (mkTupleFieldGetViaExprAddr (tupInfo, eR, tinst, i, m))
+
+ let mkAnonRecdFieldGet g (anonInfo: AnonRecdTypeInfo, e, tinst, i, m) =
+ let wrap, eR, _readonly, _writeonly =
+ mkExprAddrOfExpr g (evalAnonInfoIsStruct anonInfo) false NeverMutates e None m
+
+ wrap (mkAnonRecdFieldGetViaExprAddr (anonInfo, eR, tinst, i, m))
+
+ let mkRecdFieldGet g (e, fref: RecdFieldRef, tinst, m) =
+ assert (not (isByrefTy g (tyOfExpr g e)))
+
+ let wrap, eR, _readonly, _writeonly =
+ mkExprAddrOfExpr g fref.Tycon.IsStructOrEnumTycon false NeverMutates e None m
+
+ wrap (mkRecdFieldGetViaExprAddr (eR, fref, tinst, m))
+
+ let mkUnionCaseFieldGetUnproven g (e, cref: UnionCaseRef, tinst, j, m) =
+ assert (not (isByrefTy g (tyOfExpr g e)))
+
+ let wrap, eR, _readonly, _writeonly =
+ mkExprAddrOfExpr g cref.Tycon.IsStructOrEnumTycon false NeverMutates e None m
+
+ wrap (mkUnionCaseFieldGetUnprovenViaExprAddr (eR, cref, tinst, j, m))
+
+[]
+module internal ExprFolding =
+
+ //---------------------------------------------------------------------------
+ // Compute fixups for letrec's.
+ //
+ // Generate an assignment expression that will fixup the recursion
+ // amongst the vals on the r.h.s. of a letrec. The returned expressions
+ // include disorderly constructs such as expressions/statements
+ // to set closure environments and non-mutable fields. These are only ever
+ // generated by the backend code-generator when processing a "letrec"
+ // construct.
+ //
+ // [self] is the top level value that is being fixed
+ // [exprToFix] is the r.h.s. expression
+ // [rvs] is the set of recursive vals being bound.
+ // [acc] accumulates the expression right-to-left.
+ //
+ // Traversal of the r.h.s. term must happen back-to-front to get the
+ // uniq's for the lambdas correct in the very rare case where the same lambda
+ // somehow appears twice on the right.
+ //---------------------------------------------------------------------------
+
+ let rec IterateRecursiveFixups g (selfv: Val option) rvs (access: Expr, set) exprToFix =
+ let exprToFix = stripExpr exprToFix
+
+ match exprToFix with
+ | Expr.Const _ -> ()
+ | Expr.Op(TOp.Tuple tupInfo, argTys, args, m) when not (evalTupInfoIsStruct tupInfo) ->
+ args
+ |> List.iteri (fun n ->
+ IterateRecursiveFixups
+ g
+ None
+ rvs
+ (mkTupleFieldGet g (tupInfo, access, argTys, n, m),
+ (fun e ->
+ // NICE: it would be better to do this check in the type checker
+ errorR (Error(FSComp.SR.tastRecursiveValuesMayNotBeInConstructionOfTuple (), m))
+ e)))
+
+ | Expr.Op(TOp.UnionCase c, tinst, args, m) ->
+ args
+ |> List.iteri (fun n ->
+ IterateRecursiveFixups
+ g
+ None
+ rvs
+ (mkUnionCaseFieldGetUnprovenViaExprAddr (access, c, tinst, n, m),
+ (fun e ->
+ // NICE: it would be better to do this check in the type checker
+ let tcref = c.TyconRef
+
+ if
+ not (c.FieldByIndex n).IsMutable
+ && not (entityRefInThisAssembly g.compilingFSharpCore tcref)
+ then
+ errorR (Error(FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType (tcref.LogicalName), m))
+
+ mkUnionCaseFieldSet (access, c, tinst, n, e, m))))
+
+ | Expr.Op(TOp.Recd(_, tcref), tinst, args, m) ->
+ (tcref.TrueInstanceFieldsAsRefList, args)
+ ||> List.iter2 (fun fref arg ->
+ let fspec = fref.RecdField
+
+ IterateRecursiveFixups
+ g
+ None
+ rvs
+ (mkRecdFieldGetViaExprAddr (access, fref, tinst, m),
+ (fun e ->
+ // NICE: it would be better to do this check in the type checker
+ if not fspec.IsMutable && not (entityRefInThisAssembly g.compilingFSharpCore tcref) then
+ errorR (
+ Error(
+ FSComp.SR.tastRecursiveValuesMayNotBeAssignedToNonMutableField (
+ fspec.rfield_id.idText,
+ tcref.LogicalName
+ ),
+ m
+ )
+ )
+
+ mkRecdFieldSetViaExprAddr (access, fref, tinst, e, m)))
+ arg)
+ | Expr.Val _
+ | Expr.Lambda _
+ | Expr.Obj _
+ | Expr.TyChoose _
+ | Expr.TyLambda _ -> rvs selfv access set exprToFix
+ | _ -> ()
+
+ //--------------------------------------------------------------------------
+ // computations on constraints
+ //--------------------------------------------------------------------------
+
+ let JoinTyparStaticReq r1 r2 =
+ match r1, r2 with
+ | TyparStaticReq.None, r
+ | r, TyparStaticReq.None -> r
+ | TyparStaticReq.HeadType, r
+ | r, TyparStaticReq.HeadType -> r
+
+ //-------------------------------------------------------------------------
+ // ExprFolder - fold steps
+ //-------------------------------------------------------------------------
+
+ type ExprFolder<'State> =
+ {
+ exprIntercept (* recurseF *) :
+ ('State -> Expr -> 'State) -> (* noInterceptF *) ('State -> Expr -> 'State) -> 'State -> Expr -> 'State
+ // the bool is 'bound in dtree'
+ valBindingSiteIntercept: 'State -> bool * Val -> 'State
+ // these values are always bound to these expressions. bool indicates 'recursively'
+ nonRecBindingsIntercept: 'State -> Binding -> 'State
+ recBindingsIntercept: 'State -> Bindings -> 'State
+ dtreeIntercept: 'State -> DecisionTree -> 'State
+ targetIntercept (* recurseF *) : ('State -> Expr -> 'State) -> 'State -> DecisionTreeTarget -> 'State option
+ tmethodIntercept (* recurseF *) : ('State -> Expr -> 'State) -> 'State -> ObjExprMethod -> 'State option
+ }
+
+ let ExprFolder0 =
+ {
+ exprIntercept = (fun _recurseF noInterceptF z x -> noInterceptF z x)
+ valBindingSiteIntercept = (fun z _b -> z)
+ nonRecBindingsIntercept = (fun z _bs -> z)
+ recBindingsIntercept = (fun z _bs -> z)
+ dtreeIntercept = (fun z _dt -> z)
+ targetIntercept = (fun _exprF _z _x -> None)
+ tmethodIntercept = (fun _exprF _z _x -> None)
+ }
+
+ //-------------------------------------------------------------------------
+ // FoldExpr
+ //-------------------------------------------------------------------------
+
+ /// Adapted from usage info folding.
+ /// Collecting from exprs at moment.
+ /// To collect ids etc some additional folding needed, over formals etc.
+ type ExprFolders<'State>(folders: ExprFolder<'State>) =
+ let mutable exprFClosure = Unchecked.defaultof<'State -> Expr -> 'State> // prevent reallocation of closure
+ let mutable exprNoInterceptFClosure = Unchecked.defaultof<'State -> Expr -> 'State> // prevent reallocation of closure
+ let stackGuard = StackGuard("FoldExprStackGuardDepth")
+
+ let rec exprsF z xs = List.fold exprFClosure z xs
+
+ and exprF (z: 'State) (x: Expr) =
+ stackGuard.Guard
+ <| fun () -> folders.exprIntercept exprFClosure exprNoInterceptFClosure z x
+
+ and exprNoInterceptF (z: 'State) (x: Expr) =
+ match x with
+
+ | Expr.Const _ -> z
+
+ | Expr.Val _ -> z
+
+ | LinearOpExpr(_op, _tyargs, argsHead, argLast, _m) ->
+ let z = exprsF z argsHead
+ // tailcall
+ exprF z argLast
+
+ | Expr.Op(_c, _tyargs, args, _) -> exprsF z args
+
+ | Expr.Sequential(x0, x1, _dir, _) ->
+ let z = exprF z x0
+ exprF z x1
+
+ | Expr.Lambda(_lambdaId, _ctorThisValOpt, _baseValOpt, _argvs, body, _m, _rty) -> exprF z body
+
+ | Expr.TyLambda(_lambdaId, _tps, body, _m, _rty) -> exprF z body
+
+ | Expr.TyChoose(_, body, _) -> exprF z body
+
+ | Expr.App(f, _fty, _tys, argTys, _) ->
+ let z = exprF z f
+ exprsF z argTys
+
+ | Expr.LetRec(binds, body, _, _) ->
+ let z = valBindsF false z binds
+ exprF z body
+
+ | Expr.Let(bind, body, _, _) ->
+ let z = valBindF false z bind
+ exprF z body
+
+ | Expr.Link rX -> exprF z rX.Value
+
+ | Expr.DebugPoint(_, innerExpr) -> exprF z innerExpr
+
+ | Expr.Match(_spBind, _exprm, dtree, targets, _m, _ty) ->
+ let z = dtreeF z dtree
+ let z = Array.fold targetF z targets[0 .. targets.Length - 2]
+ // tailcall
+ targetF z targets[targets.Length - 1]
+
+ | Expr.Quote(e, dataCell, _, _, _) ->
+ let z = exprF z e
+
+ match dataCell.Value with
+ | None -> z
+ | Some((_typeDefs, _argTypes, argExprs, _), _) -> exprsF z argExprs
+
+ | Expr.Obj(_n, _typ, _basev, basecall, overrides, iimpls, _m) ->
+ let z = exprF z basecall
+ let z = List.fold tmethodF z overrides
+ List.fold (foldOn snd (List.fold tmethodF)) z iimpls
+
+ | Expr.StaticOptimization(_tcs, csx, x, _) -> exprsF z [ csx; x ]
+
+ | Expr.WitnessArg(_witnessInfo, _m) -> z
+
+ and valBindF dtree z bind =
+ let z = folders.nonRecBindingsIntercept z bind
+ bindF dtree z bind
+
+ and valBindsF dtree z binds =
+ let z = folders.recBindingsIntercept z binds
+ List.fold (bindF dtree) z binds
+
+ and bindF dtree z (bind: Binding) =
+ let z = folders.valBindingSiteIntercept z (dtree, bind.Var)
+ exprF z bind.Expr
+
+ and dtreeF z dtree =
+ let z = folders.dtreeIntercept z dtree
+
+ match dtree with
+ | TDBind(bind, rest) ->
+ let z = valBindF true z bind
+ dtreeF z rest
+ | TDSuccess(args, _) -> exprsF z args
+ | TDSwitch(test, dcases, dflt, _) ->
+ let z = exprF z test
+ let z = List.fold dcaseF z dcases
+ let z = Option.fold dtreeF z dflt
+ z
+
+ and dcaseF z =
+ function
+ | TCase(_, dtree) -> dtreeF z dtree (* not collecting from test *)
+
+ and targetF z x =
+ match folders.targetIntercept exprFClosure z x with
+ | Some z -> z // intercepted
+ | None -> // structurally recurse
+ let (TTarget(_, body, _)) = x
+ exprF z body
+
+ and tmethodF z x =
+ match folders.tmethodIntercept exprFClosure z x with
+ | Some z -> z // intercepted
+ | None -> // structurally recurse
+ let (TObjExprMethod(_, _, _, _, e, _)) = x
+ exprF z e
+
+ and mdefF z x =
+ match x with
+ | TMDefRec(_, _, _, mbinds, _) ->
+ // REVIEW: also iterate the abstract slot vspecs hidden in the _vslots field in the tycons
+ let z = List.fold mbindF z mbinds
+ z
+ | TMDefLet(bind, _) -> valBindF false z bind
+ | TMDefOpens _ -> z
+ | TMDefDo(e, _) -> exprF z e
+ | TMDefs defs -> List.fold mdefF z defs
+
+ and mbindF z x =
+ match x with
+ | ModuleOrNamespaceBinding.Binding b -> valBindF false z b
+ | ModuleOrNamespaceBinding.Module(_, def) -> mdefF z def
+
+ let implF z (x: CheckedImplFile) = mdefF z x.Contents
+
+ do exprFClosure <- exprF // allocate one instance of this closure
+ do exprNoInterceptFClosure <- exprNoInterceptF // allocate one instance of this closure
+
+ member x.FoldExpr = exprF
+
+ member x.FoldImplFile = implF
+
+ let FoldExpr folders state expr =
+ ExprFolders(folders).FoldExpr state expr
+
+ let FoldImplFile folders state implFile =
+ ExprFolders(folders).FoldImplFile state implFile
+
+#if DEBUG
+ //-------------------------------------------------------------------------
+ // ExprStats
+ //-------------------------------------------------------------------------
+
+ let ExprStats x =
+ let mutable count = 0
+
+ let folders =
+ { ExprFolder0 with
+ exprIntercept =
+ (fun _ noInterceptF z x ->
+ (count <- count + 1
+ noInterceptF z x))
+ }
+
+ let () = FoldExpr folders () x
+ string count + " TExpr nodes"
+#endif
+
+[]
+module internal Makers =
+
+ //-------------------------------------------------------------------------
+ // Make expressions
+ //-------------------------------------------------------------------------
+
+ let mkString (g: TcGlobals) m n =
+ Expr.Const(Const.String n, m, g.string_ty)
+
+ let mkByte (g: TcGlobals) m b = Expr.Const(Const.Byte b, m, g.byte_ty)
+
+ let mkUInt16 (g: TcGlobals) m b =
+ Expr.Const(Const.UInt16 b, m, g.uint16_ty)
+
+ let mkUnit (g: TcGlobals) m = Expr.Const(Const.Unit, m, g.unit_ty)
+
+ let mkInt32 (g: TcGlobals) m n =
+ Expr.Const(Const.Int32 n, m, g.int32_ty)
+
+ let mkInt g m n = mkInt32 g m n
+
+ let mkZero g m = mkInt g m 0
+
+ let mkOne g m = mkInt g m 1
+
+ let mkTwo g m = mkInt g m 2
+
+ let mkMinusOne g m = mkInt g m -1
+
+ let mkTypedZero g m ty =
+ if typeEquivAux EraseMeasures g ty g.int32_ty then
+ Expr.Const(Const.Int32 0, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.int64_ty then
+ Expr.Const(Const.Int64 0L, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.uint64_ty then
+ Expr.Const(Const.UInt64 0UL, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.uint32_ty then
+ Expr.Const(Const.UInt32 0u, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.nativeint_ty then
+ Expr.Const(Const.IntPtr 0L, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.unativeint_ty then
+ Expr.Const(Const.UIntPtr 0UL, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.int16_ty then
+ Expr.Const(Const.Int16 0s, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.uint16_ty then
+ Expr.Const(Const.UInt16 0us, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.sbyte_ty then
+ Expr.Const(Const.SByte 0y, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.byte_ty then
+ Expr.Const(Const.Byte 0uy, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.char_ty then
+ Expr.Const(Const.Char '\000', m, ty)
+ elif typeEquivAux EraseMeasures g ty g.float32_ty then
+ Expr.Const(Const.Single 0.0f, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.float_ty then
+ Expr.Const(Const.Double 0.0, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.decimal_ty then
+ Expr.Const(Const.Decimal 0m, m, ty)
+ else
+ error (InternalError($"Unrecognized numeric type '{ty}'.", m))
+
+ let mkTypedOne g m ty =
+ if typeEquivAux EraseMeasures g ty g.int32_ty then
+ Expr.Const(Const.Int32 1, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.int64_ty then
+ Expr.Const(Const.Int64 1L, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.uint64_ty then
+ Expr.Const(Const.UInt64 1UL, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.uint32_ty then
+ Expr.Const(Const.UInt32 1u, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.nativeint_ty then
+ Expr.Const(Const.IntPtr 1L, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.unativeint_ty then
+ Expr.Const(Const.UIntPtr 1UL, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.int16_ty then
+ Expr.Const(Const.Int16 1s, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.uint16_ty then
+ Expr.Const(Const.UInt16 1us, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.sbyte_ty then
+ Expr.Const(Const.SByte 1y, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.byte_ty then
+ Expr.Const(Const.Byte 1uy, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.char_ty then
+ Expr.Const(Const.Char '\001', m, ty)
+ elif typeEquivAux EraseMeasures g ty g.float32_ty then
+ Expr.Const(Const.Single 1.0f, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.float_ty then
+ Expr.Const(Const.Double 1.0, m, ty)
+ elif typeEquivAux EraseMeasures g ty g.decimal_ty then
+ Expr.Const(Const.Decimal 1m, m, ty)
+ else
+ error (InternalError($"Unrecognized numeric type '{ty}'.", m))
+
+ let mkRefCellContentsRef (g: TcGlobals) =
+ mkRecdFieldRef g.refcell_tcr_canon "contents"
+
+ let mkSequential m e1 e2 = Expr.Sequential(e1, e2, NormalSeq, m)
+
+ let mkCompGenSequential m stmt expr = mkSequential m stmt expr
+
+ let mkThenDoSequential m expr stmt =
+ Expr.Sequential(expr, stmt, ThenDoSeq, m)
+
+ let mkCompGenThenDoSequential m expr stmt = mkThenDoSequential m expr stmt
+
+ let rec mkSequentials g m es =
+ match es with
+ | [ e ] -> e
+ | e :: es -> mkSequential m e (mkSequentials g m es)
+ | [] -> mkUnit g m
+
+ let mkGetArg0 m ty =
+ mkAsmExpr ([ mkLdarg0 ], [], [], [ ty ], m)
+
+ //-------------------------------------------------------------------------
+ // Tuples...
+ //-------------------------------------------------------------------------
+
+ let mkAnyTupled g m tupInfo es tys =
+ match es with
+ | [] -> mkUnit g m
+ | [ e ] -> e
+ | _ -> Expr.Op(TOp.Tuple tupInfo, tys, es, m)
+
+ let mkRefTupled g m es tys = mkAnyTupled g m tupInfoRef es tys
+
+ let mkRefTupledNoTypes g m args =
+ mkRefTupled g m args (List.map (tyOfExpr g) args)
+
+ let mkRefTupledVars g m vs =
+ mkRefTupled g m (List.map (exprForVal m) vs) (typesOfVals vs)
+
+ //--------------------------------------------------------------------------
+ // Permute expressions
+ //--------------------------------------------------------------------------
+
+ let inversePerm (sigma: int array) =
+ let n = sigma.Length
+ let invSigma = Array.create n -1
+
+ for i = 0 to n - 1 do
+ let sigma_i = sigma[i]
+ // assert( invSigma.[sigma_i] = -1 )
+ invSigma[sigma_i] <- i
+
+ invSigma
+
+ let permute (sigma: int[]) (data: 'T[]) =
+ let n = sigma.Length
+ let invSigma = inversePerm sigma
+ Array.init n (fun i -> data[invSigma[i]])
+
+ let rec existsR a b pred =
+ if a <= b then pred a || existsR (a + 1) b pred else false
+
+ // Given a permutation for record fields, work out the highest entry that we must lift out
+ // of a record initialization. Lift out xi if xi goes to position that will be preceded by an expr with an effect
+ // that originally followed xi. If one entry gets lifted then everything before it also gets lifted.
+ let liftAllBefore sigma =
+ let invSigma = inversePerm sigma
+
+ let lifted =
+ [
+ for i in 0 .. sigma.Length - 1 do
+ let iR = sigma[i]
+
+ if existsR 0 (iR - 1) (fun jR -> invSigma[jR] > i) then
+ yield i
+ ]
+
+ if lifted.IsEmpty then 0 else List.max lifted + 1
+
+ /// Put record field assignments in order.
+ //
+ let permuteExprList (sigma: int[]) (exprs: Expr list) (ty: TType list) (names: string list) =
+ let ty, names = (Array.ofList ty, Array.ofList names)
+
+ let liftLim = liftAllBefore sigma
+
+ let rewrite rbinds (i, expri: Expr) =
+ if i < liftLim then
+ let tmpvi, tmpei = mkCompGenLocal expri.Range names[i] ty[i]
+ let bindi = mkCompGenBind tmpvi expri
+ tmpei, bindi :: rbinds
+ else
+ expri, rbinds
+
+ let newExprs, reversedBinds = List.mapFold rewrite [] (exprs |> List.indexed)
+ let binds = List.rev reversedBinds
+ let reorderedExprs = permute sigma (Array.ofList newExprs)
+ binds, Array.toList reorderedExprs
+
+ /// Evaluate the expressions in the original order, but build a record with the results in field order
+ /// Note some fields may be static. If this were not the case we could just use
+ /// let sigma = Array.map #Index ()
+ /// However the presence of static fields means .Index may index into a non-compact set of instance field indexes.
+ /// We still need to sort by index.
+ let mkRecordExpr g (lnk, tcref, tinst, unsortedRecdFields: RecdFieldRef list, unsortedFieldExprs, m) =
+ // Remove any abbreviations
+ let tcref, tinst = destAppTy g (mkWoNullAppTy tcref tinst)
+
+ let sortedRecdFields =
+ unsortedRecdFields
+ |> List.indexed
+ |> Array.ofList
+ |> Array.sortBy (fun (_, r) -> r.Index)
+
+ let sigma = Array.create sortedRecdFields.Length -1
+
+ sortedRecdFields
+ |> Array.iteri (fun sortedIdx (unsortedIdx, _) ->
+ if sigma[unsortedIdx] <> -1 then
+ error (InternalError("bad permutation", m))
+
+ sigma[unsortedIdx] <- sortedIdx)
+
+ let unsortedArgTys =
+ unsortedRecdFields |> List.map (fun rfref -> actualTyOfRecdFieldRef rfref tinst)
+
+ let unsortedArgNames = unsortedRecdFields |> List.map (fun rfref -> rfref.FieldName)
+
+ let unsortedArgBinds, sortedArgExprs =
+ permuteExprList sigma unsortedFieldExprs unsortedArgTys unsortedArgNames
+
+ let core = Expr.Op(TOp.Recd(lnk, tcref), tinst, sortedArgExprs, m)
+ mkLetsBind m unsortedArgBinds core
+
+ let mkAnonRecd (_g: TcGlobals) m (anonInfo: AnonRecdTypeInfo) (unsortedIds: Ident[]) (unsortedFieldExprs: Expr list) unsortedArgTys =
+ let sortedRecdFields =
+ unsortedFieldExprs
+ |> List.indexed
+ |> Array.ofList
+ |> Array.sortBy (fun (i, _) -> unsortedIds[i].idText)
+
+ let sortedArgTys =
+ unsortedArgTys
+ |> List.indexed
+ |> List.sortBy (fun (i, _) -> unsortedIds[i].idText)
+ |> List.map snd
+
+ let sigma = Array.create sortedRecdFields.Length -1
+
+ sortedRecdFields
+ |> Array.iteri (fun sortedIdx (unsortedIdx, _) ->
+ if sigma[unsortedIdx] <> -1 then
+ error (InternalError("bad permutation", m))
+
+ sigma[unsortedIdx] <- sortedIdx)
+
+ let unsortedArgNames = unsortedIds |> Array.toList |> List.map (fun id -> id.idText)
+
+ let unsortedArgBinds, sortedArgExprs =
+ permuteExprList sigma unsortedFieldExprs unsortedArgTys unsortedArgNames
+
+ let core = Expr.Op(TOp.AnonRecd anonInfo, sortedArgTys, sortedArgExprs, m)
+ mkLetsBind m unsortedArgBinds core
+
+ //-------------------------------------------------------------------------
+ // List builders
+ //-------------------------------------------------------------------------
+
+ let mkRefCell g m ty e =
+ mkRecordExpr g (RecdExpr, g.refcell_tcr_canon, [ ty ], [ mkRefCellContentsRef g ], [ e ], m)
+
+ let mkRefCellGet g m ty e =
+ mkRecdFieldGetViaExprAddr (e, mkRefCellContentsRef g, [ ty ], m)
+
+ let mkRefCellSet g m ty e1 e2 =
+ mkRecdFieldSetViaExprAddr (e1, mkRefCellContentsRef g, [ ty ], e2, m)
+
+ let mkNil (g: TcGlobals) m ty =
+ mkUnionCaseExpr (g.nil_ucref, [ ty ], [], m)
+
+ let mkCons (g: TcGlobals) ty h t =
+ mkUnionCaseExpr (g.cons_ucref, [ ty ], [ h; t ], unionRanges h.Range t.Range)
+
+ let mkArray (argTy, args, m) = Expr.Op(TOp.Array, [ argTy ], args, m)
+
+ let mkCompGenLocalAndInvisibleBind g nm m e =
+ let locv, loce = mkCompGenLocal m nm (tyOfExpr g e)
+ locv, loce, mkInvisibleBind locv e
+
+ //----------------------------------------------------------------------------
+ // Make some fragments of code
+ //----------------------------------------------------------------------------
+
+ let box = I_box(mkILTyvarTy 0us)
+
+ let isinst = I_isinst(mkILTyvarTy 0us)
+
+ let unbox = I_unbox_any(mkILTyvarTy 0us)
+
+ let mkUnbox ty e m =
+ mkAsmExpr ([ unbox ], [ ty ], [ e ], [ ty ], m)
+
+ let mkBox ty e m =
+ mkAsmExpr ([ box ], [], [ e ], [ ty ], m)
+
+ let mkIsInst ty e m =
+ mkAsmExpr ([ isinst ], [ ty ], [ e ], [ ty ], m)
+
+ let mspec_Type_GetTypeFromHandle (g: TcGlobals) =
+ mkILNonGenericStaticMethSpecInTy (g.ilg.typ_Type, "GetTypeFromHandle", [ g.iltyp_RuntimeTypeHandle ], g.ilg.typ_Type)
+
+ let mspec_String_Length (g: TcGlobals) =
+ mkILNonGenericInstanceMethSpecInTy (g.ilg.typ_String, "get_Length", [], g.ilg.typ_Int32)
+
+ let mspec_String_Concat2 (g: TcGlobals) =
+ mkILNonGenericStaticMethSpecInTy (g.ilg.typ_String, "Concat", [ g.ilg.typ_String; g.ilg.typ_String ], g.ilg.typ_String)
+
+ let mspec_String_Concat3 (g: TcGlobals) =
+ mkILNonGenericStaticMethSpecInTy (
+ g.ilg.typ_String,
+ "Concat",
+ [ g.ilg.typ_String; g.ilg.typ_String; g.ilg.typ_String ],
+ g.ilg.typ_String
+ )
+
+ let mspec_String_Concat4 (g: TcGlobals) =
+ mkILNonGenericStaticMethSpecInTy (
+ g.ilg.typ_String,
+ "Concat",
+ [ g.ilg.typ_String; g.ilg.typ_String; g.ilg.typ_String; g.ilg.typ_String ],
+ g.ilg.typ_String
+ )
+
+ let mspec_String_Concat_Array (g: TcGlobals) =
+ mkILNonGenericStaticMethSpecInTy (g.ilg.typ_String, "Concat", [ mkILArr1DTy g.ilg.typ_String ], g.ilg.typ_String)
+
+ let fspec_Missing_Value (g: TcGlobals) =
+ mkILFieldSpecInTy (g.iltyp_Missing, "Value", g.iltyp_Missing)
+
+ let mkInitializeArrayMethSpec (g: TcGlobals) =
+ let tref = g.FindSysILTypeRef "System.Runtime.CompilerServices.RuntimeHelpers"
+
+ mkILNonGenericStaticMethSpecInTy (
+ mkILNonGenericBoxedTy tref,
+ "InitializeArray",
+ [ g.ilg.typ_Array; g.iltyp_RuntimeFieldHandle ],
+ ILType.Void
+ )
+
+ let mkInvalidCastExnNewobj (g: TcGlobals) =
+ mkNormalNewobj (mkILCtorMethSpecForTy (mkILNonGenericBoxedTy (g.FindSysILTypeRef "System.InvalidCastException"), []))
+
+ let typedExprForIntrinsic _g m (IntrinsicValRef(_, _, _, ty, _) as i) =
+ let vref = ValRefForIntrinsic i
+ exprForValRef m vref, ty
+
+ //--------------------------------------------------------------------------
+ // Make applications
+ //---------------------------------------------------------------------------
+
+ let primMkApp (f, fty) tyargs argsl m = Expr.App(f, fty, tyargs, argsl, m)
+
+ // Check for the funky where a generic type instantiation at function type causes a generic function
+ // to appear to accept more arguments than it really does, e.g. "id id 1", where the first "id" is
+ // instantiated with "int -> int".
+ //
+ // In this case, apply the arguments one at a time.
+ let isExpansiveUnderInstantiation g fty0 tyargs pargs argsl =
+ isForallTy g fty0
+ && let fty1 = formalApplyTys g fty0 (tyargs, pargs) in
+
+ (not (isFunTy g fty1)
+ || let rec loop fty xs =
+ match xs with
+ | [] -> false
+ | _ :: t -> not (isFunTy g fty) || loop (rangeOfFunTy g fty) t in
+
+ loop fty1 argsl)
+
+ let mkExprAppAux g f fty argsl m =
+ match argsl with
+ | [] -> f
+ | _ ->
+ // Always combine the term application with a type application
+ //
+ // Combine the term application with a term application, but only when f' is an under-applied value of known arity
+ match f with
+ | Expr.App(f0, fty0, tyargs, pargs, m2) when
+ (isNil pargs
+ || (match stripExpr f0 with
+ | Expr.Val(v, _, _) ->
+ match v.ValReprInfo with
+ | Some info -> info.NumCurriedArgs > pargs.Length
+ | None -> false
+ | _ -> false))
+ && not (isExpansiveUnderInstantiation g fty0 tyargs pargs argsl)
+ ->
+ primMkApp (f0, fty0) tyargs (pargs @ argsl) (unionRanges m2 m)
+
+ | _ ->
+ // Don't combine. 'f' is not an application
+ if not (isFunTy g fty) then
+ error (InternalError("expected a function type", m))
+
+ primMkApp (f, fty) [] argsl m
+
+ let rec mkAppsAux g f fty tyargsl argsl m =
+ match tyargsl with
+ | tyargs :: rest ->
+ match tyargs with
+ | [] -> mkAppsAux g f fty rest argsl m
+ | _ ->
+ let arfty = applyForallTy g fty tyargs
+ mkAppsAux g (primMkApp (f, fty) tyargs [] m) arfty rest argsl m
+ | [] -> mkExprAppAux g f fty argsl m
+
+ let mkApps g ((f, fty), tyargsl, argl, m) = mkAppsAux g f fty tyargsl argl m
+
+ let mkTyAppExpr m (f, fty) tyargs =
+ match tyargs with
+ | [] -> f
+ | _ -> primMkApp (f, fty) tyargs [] m
+
+ let mkCallGetGenericComparer (g: TcGlobals) m =
+ typedExprForIntrinsic g m g.get_generic_comparer_info |> fst
+
+ let mkCallGetGenericEREqualityComparer (g: TcGlobals) m =
+ typedExprForIntrinsic g m g.get_generic_er_equality_comparer_info |> fst
+
+ let mkCallGetGenericPEREqualityComparer (g: TcGlobals) m =
+ typedExprForIntrinsic g m g.get_generic_per_equality_comparer_info |> fst
+
+ let mkCallUnbox (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.unbox_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallUnboxFast (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.unbox_fast_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallTypeTest (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.istype_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallTypeOf (g: TcGlobals) m ty =
+ mkApps g (typedExprForIntrinsic g m g.typeof_info, [ [ ty ] ], [], m)
+
+ let mkCallTypeDefOf (g: TcGlobals) m ty =
+ mkApps g (typedExprForIntrinsic g m g.typedefof_info, [ [ ty ] ], [], m)
+
+ let mkCallDispose (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.dispose_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallSeq (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.seq_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallCreateInstance (g: TcGlobals) m ty =
+ mkApps g (typedExprForIntrinsic g m g.create_instance_info, [ [ ty ] ], [ mkUnit g m ], m)
+
+ let mkCallGetQuerySourceAsEnumerable (g: TcGlobals) m ty1 ty2 e1 =
+ mkApps g (typedExprForIntrinsic g m g.query_source_as_enum_info, [ [ ty1; ty2 ] ], [ e1; mkUnit g m ], m)
+
+ let mkCallNewQuerySource (g: TcGlobals) m ty1 ty2 e1 =
+ mkApps g (typedExprForIntrinsic g m g.new_query_source_info, [ [ ty1; ty2 ] ], [ e1 ], m)
+
+ let mkCallCreateEvent (g: TcGlobals) m ty1 ty2 e1 e2 e3 =
+ mkApps g (typedExprForIntrinsic g m g.create_event_info, [ [ ty1; ty2 ] ], [ e1; e2; e3 ], m)
+
+ let mkCallGenericComparisonWithComparerOuter (g: TcGlobals) m ty comp e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.generic_comparison_withc_outer_info, [ [ ty ] ], [ comp; e1; e2 ], m)
+
+ let mkCallGenericEqualityEROuter (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.generic_equality_er_outer_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallGenericEqualityWithComparerOuter (g: TcGlobals) m ty comp e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.generic_equality_withc_outer_info, [ [ ty ] ], [ comp; e1; e2 ], m)
+
+ let mkCallGenericHashWithComparerOuter (g: TcGlobals) m ty comp e1 =
+ mkApps g (typedExprForIntrinsic g m g.generic_hash_withc_outer_info, [ [ ty ] ], [ comp; e1 ], m)
+
+ let mkCallEqualsOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.equals_operator_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallNotEqualsOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.not_equals_operator, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallLessThanOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.less_than_operator, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallLessThanOrEqualsOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.less_than_or_equals_operator, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallGreaterThanOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.greater_than_operator, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallGreaterThanOrEqualsOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.greater_than_or_equals_operator, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallAdditionOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_addition_info, [ [ ty; ty; ty ] ], [ e1; e2 ], m)
+
+ let mkCallSubtractionOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_subtraction_info, [ [ ty; ty; ty ] ], [ e1; e2 ], m)
+
+ let mkCallMultiplyOperator (g: TcGlobals) m ty1 ty2 retTy e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_multiply_info, [ [ ty1; ty2; retTy ] ], [ e1; e2 ], m)
+
+ let mkCallDivisionOperator (g: TcGlobals) m ty1 ty2 retTy e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_division_info, [ [ ty1; ty2; retTy ] ], [ e1; e2 ], m)
+
+ let mkCallModulusOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_modulus_info, [ [ ty; ty; ty ] ], [ e1; e2 ], m)
+
+ let mkCallDefaultOf (g: TcGlobals) m ty =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_defaultof_info, [ [ ty ] ], [], m)
+
+ let mkCallBitwiseAndOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.bitwise_and_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallBitwiseOrOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.bitwise_or_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallBitwiseXorOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.bitwise_xor_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallShiftLeftOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.bitwise_shift_left_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallShiftRightOperator (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.bitwise_shift_right_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkCallUnaryNegOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.unchecked_unary_minus_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallUnaryNotOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.bitwise_unary_not_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallAdditionChecked (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.checked_addition_info, [ [ ty; ty; ty ] ], [ e1; e2 ], m)
+
+ let mkCallSubtractionChecked (g: TcGlobals) m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.checked_subtraction_info, [ [ ty; ty; ty ] ], [ e1; e2 ], m)
+
+ let mkCallMultiplyChecked (g: TcGlobals) m ty1 ty2 retTy e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.checked_multiply_info, [ [ ty1; ty2; retTy ] ], [ e1; e2 ], m)
+
+ let mkCallUnaryNegChecked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.checked_unary_minus_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToByteChecked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.byte_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToSByteChecked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.sbyte_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToInt16Checked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int16_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUInt16Checked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.uint16_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToIntChecked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToInt32Checked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int32_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUInt32Checked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.uint32_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToInt64Checked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int64_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUInt64Checked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.uint64_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToIntPtrChecked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.nativeint_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUIntPtrChecked (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.unativeint_checked_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToByteOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.byte_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToSByteOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.sbyte_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToInt16Operator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int16_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUInt16Operator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.uint16_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToInt32Operator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int32_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUInt32Operator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.uint32_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToInt64Operator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.int64_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUInt64Operator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.uint64_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToSingleOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.float32_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToDoubleOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.float_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToIntPtrOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.nativeint_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToUIntPtrOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.unativeint_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToCharOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.char_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallToEnumOperator (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.enum_operator_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallArrayLength (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.array_length_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallArrayGet (g: TcGlobals) m ty e1 idx1 =
+ mkApps g (typedExprForIntrinsic g m g.array_get_info, [ [ ty ] ], [ e1; idx1 ], m)
+
+ let mkCallArray2DGet (g: TcGlobals) m ty e1 idx1 idx2 =
+ mkApps g (typedExprForIntrinsic g m g.array2D_get_info, [ [ ty ] ], [ e1; idx1; idx2 ], m)
+
+ let mkCallArray3DGet (g: TcGlobals) m ty e1 idx1 idx2 idx3 =
+ mkApps g (typedExprForIntrinsic g m g.array3D_get_info, [ [ ty ] ], [ e1; idx1; idx2; idx3 ], m)
+
+ let mkCallArray4DGet (g: TcGlobals) m ty e1 idx1 idx2 idx3 idx4 =
+ mkApps g (typedExprForIntrinsic g m g.array4D_get_info, [ [ ty ] ], [ e1; idx1; idx2; idx3; idx4 ], m)
+
+ let mkCallArraySet (g: TcGlobals) m ty e1 idx1 v =
+ mkApps g (typedExprForIntrinsic g m g.array_set_info, [ [ ty ] ], [ e1; idx1; v ], m)
+
+ let mkCallArray2DSet (g: TcGlobals) m ty e1 idx1 idx2 v =
+ mkApps g (typedExprForIntrinsic g m g.array2D_set_info, [ [ ty ] ], [ e1; idx1; idx2; v ], m)
+
+ let mkCallArray3DSet (g: TcGlobals) m ty e1 idx1 idx2 idx3 v =
+ mkApps g (typedExprForIntrinsic g m g.array3D_set_info, [ [ ty ] ], [ e1; idx1; idx2; idx3; v ], m)
+
+ let mkCallArray4DSet (g: TcGlobals) m ty e1 idx1 idx2 idx3 idx4 v =
+ mkApps g (typedExprForIntrinsic g m g.array4D_set_info, [ [ ty ] ], [ e1; idx1; idx2; idx3; idx4; v ], m)
+
+ let mkCallHash (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.hash_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallBox (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.box_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallIsNull (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.isnull_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallRaise (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.raise_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallNewDecimal (g: TcGlobals) m (e1, e2, e3, e4, e5) =
+ mkApps g (typedExprForIntrinsic g m g.new_decimal_info, [], [ e1; e2; e3; e4; e5 ], m)
+
+ let mkCallNewFormat (g: TcGlobals) m aty bty cty dty ety formatStringExpr =
+ mkApps g (typedExprForIntrinsic g m g.new_format_info, [ [ aty; bty; cty; dty; ety ] ], [ formatStringExpr ], m)
+
+ let tryMkCallBuiltInWitness (g: TcGlobals) traitInfo argExprs m =
+ let info, tinst = g.MakeBuiltInWitnessInfo traitInfo
+ let vref = ValRefForIntrinsic info
+
+ match vref.TryDeref with
+ | ValueSome v ->
+ let f = exprForValRef m vref
+ mkApps g ((f, v.Type), [ tinst ], argExprs, m) |> Some
+ | ValueNone -> None
+
+ let tryMkCallCoreFunctionAsBuiltInWitness (g: TcGlobals) info tyargs argExprs m =
+ let vref = ValRefForIntrinsic info
+
+ match vref.TryDeref with
+ | ValueSome v ->
+ let f = exprForValRef m vref
+ mkApps g ((f, v.Type), [ tyargs ], argExprs, m) |> Some
+ | ValueNone -> None
+
+ let TryEliminateDesugaredConstants g m c =
+ match c with
+ | Const.Decimal d ->
+ match Decimal.GetBits d with
+ | [| lo; med; hi; signExp |] ->
+ let scale = (min (((signExp &&& 0xFF0000) >>> 16) &&& 0xFF) 28) |> byte
+ let isNegative = (signExp &&& 0x80000000) <> 0
+ Some(mkCallNewDecimal g m (mkInt g m lo, mkInt g m med, mkInt g m hi, mkBool g m isNegative, mkByte g m scale))
+ | _ -> failwith "unreachable"
+ | _ -> None
+
+ let mkCallSeqCollect g m alphaTy betaTy arg1 arg2 =
+ let enumty2 =
+ try
+ rangeOfFunTy g (tyOfExpr g arg1)
+ with _ -> (* defensive programming *)
+ (mkSeqTy g betaTy)
+
+ mkApps g (typedExprForIntrinsic g m g.seq_collect_info, [ [ alphaTy; enumty2; betaTy ] ], [ arg1; arg2 ], m)
+
+ let mkCallSeqUsing g m resourceTy elemTy arg1 arg2 =
+ // We're instantiating val using : 'a -> ('a -> 'sb) -> seq<'b> when 'sb :> seq<'b> and 'a :> IDisposable
+ // We set 'sb -> range(typeof(arg2))
+ let enumty =
+ try
+ rangeOfFunTy g (tyOfExpr g arg2)
+ with _ -> (* defensive programming *)
+ (mkSeqTy g elemTy)
+
+ mkApps g (typedExprForIntrinsic g m g.seq_using_info, [ [ resourceTy; enumty; elemTy ] ], [ arg1; arg2 ], m)
+
+ let mkCallSeqDelay g m elemTy arg1 =
+ mkApps g (typedExprForIntrinsic g m g.seq_delay_info, [ [ elemTy ] ], [ arg1 ], m)
+
+ let mkCallSeqAppend g m elemTy arg1 arg2 =
+ mkApps g (typedExprForIntrinsic g m g.seq_append_info, [ [ elemTy ] ], [ arg1; arg2 ], m)
+
+ let mkCallSeqGenerated g m elemTy arg1 arg2 =
+ mkApps g (typedExprForIntrinsic g m g.seq_generated_info, [ [ elemTy ] ], [ arg1; arg2 ], m)
+
+ let mkCallSeqFinally g m elemTy arg1 arg2 =
+ mkApps g (typedExprForIntrinsic g m g.seq_finally_info, [ [ elemTy ] ], [ arg1; arg2 ], m)
+
+ let mkCallSeqTryWith g m elemTy origSeq exnFilter exnHandler =
+ mkApps g (typedExprForIntrinsic g m g.seq_trywith_info, [ [ elemTy ] ], [ origSeq; exnFilter; exnHandler ], m)
+
+ let mkCallSeqOfFunctions g m ty1 ty2 arg1 arg2 arg3 =
+ mkApps g (typedExprForIntrinsic g m g.seq_of_functions_info, [ [ ty1; ty2 ] ], [ arg1; arg2; arg3 ], m)
+
+ let mkCallSeqToArray g m elemTy arg1 =
+ mkApps g (typedExprForIntrinsic g m g.seq_to_array_info, [ [ elemTy ] ], [ arg1 ], m)
+
+ let mkCallSeqToList g m elemTy arg1 =
+ mkApps g (typedExprForIntrinsic g m g.seq_to_list_info, [ [ elemTy ] ], [ arg1 ], m)
+
+ let mkCallSeqMap g m inpElemTy genElemTy arg1 arg2 =
+ mkApps g (typedExprForIntrinsic g m g.seq_map_info, [ [ inpElemTy; genElemTy ] ], [ arg1; arg2 ], m)
+
+ let mkCallSeqSingleton g m ty1 arg1 =
+ mkApps g (typedExprForIntrinsic g m g.seq_singleton_info, [ [ ty1 ] ], [ arg1 ], m)
+
+ let mkCallSeqEmpty g m ty1 =
+ mkApps g (typedExprForIntrinsic g m g.seq_empty_info, [ [ ty1 ] ], [], m)
+
+ let mkCall_sprintf (g: TcGlobals) m funcTy fmtExpr fillExprs =
+ mkApps g (typedExprForIntrinsic g m g.sprintf_info, [ [ funcTy ] ], fmtExpr :: fillExprs, m)
+
+ let mkCallDeserializeQuotationFSharp20Plus g m e1 e2 e3 e4 =
+ let args = [ e1; e2; e3; e4 ]
+ mkApps g (typedExprForIntrinsic g m g.deserialize_quoted_FSharp_20_plus_info, [], [ mkRefTupledNoTypes g m args ], m)
+
+ let mkCallDeserializeQuotationFSharp40Plus g m e1 e2 e3 e4 e5 =
+ let args = [ e1; e2; e3; e4; e5 ]
+ mkApps g (typedExprForIntrinsic g m g.deserialize_quoted_FSharp_40_plus_info, [], [ mkRefTupledNoTypes g m args ], m)
+
+ let mkCallCastQuotation g m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.cast_quotation_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallLiftValue (g: TcGlobals) m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.lift_value_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallLiftValueWithName (g: TcGlobals) m ty nm e1 =
+ let vref = ValRefForIntrinsic g.lift_value_with_name_info
+ // Use "Expr.ValueWithName" if it exists in FSharp.Core
+ match vref.TryDeref with
+ | ValueSome _ ->
+ mkApps
+ g
+ (typedExprForIntrinsic g m g.lift_value_with_name_info, [ [ ty ] ], [ mkRefTupledNoTypes g m [ e1; mkString g m nm ] ], m)
+ | ValueNone -> mkCallLiftValue g m ty e1
+
+ let mkCallLiftValueWithDefn g m qty e1 =
+ assert isQuotedExprTy g qty
+ let ty = destQuotedExprTy g qty
+ let vref = ValRefForIntrinsic g.lift_value_with_defn_info
+ // Use "Expr.WithValue" if it exists in FSharp.Core
+ match vref.TryDeref with
+ | ValueSome _ ->
+ let copyOfExpr = copyExpr g ValCopyFlag.CloneAll e1
+ let quoteOfCopyOfExpr = Expr.Quote(copyOfExpr, ref None, false, m, qty)
+
+ mkApps
+ g
+ (typedExprForIntrinsic g m g.lift_value_with_defn_info, [ [ ty ] ], [ mkRefTupledNoTypes g m [ e1; quoteOfCopyOfExpr ] ], m)
+ | ValueNone -> Expr.Quote(e1, ref None, false, m, qty)
+
+ let mkCallCheckThis g m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.check_this_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkCallFailInit g m =
+ mkApps g (typedExprForIntrinsic g m g.fail_init_info, [], [ mkUnit g m ], m)
+
+ let mkCallFailStaticInit g m =
+ mkApps g (typedExprForIntrinsic g m g.fail_static_init_info, [], [ mkUnit g m ], m)
+
+ let mkCallQuoteToLinqLambdaExpression g m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.quote_to_linq_lambda_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkOptionToNullable g m ty e1 =
+ mkApps g (typedExprForIntrinsic g m g.option_toNullable_info, [ [ ty ] ], [ e1 ], m)
+
+ let mkOptionDefaultValue g m ty e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.option_defaultValue_info, [ [ ty ] ], [ e1; e2 ], m)
+
+ let mkLazyDelayed g m ty f =
+ mkApps g (typedExprForIntrinsic g m g.lazy_create_info, [ [ ty ] ], [ f ], m)
+
+ let mkLazyForce g m ty e =
+ mkApps g (typedExprForIntrinsic g m g.lazy_force_info, [ [ ty ] ], [ e; mkUnit g m ], m)
+
+ let mkGetString g m e1 e2 =
+ mkApps g (typedExprForIntrinsic g m g.getstring_info, [], [ e1; e2 ], m)
+
+ let mkGetStringChar = mkGetString
+
+ let mkGetStringLength g m e =
+ let mspec = mspec_String_Length g
+
+ Expr.Op(
+ TOp.ILCall(false, false, false, false, ValUseFlag.NormalValUse, true, false, mspec.MethodRef, [], [], [ g.int32_ty ]),
+ [],
+ [ e ],
+ m
+ )
+
+ let mkStaticCall_String_Concat2 g m arg1 arg2 =
+ let mspec = mspec_String_Concat2 g
+
+ Expr.Op(
+ TOp.ILCall(false, false, false, false, ValUseFlag.NormalValUse, false, false, mspec.MethodRef, [], [], [ g.string_ty ]),
+ [],
+ [ arg1; arg2 ],
+ m
+ )
+
+ let mkStaticCall_String_Concat3 g m arg1 arg2 arg3 =
+ let mspec = mspec_String_Concat3 g
+
+ Expr.Op(
+ TOp.ILCall(false, false, false, false, ValUseFlag.NormalValUse, false, false, mspec.MethodRef, [], [], [ g.string_ty ]),
+ [],
+ [ arg1; arg2; arg3 ],
+ m
+ )
+
+ let mkStaticCall_String_Concat4 g m arg1 arg2 arg3 arg4 =
+ let mspec = mspec_String_Concat4 g
+
+ Expr.Op(
+ TOp.ILCall(false, false, false, false, ValUseFlag.NormalValUse, false, false, mspec.MethodRef, [], [], [ g.string_ty ]),
+ [],
+ [ arg1; arg2; arg3; arg4 ],
+ m
+ )
+
+ let mkStaticCall_String_Concat_Array g m arg =
+ let mspec = mspec_String_Concat_Array g
+
+ Expr.Op(
+ TOp.ILCall(false, false, false, false, ValUseFlag.NormalValUse, false, false, mspec.MethodRef, [], [], [ g.string_ty ]),
+ [],
+ [ arg ],
+ m
+ )
+
+ // Quotations can't contain any IL.
+ // As a result, we aim to get rid of all IL generation in the typechecker and pattern match
+ // compiler, or else train the quotation generator to understand the generated IL.
+ // Hence each of the following are marked with places where they are generated.
+
+ // Generated by the optimizer and the encoding of 'for' loops
+ let mkDecr (g: TcGlobals) m e =
+ mkAsmExpr ([ AI_sub ], [], [ e; mkOne g m ], [ g.int_ty ], m)
+
+ let mkIncr (g: TcGlobals) m e =
+ mkAsmExpr ([ AI_add ], [], [ mkOne g m; e ], [ g.int_ty ], m)
+
+ // Generated by the pattern match compiler and the optimizer for
+ // 1. array patterns
+ // 2. optimizations associated with getting 'for' loops into the shape expected by the JIT.
+ //
+ // NOTE: The conv.i4 assumes that int_ty is int32. Note: ldlen returns native UNSIGNED int
+ let mkLdlen (g: TcGlobals) m arre =
+ mkAsmExpr ([ I_ldlen; (AI_conv DT_I4) ], [], [ arre ], [ g.int_ty ], m)
+
+ let mkLdelem (_g: TcGlobals) m ty arre idxe =
+ mkAsmExpr ([ I_ldelem_any(ILArrayShape.SingleDimensional, mkILTyvarTy 0us) ], [ ty ], [ arre; idxe ], [ ty ], m)
+
+ // This is generated in equality/compare/hash augmentations and in the pattern match compiler.
+ // It is understood by the quotation processor and turned into "Equality" nodes.
+ //
+ // Note: this is IL assembly code, don't go inserting this in expressions which will be exposed via quotations
+ let mkILAsmCeq (g: TcGlobals) m e1 e2 =
+ mkAsmExpr ([ AI_ceq ], [], [ e1; e2 ], [ g.bool_ty ], m)
+
+ let mkILAsmClt (g: TcGlobals) m e1 e2 =
+ mkAsmExpr ([ AI_clt ], [], [ e1; e2 ], [ g.bool_ty ], m)
+
+ // This is generated in the initialization of the "ctorv" field in the typechecker's compilation of
+ // an implicit class construction.
+ let mkNull m ty = Expr.Const(Const.Zero, m, ty)
+
+ let mkThrow m ty e =
+ mkAsmExpr ([ I_throw ], [], [ e ], [ ty ], m)
+
+ // reraise - parsed as library call - internally represented as op form.
+ let mkReraiseLibCall (g: TcGlobals) ty m =
+ let ve, vt = typedExprForIntrinsic g m g.reraise_info
+ Expr.App(ve, vt, [ ty ], [ mkUnit g m ], m)
+
+ let mkReraise m returnTy =
+ Expr.Op(TOp.Reraise, [ returnTy ], [], m) (* could suppress unitArg *)
+
+ //--------------------------------------------------------------------------
+ // Nullness tests and pokes
+ //--------------------------------------------------------------------------
+
+ (* match inp with DU(_) -> true | _ -> false *)
+ let mkUnionCaseTest (g: TcGlobals) (e1, cref: UnionCaseRef, tinst, m) =
+ let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m)
+ let tg2 = mbuilder.AddResultTarget(Expr.Const(Const.Bool true, m, g.bool_ty))
+ let tg3 = mbuilder.AddResultTarget(Expr.Const(Const.Bool false, m, g.bool_ty))
+
+ let dtree =
+ TDSwitch(e1, [ TCase(DecisionTreeTest.UnionCase(cref, tinst), tg2) ], Some tg3, m)
+
+ let expr = mbuilder.Close(dtree, m, g.bool_ty)
+ expr
+
+ // Null tests are generated by
+ // 1. The compilation of array patterns in the pattern match compiler
+ // 2. The compilation of string patterns in the pattern match compiler
+ let mkLabelled m l e =
+ mkCompGenSequential m (Expr.Op(TOp.Label l, [], [], m)) e
+
+ // Called for when creating compiled form of 'let fixed ...'.
+ //
+ // No sequence point is generated for this expression form as this function is only
+ // used for compiler-generated code.
+ let mkNullTest g m e1 e2 e3 =
+ let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m)
+ let tg2 = mbuilder.AddResultTarget(e2)
+ let tg3 = mbuilder.AddResultTarget(e3)
+ let dtree = TDSwitch(e1, [ TCase(DecisionTreeTest.IsNull, tg3) ], Some tg2, m)
+ let expr = mbuilder.Close(dtree, m, tyOfExpr g e2)
+ expr
+
+ let mkNonNullTest (g: TcGlobals) m e =
+ mkAsmExpr ([ AI_ldnull; AI_cgt_un ], [], [ e ], [ g.bool_ty ], m)
+
+ // No sequence point is generated for this expression form as this function is only
+ // used for compiler-generated code.
+ let mkNonNullCond g m ty e1 e2 e3 =
+ mkCond DebugPointAtBinding.NoneAtInvisible m ty (mkNonNullTest g m e1) e2 e3
+
+ // No sequence point is generated for this expression form as this function is only
+ // used for compiler-generated code.
+ let mkIfThen (g: TcGlobals) m e1 e2 =
+ mkCond DebugPointAtBinding.NoneAtInvisible m g.unit_ty e1 e2 (mkUnit g m)
+
+[]
+module internal ExprTransforms =
+
+ //--------------------------------------------------------------------------
+ // tupled lambda --> method/function with a given valReprInfo specification.
+ //
+ // AdjustArityOfLambdaBody: "(vs, body)" represents a lambda "fun (vs) -> body". The
+ // aim is to produce a "static method" represented by a pair
+ // "(mvs, body)" where mvs has the List.length "arity".
+ //--------------------------------------------------------------------------
+
+ let untupledToRefTupled g vs =
+ let untupledTys = typesOfVals vs
+ let m = (List.head vs).Range
+ let tupledv, tuplede = mkCompGenLocal m "tupledArg" (mkRefTupledTy g untupledTys)
+
+ let untupling_es =
+ List.mapi (fun i _ -> mkTupleFieldGet g (tupInfoRef, tuplede, untupledTys, i, m)) untupledTys
+ // These are non-sticky - at the caller,any sequence point for 'body' goes on 'body' _after_ the binding has been made
+ tupledv, mkInvisibleLets m vs untupling_es
+
+ // The required tupled-arity (arity) can either be 1
+ // or N, and likewise for the tuple-arity of the input lambda, i.e. either 1 or N
+ // where the N's will be identical.
+ let AdjustArityOfLambdaBody g arity (vs: Val list) body =
+ let nvs = vs.Length
+
+ if not (nvs = arity || nvs = 1 || arity = 1) then
+ failwith "lengths don't add up"
+
+ if arity = 0 then
+ vs, body
+ elif nvs = arity then
+ vs, body
+ elif nvs = 1 then
+ let v = vs.Head
+ let untupledTys = destRefTupleTy g v.Type
+
+ if (untupledTys.Length <> arity) then
+ failwith "length untupledTys <> arity"
+
+ let dummyvs, dummyes =
+ untupledTys
+ |> List.mapi (fun i ty -> mkCompGenLocal v.Range (v.LogicalName + "_" + string i) ty)
+ |> List.unzip
+
+ let body = mkInvisibleLet v.Range v (mkRefTupled g v.Range dummyes untupledTys) body
+ dummyvs, body
+ else
+ let tupledv, untupler = untupledToRefTupled g vs
+ [ tupledv ], untupler body
+
+ let MultiLambdaToTupledLambda g vs body =
+ match vs with
+ | [] -> failwith "MultiLambdaToTupledLambda: expected some arguments"
+ | [ v ] -> v, body
+ | vs ->
+ let tupledv, untupler = untupledToRefTupled g vs
+ tupledv, untupler body
+
+ []
+ let (|RefTuple|_|) expr =
+ match expr with
+ | Expr.Op(TOp.Tuple(TupInfo.Const false), _, args, _) -> ValueSome args
+ | _ -> ValueNone
+
+ let MultiLambdaToTupledLambdaIfNeeded g (vs, arg) body =
+ match vs, arg with
+ | [], _ -> failwith "MultiLambdaToTupledLambda: expected some arguments"
+ | [ v ], _ -> [ (v, arg) ], body
+ | vs, RefTuple args when args.Length = vs.Length -> List.zip vs args, body
+ | vs, _ ->
+ let tupledv, untupler = untupledToRefTupled g vs
+ [ (tupledv, arg) ], untupler body
+
+ //--------------------------------------------------------------------------
+ // Beta reduction via let-bindings. Reduce immediate apps. of lambdas to let bindings.
+ // Includes binding the immediate application of generic
+ // functions. Input type is the type of the function. Makes use of the invariant
+ // that any two expressions have distinct local variables (because we explicitly copy
+ // expressions).
+ //------------------------------------------------------------------------
+
+ let rec MakeApplicationAndBetaReduceAux g (f, fty, tyargsl: TType list list, argsl: Expr list, m) =
+ match f with
+ | Expr.Let(bind, body, mLet, _) ->
+ // Lift bindings out, i.e. (let x = e in f) y --> let x = e in f y
+ // This increases the scope of 'x', which I don't like as it mucks with debugging
+ // scopes of variables, but this is an important optimization, especially when the '|>'
+ // notation is used a lot.
+ mkLetBind mLet bind (MakeApplicationAndBetaReduceAux g (body, fty, tyargsl, argsl, m))
+ | _ ->
+ match tyargsl with
+ | [] :: rest -> MakeApplicationAndBetaReduceAux g (f, fty, rest, argsl, m)
+
+ | tyargs :: rest ->
+ // Bind type parameters by immediate substitution
+ match f with
+ | Expr.TyLambda(_, tyvs, body, _, bodyTy) when tyvs.Length = List.length tyargs ->
+ let tpenv = bindTypars tyvs tyargs emptyTyparInst
+ let body = instExpr g tpenv body
+ let bodyTyR = instType tpenv bodyTy
+ MakeApplicationAndBetaReduceAux g (body, bodyTyR, rest, argsl, m)
+
+ | _ ->
+ let f = mkAppsAux g f fty [ tyargs ] [] m
+ let fty = applyTyArgs g fty tyargs
+ MakeApplicationAndBetaReduceAux g (f, fty, rest, argsl, m)
+ | [] ->
+ match argsl with
+ | _ :: _ ->
+ // Bind term parameters by "let" explicit substitutions
+ //
+ // Only do this if there are enough lambdas for the number of arguments supplied. This is because
+ // all arguments get evaluated before application.
+ //
+ // VALID:
+ // (fun a b -> E[a, b]) t1 t2 ---> let a = t1 in let b = t2 in E[t1, t2]
+ // INVALID:
+ // (fun a -> E[a]) t1 t2 ---> let a = t1 in E[a] t2 UNLESS: E[a] has no effects OR t2 has no effects
+
+ match tryStripLambdaN argsl.Length f with
+ | Some(argvsl, body) ->
+ assert (argvsl.Length = argsl.Length)
+
+ let pairs, body =
+ List.mapFoldBack (MultiLambdaToTupledLambdaIfNeeded g) (List.zip argvsl argsl) body
+
+ let argvs2, args2 = List.unzip (List.concat pairs)
+ mkLetsBind m (mkCompGenBinds argvs2 args2) body
+ | _ -> mkExprAppAux g f fty argsl m
+
+ | [] -> f
+
+ let MakeApplicationAndBetaReduce g (f, fty, tyargsl, argl, m) =
+ MakeApplicationAndBetaReduceAux g (f, fty, tyargsl, argl, m)
+
+ []
+ let (|NewDelegateExpr|_|) g expr =
+ match expr with
+ | Expr.Obj(lambdaId, ty, a, b, [ TObjExprMethod(c, d, e, tmvs, body, f) ], [], m) when isDelegateTy g ty ->
+ ValueSome(
+ lambdaId,
+ List.concat tmvs,
+ body,
+ m,
+ (fun bodyR -> Expr.Obj(lambdaId, ty, a, b, [ TObjExprMethod(c, d, e, tmvs, bodyR, f) ], [], m))
+ )
+ | _ -> ValueNone
+
+ []
+ let (|DelegateInvokeExpr|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(invokeRef, _, _) as delInvokeRef, delInvokeTy, tyargs, [ delExpr; delInvokeArg ], m) when
+ invokeRef.LogicalName = "Invoke" && isFSharpDelegateTy g (tyOfExpr g delExpr)
+ ->
+ ValueSome(delInvokeRef, delInvokeTy, tyargs, delExpr, delInvokeArg, m)
+ | _ -> ValueNone
+
+ []
+ let (|OpPipeRight|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ _; resType ], [ xExpr; fExpr ], m) when valRefEq g vref g.piperight_vref ->
+ ValueSome(resType, xExpr, fExpr, m)
+ | _ -> ValueNone
+
+ []
+ let (|OpPipeRight2|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ _; _; resType ], [ Expr.Op(TOp.Tuple _, _, [ arg1; arg2 ], _); fExpr ], m) when
+ valRefEq g vref g.piperight2_vref
+ ->
+ ValueSome(resType, arg1, arg2, fExpr, m)
+ | _ -> ValueNone
+
+ []
+ let (|OpPipeRight3|_|) g expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, _, _), _, [ _; _; _; resType ], [ Expr.Op(TOp.Tuple _, _, [ arg1; arg2; arg3 ], _); fExpr ], m) when
+ valRefEq g vref g.piperight3_vref
+ ->
+ ValueSome(resType, arg1, arg2, arg3, fExpr, m)
+ | _ -> ValueNone
+
+ let rec MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, delExpr, delInvokeTy, tyargs, delInvokeArg, m) =
+ match delExpr with
+ | Expr.Let(bind, body, mLet, _) ->
+ mkLetBind mLet bind (MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, body, delInvokeTy, tyargs, delInvokeArg, m))
+ | NewDelegateExpr g (_, argvs & _ :: _, body, m, _) ->
+ let pairs, body = MultiLambdaToTupledLambdaIfNeeded g (argvs, delInvokeArg) body
+ let argvs2, args2 = List.unzip pairs
+ mkLetsBind m (mkCompGenBinds argvs2 args2) body
+ | _ ->
+ // Remake the delegate invoke
+ Expr.App(delInvokeRef, delInvokeTy, tyargs, [ delExpr; delInvokeArg ], m)
+
+ //---------------------------------------------------------------------------
+ // Adjust for expected usage
+ // Convert a use of a value to saturate to the given arity.
+ //---------------------------------------------------------------------------
+
+ let MakeArgsForTopArgs (_g: TcGlobals) m argTysl tpenv =
+ argTysl
+ |> List.mapi (fun i argTys ->
+ argTys
+ |> List.mapi (fun j (argTy, argInfo: ArgReprInfo) ->
+ let ty = instType tpenv argTy
+
+ let nm =
+ match argInfo.Name with
+ | None -> CompilerGeneratedName("arg" + string i + string j)
+ | Some id -> id.idText
+
+ fst (mkCompGenLocal m nm ty)))
+
+ let AdjustValForExpectedValReprInfo g m (vref: ValRef) flags valReprInfo =
+
+ let tps, argTysl, retTy, _ = GetValReprTypeInFSharpForm g valReprInfo vref.Type m
+ let tpsR = copyTypars false tps
+ let tyargsR = List.map mkTyparTy tpsR
+ let tpenv = bindTypars tps tyargsR emptyTyparInst
+ let rtyR = instType tpenv retTy
+ let vsl = MakeArgsForTopArgs g m argTysl tpenv
+
+ let call =
+ MakeApplicationAndBetaReduce g (Expr.Val(vref, flags, m), vref.Type, [ tyargsR ], (List.map (mkRefTupledVars g m) vsl), m)
+
+ let tauexpr, tauty =
+ List.foldBack (fun vs (e, ty) -> mkMultiLambda m vs (e, ty), (mkFunTy g (mkRefTupledVarsTy g vs) ty)) vsl (call, rtyR)
+ // Build a type-lambda expression for the toplevel value if needed...
+ mkTypeLambda m tpsR (tauexpr, tauty), tpsR +-> tauty
+
+ let stripTupledFunTy g ty =
+ let argTys, retTy = stripFunTy g ty
+ let curriedArgTys = argTys |> List.map (tryDestRefTupleTy g)
+ curriedArgTys, retTy
+
+ []
+ let (|ExprValWithPossibleTypeInst|_|) expr =
+ match expr with
+ | Expr.App(Expr.Val(vref, flags, m), _fty, tyargs, [], _) -> ValueSome(vref, flags, tyargs, m)
+ | Expr.Val(vref, flags, m) -> ValueSome(vref, flags, [], m)
+ | _ -> ValueNone
+
+ let mkCoerceIfNeeded g tgtTy srcTy expr =
+ if typeEquiv g tgtTy srcTy then
+ expr
+ else
+ mkCoerceExpr (expr, tgtTy, expr.Range, srcTy)
+
+ let mkCompGenLetIn m nm ty e f =
+ let v, ve = mkCompGenLocal m nm ty
+ mkCompGenLet m v e (f (v, ve))
+
+ let mkCompGenLetMutableIn m nm ty e f =
+ let v, ve = mkMutableCompGenLocal m nm ty
+ mkCompGenLet m v e (f (v, ve))
+
+ /// Take a node representing a coercion from one function type to another, e.g.
+ /// A -> A * A -> int
+ /// to
+ /// B -> B * A -> int
+ /// and return an expression of the correct type that doesn't use a coercion type. For example
+ /// return
+ /// (fun b1 b2 -> E (b1 :> A) (b2 :> A))
+ ///
+ /// - Use good names for the closure arguments if available
+ /// - Create lambda variables if needed, or use the supplied arguments if available.
+ ///
+ /// Return the new expression and any unused suffix of supplied arguments
+ ///
+ /// If E is a value with TopInfo then use the arity to help create a better closure.
+ /// In particular we can create a closure like this:
+ /// (fun b1 b2 -> E (b1 :> A) (b2 :> A))
+ /// rather than
+ /// (fun b1 -> let clo = E (b1 :> A) in (fun b2 -> clo (b2 :> A)))
+ /// The latter closures are needed to carefully preserve side effect order
+ ///
+ /// Note that the results of this translation are visible to quotations
+
+ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Expr * Expr list) option =
+
+ match expr with
+ | Expr.Op(TOp.Coerce, [ inputTy; actualTy ], [ exprWithActualTy ], m) when isFunTy g actualTy && isFunTy g inputTy ->
+
+ if typeEquiv g actualTy inputTy then
+ Some(exprWithActualTy, suppliedArgs)
+ else
+
+ let curriedActualArgTys, retTy = stripTupledFunTy g actualTy
+
+ let curriedInputTys, _ = stripFunTy g inputTy
+
+ assert (curriedActualArgTys.Length = curriedInputTys.Length)
+
+ let argTys =
+ (curriedInputTys, curriedActualArgTys) ||> List.mapi2 (fun i x y -> (i, x, y))
+
+ // Use the nice names for a function of known arity and name. Note that 'nice' here also
+ // carries a semantic meaning. For a function with top-info,
+ // let f (x: A) (y: A) (z: A) = ...
+ // we know there are no side effects on the application of 'f' to 1, 2 args. This greatly simplifies
+ // the closure built for
+ // f b1 b2
+ // and indeed for
+ // f b1 b2 b3
+ // we don't build any closure at all, and just return
+ // f (b1 :> A) (b2 :> A) (b3 :> A)
+
+ let curriedNiceNames =
+ match stripExpr exprWithActualTy with
+ | ExprValWithPossibleTypeInst(vref, _, _, _) when vref.ValReprInfo.IsSome ->
+
+ let _, argTysl, _, _ =
+ GetValReprTypeInFSharpForm g vref.ValReprInfo.Value vref.Type expr.Range
+
+ argTysl
+ |> List.mapi (fun i argTys ->
+ argTys
+ |> List.mapi (fun j (_, argInfo) ->
+ match argInfo.Name with
+ | None -> CompilerGeneratedName("arg" + string i + string j)
+ | Some id -> id.idText))
+ | _ -> []
+
+ let nCurriedNiceNames = curriedNiceNames.Length
+ assert (curriedActualArgTys.Length >= nCurriedNiceNames)
+
+ let argTysWithNiceNames, argTysWithoutNiceNames =
+ List.splitAt nCurriedNiceNames argTys
+
+ /// Only consume 'suppliedArgs' up to at most the number of nice arguments
+ let nSuppliedArgs = min suppliedArgs.Length nCurriedNiceNames
+ let suppliedArgs, droppedSuppliedArgs = List.splitAt nSuppliedArgs suppliedArgs
+
+ /// The relevant range for any expressions and applications includes the arguments
+ let appm = (m, suppliedArgs) ||> List.fold (fun m e -> unionRanges m e.Range)
+
+ // See if we have 'enough' suppliedArgs. If not, we have to build some lambdas, and,
+ // we have to 'let' bind all arguments that we consume, e.g.
+ // Seq.take (effect;4) : int list -> int list
+ // is a classic case. Here we generate
+ // let tmp = (effect;4) in
+ // (fun v -> Seq.take tmp (v :> seq<_>))
+ let buildingLambdas = nSuppliedArgs <> nCurriedNiceNames
+
+ /// Given a tuple of argument variables that has a tuple type that satisfies the input argument types,
+ /// coerce it to a tuple that satisfies the matching coerced argument type(s).
+ let CoerceDetupled (argTys: TType list) (detupledArgs: Expr list) (actualTys: TType list) =
+ assert (actualTys.Length = argTys.Length)
+ assert (actualTys.Length = detupledArgs.Length)
+ // Inject the coercions into the user-supplied explicit tuple
+ let argm = List.reduce unionRanges (detupledArgs |> List.map (fun e -> e.Range))
+ mkRefTupled g argm (List.map3 (mkCoerceIfNeeded g) actualTys argTys detupledArgs) actualTys
+
+ /// Given an argument variable of tuple type that has been evaluated and stored in the
+ /// given variable, where the tuple type that satisfies the input argument types,
+ /// coerce it to a tuple that satisfies the matching coerced argument type(s).
+ let CoerceBoundTuple tupleVar argTys (actualTys: TType list) =
+ assert (actualTys.Length > 1)
+
+ mkRefTupled
+ g
+ appm
+ ((actualTys, argTys)
+ ||> List.mapi2 (fun i actualTy dummyTy ->
+ let argExprElement = mkTupleFieldGet g (tupInfoRef, tupleVar, argTys, i, appm)
+ mkCoerceIfNeeded g actualTy dummyTy argExprElement))
+ actualTys
+
+ /// Given an argument that has a tuple type that satisfies the input argument types,
+ /// coerce it to a tuple that satisfies the matching coerced argument type. Try to detuple the argument if possible.
+ let CoerceTupled niceNames (argExpr: Expr) (actualTys: TType list) =
+ let argExprTy = (tyOfExpr g argExpr)
+
+ let argTys =
+ match actualTys with
+ | [ _ ] -> [ tyOfExpr g argExpr ]
+ | _ -> tryDestRefTupleTy g argExprTy
+
+ assert (actualTys.Length = argTys.Length)
+
+ let nm =
+ match niceNames with
+ | [ nm ] -> nm
+ | _ -> "arg"
+
+ if buildingLambdas then
+ // Evaluate the user-supplied tuple-valued argument expression, inject the coercions and build an explicit tuple
+ // Assign the argument to make sure it is only run once
+ // f ~~>: B -> int
+ // f ~~> : (B * B) -> int
+ //
+ // for
+ // let f a = 1
+ // let f (a, a) = 1
+ let v, ve = mkCompGenLocal appm nm argExprTy
+ let binderBuilder = (fun tm -> mkCompGenLet appm v argExpr tm)
+
+ let expr =
+ match actualTys, argTys with
+ | [ actualTy ], [ argTy ] -> mkCoerceIfNeeded g actualTy argTy ve
+ | _ -> CoerceBoundTuple ve argTys actualTys
+
+ binderBuilder, expr
+ else if typeEquiv g (mkRefTupledTy g actualTys) argExprTy then
+ id, argExpr
+ else
+
+ let detupledArgs, argTys =
+ match actualTys with
+ | [ _actualType ] -> [ argExpr ], [ tyOfExpr g argExpr ]
+ | _ -> tryDestRefTupleExpr argExpr, tryDestRefTupleTy g argExprTy
+
+ // OK, the tuples match, or there is no de-tupling,
+ // f x
+ // f (x, y)
+ //
+ // for
+ // let f (x, y) = 1
+ // and we're not building lambdas, just coerce the arguments in place
+ if detupledArgs.Length = actualTys.Length then
+ id, CoerceDetupled argTys detupledArgs actualTys
+ else
+ // In this case there is a tuple mismatch.
+ // f p
+ //
+ //
+ // for
+ // let f (x, y) = 1
+ // Assign the argument to make sure it is only run once
+ let v, ve = mkCompGenLocal appm nm argExprTy
+ let binderBuilder = (fun tm -> mkCompGenLet appm v argExpr tm)
+ let expr = CoerceBoundTuple ve argTys actualTys
+ binderBuilder, expr
+
+ // This variable is really a dummy to make the code below more regular.
+ // In the i = N - 1 cases we skip the introduction of the 'let' for
+ // this variable.
+ let resVar, resVarAsExpr = mkCompGenLocal appm "result" retTy
+ let N = argTys.Length
+
+ let cloVar, exprForOtherArgs, _ =
+ List.foldBack
+ (fun (i, inpArgTy, actualArgTys) (cloVar: Val, res, resTy) ->
+
+ let inpArgTys =
+ match actualArgTys with
+ | [ _ ] -> [ inpArgTy ]
+ | _ -> destRefTupleTy g inpArgTy
+
+ assert (inpArgTys.Length = actualArgTys.Length)
+
+ let inpsAsVars, inpsAsExprs =
+ inpArgTys
+ |> List.mapi (fun j ty -> mkCompGenLocal appm ("arg" + string i + string j) ty)
+ |> List.unzip
+
+ let inpsAsActualArg = CoerceDetupled inpArgTys inpsAsExprs actualArgTys
+ let inpCloVarType = mkFunTy g (mkRefTupledTy g actualArgTys) cloVar.Type
+ let newResTy = mkFunTy g inpArgTy resTy
+
+ let inpCloVar, inpCloVarAsExpr =
+ mkCompGenLocal appm ("clo" + string i) inpCloVarType
+
+ let newRes =
+ // For the final arg we can skip introducing the dummy variable
+ if i = N - 1 then
+ mkMultiLambda
+ appm
+ inpsAsVars
+ (mkApps g ((inpCloVarAsExpr, inpCloVarType), [], [ inpsAsActualArg ], appm), resTy)
+ else
+ mkMultiLambda
+ appm
+ inpsAsVars
+ (mkCompGenLet
+ appm
+ cloVar
+ (mkApps g ((inpCloVarAsExpr, inpCloVarType), [], [ inpsAsActualArg ], appm))
+ res,
+ resTy)
+
+ inpCloVar, newRes, newResTy)
+ argTysWithoutNiceNames
+ (resVar, resVarAsExpr, retTy)
+
+ let exprForAllArgs =
+ if isNil argTysWithNiceNames then
+ mkCompGenLet appm cloVar exprWithActualTy exprForOtherArgs
+ else
+ // Mark the up as Some/None
+ let suppliedArgs =
+ List.map Some suppliedArgs
+ @ List.replicate (nCurriedNiceNames - nSuppliedArgs) None
+
+ assert (suppliedArgs.Length = nCurriedNiceNames)
+
+ let lambdaBuilders, binderBuilders, inpsAsArgs =
+
+ (argTysWithNiceNames, curriedNiceNames, suppliedArgs)
+ |||> List.map3 (fun (_, inpArgTy, actualArgTys) niceNames suppliedArg ->
+
+ let inpArgTys =
+ match actualArgTys with
+ | [ _ ] -> [ inpArgTy ]
+ | _ -> destRefTupleTy g inpArgTy
+
+ /// Note: there might not be enough nice names, and they might not match in arity
+ let niceNames =
+ match niceNames with
+ | nms when nms.Length = inpArgTys.Length -> nms
+ | [ nm ] -> inpArgTys |> List.mapi (fun i _ -> (nm + string i))
+ | nms -> nms
+
+ match suppliedArg with
+ | Some arg ->
+ let binderBuilder, inpsAsActualArg = CoerceTupled niceNames arg actualArgTys
+ let lambdaBuilder = id
+ lambdaBuilder, binderBuilder, inpsAsActualArg
+ | None ->
+ let inpsAsVars, inpsAsExprs =
+ (niceNames, inpArgTys)
+ ||> List.map2 (fun nm ty -> mkCompGenLocal appm nm ty)
+ |> List.unzip
+
+ let inpsAsActualArg = CoerceDetupled inpArgTys inpsAsExprs actualArgTys
+ let lambdaBuilder = (fun tm -> mkMultiLambda appm inpsAsVars (tm, tyOfExpr g tm))
+ let binderBuilder = id
+ lambdaBuilder, binderBuilder, inpsAsActualArg)
+ |> List.unzip3
+
+ // If no trailing args then we can skip introducing the dummy variable
+ // This corresponds to
+ // let f (x: A) = 1
+ //
+ // f ~~> type B -> int
+ //
+ // giving
+ // (fun b -> f (b :> A))
+ // rather than
+ // (fun b -> let clo = f (b :> A) in clo)
+ let exprApp =
+ if isNil argTysWithoutNiceNames then
+ mkApps g ((exprWithActualTy, actualTy), [], inpsAsArgs, appm)
+ else
+ mkCompGenLet appm cloVar (mkApps g ((exprWithActualTy, actualTy), [], inpsAsArgs, appm)) exprForOtherArgs
+
+ List.foldBack (fun f acc -> f acc) binderBuilders (List.foldBack (fun f acc -> f acc) lambdaBuilders exprApp)
+
+ Some(exprForAllArgs, droppedSuppliedArgs)
+ | _ -> None
+
+ /// Find and make all subsumption eliminations
+ let NormalizeAndAdjustPossibleSubsumptionExprs g inputExpr =
+ let expr, args =
+ // AdjustPossibleSubsumptionExpr can take into account an application
+ match stripExpr inputExpr with
+ | Expr.App(f, _fty, [], args, _) -> f, args
+
+ | _ -> inputExpr, []
+
+ match AdjustPossibleSubsumptionExpr g expr args with
+ | None -> inputExpr
+ | Some(exprR, []) -> exprR
+ | Some(exprR, argsR) ->
+ //printfn "adjusted...."
+ Expr.App(exprR, tyOfExpr g exprR, [], argsR, inputExpr.Range)
+
+ //---------------------------------------------------------------------------
+ // LinearizeTopMatch - when only one non-failing target, make linear. The full
+ // complexity of this is only used for spectacularly rare bindings such as
+ // type ('a, 'b) either = This of 'a | That of 'b
+ // let this_f1 = This (fun x -> x)
+ // let This fA | That fA = this_f1
+ //
+ // Here a polymorphic top level binding "fA" is _computed_ by a pattern match!!!
+ // The TAST coming out of type checking must, however, define fA as a type function,
+ // since it is marked with an arity that indicates it's r.h.s. is a type function]
+ // without side effects and so can be compiled as a generic method (for example).
+
+ // polymorphic things bound in complex matches at top level require eta expansion of the
+ // type function to ensure the r.h.s. of the binding is indeed a type function
+ let etaExpandTypeLambda g m tps (tm, ty) =
+ if isNil tps then
+ tm
+ else
+ mkTypeLambda m tps (mkApps g ((tm, ty), [ (List.map mkTyparTy tps) ], [], m), ty)
+
+ let AdjustValToHaveValReprInfo (tmp: Val) parent valData =
+ tmp.SetValReprInfo(Some valData)
+ tmp.SetDeclaringEntity parent
+ tmp.SetIsMemberOrModuleBinding()
+
+ let destInt32 =
+ function
+ | Expr.Const(Const.Int32 n, _, _) -> Some n
+ | _ -> None
+
+ let destThrow =
+ function
+ | Expr.Op(TOp.ILAsm([ I_throw ], [ ty2 ]), [], [ e ], m) -> Some(m, ty2, e)
+ | _ -> None
+
+ let isThrow x = Option.isSome (destThrow x)
+
+ let isIDelegateEventType g ty =
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> tyconRefEq g g.fslib_IDelegateEvent_tcr tcref
+ | _ -> false
+
+ let destIDelegateEventType g ty =
+ if isIDelegateEventType g ty then
+ match argsOfAppTy g ty with
+ | [ ty1 ] -> ty1
+ | _ -> failwith "destIDelegateEventType: internal error"
+ else
+ failwith "destIDelegateEventType: not an IDelegateEvent type"
+
+ /// For match with only one non-failing target T0, the other targets, T1... failing (say, raise exception).
+ /// tree, T0(v0, .., vN) => rhs ; T1() => fail ; ...
+ /// Convert it to bind T0's variables, then continue with T0's rhs:
+ /// let tmp = switch tree, TO(fv0, ..., fvN) => Tup (fv0, ..., fvN) ; T1() => fail; ...
+ /// let v1 = #1 tmp in ...
+ /// and vN = #N tmp
+ /// rhs
+ /// Motivation:
+ /// - For top-level let bindings with possibly failing matches,
+ /// this makes clear that subsequent bindings (if reached) are top-level ones.
+ let LinearizeTopMatchAux g parent (spBind, m, tree, targets, m2, ty) =
+ let targetsL = Array.toList targets
+ (* items* package up 0, 1, more items *)
+ let itemsProj tys i x =
+ match tys with
+ | [] -> failwith "itemsProj: no items?"
+ | [ _ ] -> x (* no projection needed *)
+ | tys -> Expr.Op(TOp.TupleFieldGet(tupInfoRef, i), tys, [ x ], m)
+
+ let isThrowingTarget =
+ function
+ | TTarget(_, x, _) -> isThrow x
+
+ if 1 + List.count isThrowingTarget targetsL = targetsL.Length then
+ // Have failing targets and ONE successful one, so linearize
+ let (TTarget(vs, rhs, _)) = List.find (isThrowingTarget >> not) targetsL
+
+ let fvs =
+ vs
+ |> List.map (fun v -> fst (mkLocal v.Range v.LogicalName v.Type)) (* fresh *)
+
+ let vtys = vs |> List.map (fun v -> v.Type)
+ let tmpTy = mkRefTupledVarsTy g vs
+ let tmp, tmpe = mkCompGenLocal m "matchResultHolder" tmpTy
+
+ AdjustValToHaveValReprInfo tmp parent ValReprInfo.emptyValData
+
+ let newTg = TTarget(fvs, mkRefTupledVars g m fvs, None)
+
+ let fixup (TTarget(tvs, tx, flags)) =
+ match destThrow tx with
+ | Some(m, _, e) ->
+ let tx = mkThrow m tmpTy e
+ TTarget(tvs, tx, flags) (* Throwing targets, recast it's "return type" *)
+ | None -> newTg (* Non-throwing target, replaced [new/old] *)
+
+ let targets = Array.map fixup targets
+
+ let binds =
+ vs
+ |> List.mapi (fun i v ->
+ let ty = v.Type
+ let rhs = etaExpandTypeLambda g m v.Typars (itemsProj vtys i tmpe, ty)
+ // update the arity of the value
+ v.SetValReprInfo(Some(InferValReprInfoOfExpr g AllowTypeDirectedDetupling.Yes ty [] [] rhs))
+ // This binding is deliberately non-sticky - any sequence point for 'rhs' goes on 'rhs' _after_ the binding has been evaluated
+ mkInvisibleBind v rhs) in (* vi = proj tmp *)
+
+ mkCompGenLet
+ m
+ tmp
+ (primMkMatch (spBind, m, tree, targets, m2, tmpTy)) (* note, probably retyped match, but note, result still has same type *)
+ (mkLetsFromBindings m binds rhs)
+ else
+ (* no change *)
+ primMkMatch (spBind, m, tree, targets, m2, ty)
+
+ let LinearizeTopMatch g parent =
+ function
+ | Expr.Match(spBind, m, tree, targets, m2, ty) -> LinearizeTopMatchAux g parent (spBind, m, tree, targets, m2, ty)
+ | x -> x
+
+ // CLEANUP NOTE: Get rid of this mutation.
+ let ClearValReprInfo (f: Val) =
+ f.SetValReprInfo None
+ f
diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi
new file mode 100644
index 0000000000..ad90c5c818
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi
@@ -0,0 +1,571 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// TypedTreeOps.ExprOps: address-of operations, expression folding, intrinsic call wrappers, and higher-level expression helpers.
+namespace FSharp.Compiler.TypedTreeOps
+
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+open FSharp.Compiler.Syntax
+
+[]
+module internal AddressOps =
+
+ /// An exception representing a warning for a defensive copy of an immutable struct
+ exception DefensiveCopyWarning of string * range
+
+ type Mutates =
+ | AddressOfOp
+ | DefinitelyMutates
+ | PossiblyMutates
+ | NeverMutates
+
+ val isRecdOrStructTyconRefAssumedImmutable: TcGlobals -> TyconRef -> bool
+
+ val isTyconRefReadOnly: TcGlobals -> range -> TyconRef -> bool
+
+ val isRecdOrStructTyconRefReadOnly: TcGlobals -> range -> TyconRef -> bool
+
+ val isRecdOrStructTyReadOnly: TcGlobals -> range -> TType -> bool
+
+ val CanTakeAddressOf: TcGlobals -> range -> bool -> TType -> Mutates -> bool
+
+ val CanTakeAddressOfImmutableVal: TcGlobals -> range -> ValRef -> Mutates -> bool
+
+ val MustTakeAddressOfVal: TcGlobals -> ValRef -> bool
+
+ val MustTakeAddressOfByrefGet: TcGlobals -> ValRef -> bool
+
+ val CanTakeAddressOfByrefGet: TcGlobals -> ValRef -> Mutates -> bool
+
+ val MustTakeAddressOfRecdFieldRef: RecdFieldRef -> bool
+
+ val CanTakeAddressOfRecdFieldRef: TcGlobals -> range -> RecdFieldRef -> TypeInst -> Mutates -> bool
+
+ val CanTakeAddressOfUnionFieldRef: TcGlobals -> range -> UnionCaseRef -> int -> TypeInst -> Mutates -> bool
+
+ /// Helper to create an expression that dereferences an address.
+ val mkDerefAddrExpr: mAddrGet: range -> expr: Expr -> mExpr: range -> exprTy: TType -> Expr
+
+ /// Helper to take the address of an expression
+ val mkExprAddrOfExprAux:
+ TcGlobals ->
+ bool ->
+ bool ->
+ Mutates ->
+ Expr ->
+ ValRef option ->
+ range ->
+ (Val * Expr) option * Expr * bool * bool
+
+ /// Take the address of an expression, or force it into a mutable local. Any allocated
+ /// mutable local may need to be kept alive over a larger expression, hence we return
+ /// a wrapping function that wraps "let mutable loc = Expr in ..." around a larger
+ /// expression.
+ val mkExprAddrOfExpr:
+ TcGlobals -> bool -> bool -> Mutates -> Expr -> ValRef option -> range -> (Expr -> Expr) * Expr * bool * bool
+
+ /// Make an expression that gets an item from a tuple
+ val mkTupleFieldGet: TcGlobals -> TupInfo * Expr * TypeInst * int * range -> Expr
+
+ /// Make an expression that gets an item from an anonymous record
+ val mkAnonRecdFieldGet: TcGlobals -> AnonRecdTypeInfo * Expr * TypeInst * int * range -> Expr
+
+ /// Build an expression representing the read of an instance class or record field.
+ /// First take the address of the record expression if it is a struct.
+ val mkRecdFieldGet: TcGlobals -> Expr * RecdFieldRef * TypeInst * range -> Expr
+
+ /// Like mkUnionCaseFieldGetUnprovenViaExprAddr, but for struct-unions, the input should be a copy of the expression.
+ val mkUnionCaseFieldGetUnproven: TcGlobals -> Expr * UnionCaseRef * TypeInst * int * range -> Expr
+
+[]
+module internal ExprFolding =
+
+ /// Work out what things on the right-hand-side of a 'let rec' recursive binding need to be fixed up
+ val IterateRecursiveFixups:
+ TcGlobals ->
+ Val option ->
+ (Val option -> Expr -> (Expr -> Expr) -> Expr -> unit) ->
+ Expr * (Expr -> Expr) ->
+ Expr ->
+ unit
+
+ /// Combine two static-resolution requirements on a type parameter
+ val JoinTyparStaticReq: TyparStaticReq -> TyparStaticReq -> TyparStaticReq
+
+ /// A set of function parameters (visitor) for folding over expressions
+ type ExprFolder<'State> =
+ { exprIntercept: ('State -> Expr -> 'State) -> ('State -> Expr -> 'State) -> 'State -> Expr -> 'State
+ valBindingSiteIntercept: 'State -> bool * Val -> 'State
+ nonRecBindingsIntercept: 'State -> Binding -> 'State
+ recBindingsIntercept: 'State -> Bindings -> 'State
+ dtreeIntercept: 'State -> DecisionTree -> 'State
+ targetIntercept: ('State -> Expr -> 'State) -> 'State -> DecisionTreeTarget -> 'State option
+ tmethodIntercept: ('State -> Expr -> 'State) -> 'State -> ObjExprMethod -> 'State option }
+
+ /// The empty set of actions for folding over expressions
+ val ExprFolder0: ExprFolder<'State>
+
+ /// Fold over all the expressions in an implementation file
+ val FoldImplFile: ExprFolder<'State> -> 'State -> CheckedImplFile -> 'State
+
+ /// Fold over all the expressions in an expression
+ val FoldExpr: ExprFolder<'State> -> 'State -> Expr -> 'State
+
+#if DEBUG
+ /// Extract some statistics from an expression
+ val ExprStats: Expr -> string
+#endif
+
+[]
+module internal Makers =
+
+ val mkString: TcGlobals -> range -> string -> Expr
+
+ val mkByte: TcGlobals -> range -> byte -> Expr
+
+ val mkUInt16: TcGlobals -> range -> uint16 -> Expr
+
+ val mkUnit: TcGlobals -> range -> Expr
+
+ val mkInt32: TcGlobals -> range -> int32 -> Expr
+
+ val mkInt: TcGlobals -> range -> int -> Expr
+
+ val mkZero: TcGlobals -> range -> Expr
+
+ val mkOne: TcGlobals -> range -> Expr
+
+ val mkTwo: TcGlobals -> range -> Expr
+
+ val mkMinusOne: TcGlobals -> range -> Expr
+
+ /// Makes an expression holding a constant 0 value of the given numeric type.
+ val mkTypedZero: g: TcGlobals -> m: range -> ty: TType -> Expr
+
+ /// Makes an expression holding a constant 1 value of the given numeric type.
+ val mkTypedOne: g: TcGlobals -> m: range -> ty: TType -> Expr
+
+ val mkRefCellContentsRef: TcGlobals -> RecdFieldRef
+
+ val mkSequential: range -> Expr -> Expr -> Expr
+
+ val mkThenDoSequential: range -> expr: Expr -> stmt: Expr -> Expr
+
+ val mkCompGenSequential: range -> stmt: Expr -> expr: Expr -> Expr
+
+ val mkCompGenThenDoSequential: range -> expr: Expr -> stmt: Expr -> Expr
+
+ val mkSequentials: TcGlobals -> range -> Exprs -> Expr
+
+ val mkGetArg0: range -> TType -> Expr
+
+ val mkAnyTupled: TcGlobals -> range -> TupInfo -> Exprs -> TType list -> Expr
+
+ val mkRefTupled: TcGlobals -> range -> Exprs -> TType list -> Expr
+
+ val mkRefTupledNoTypes: TcGlobals -> range -> Exprs -> Expr
+
+ val mkRefTupledVars: TcGlobals -> range -> Val list -> Expr
+
+ val mkRecordExpr:
+ TcGlobals -> RecordConstructionInfo * TyconRef * TypeInst * RecdFieldRef list * Exprs * range -> Expr
+
+ val mkAnonRecd: TcGlobals -> range -> AnonRecdTypeInfo -> Ident[] -> Exprs -> TType list -> Expr
+
+ val mkRefCell: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkRefCellGet: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkRefCellSet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkNil: TcGlobals -> range -> TType -> Expr
+
+ val mkCons: TcGlobals -> TType -> Expr -> Expr -> Expr
+
+ val mkArray: TType * Exprs * range -> Expr
+
+ val mkCompGenLocalAndInvisibleBind: TcGlobals -> string -> range -> Expr -> Val * Expr * Binding
+
+ val mkUnbox: TType -> Expr -> range -> Expr
+
+ val mkBox: TType -> Expr -> range -> Expr
+
+ val mkIsInst: TType -> Expr -> range -> Expr
+
+ val mspec_Type_GetTypeFromHandle: TcGlobals -> ILMethodSpec
+
+ val fspec_Missing_Value: TcGlobals -> ILFieldSpec
+
+ val mkInitializeArrayMethSpec: TcGlobals -> ILMethodSpec
+
+ val mkInvalidCastExnNewobj: TcGlobals -> ILInstr
+
+ val mkCallNewFormat:
+ TcGlobals -> range -> TType -> TType -> TType -> TType -> TType -> formatStringExpr: Expr -> Expr
+
+ val mkCallGetGenericComparer: TcGlobals -> range -> Expr
+
+ val mkCallGetGenericEREqualityComparer: TcGlobals -> range -> Expr
+
+ val mkCallGetGenericPEREqualityComparer: TcGlobals -> range -> Expr
+
+ val mkCallUnbox: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallUnboxFast: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallTypeTest: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallTypeOf: TcGlobals -> range -> TType -> Expr
+
+ val mkCallTypeDefOf: TcGlobals -> range -> TType -> Expr
+
+ val mkCallDispose: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallSeq: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallCreateInstance: TcGlobals -> range -> TType -> Expr
+
+ val mkCallGetQuerySourceAsEnumerable: TcGlobals -> range -> TType -> TType -> Expr -> Expr
+
+ val mkCallNewQuerySource: TcGlobals -> range -> TType -> TType -> Expr -> Expr
+
+ val mkCallCreateEvent: TcGlobals -> range -> TType -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallGenericComparisonWithComparerOuter: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallGenericEqualityEROuter: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallGenericEqualityWithComparerOuter: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallGenericHashWithComparerOuter: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallEqualsOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallNotEqualsOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallLessThanOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallLessThanOrEqualsOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallGreaterThanOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallGreaterThanOrEqualsOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallAdditionOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSubtractionOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallMultiplyOperator: TcGlobals -> range -> ty1: TType -> ty2: TType -> retTy: TType -> Expr -> Expr -> Expr
+
+ val mkCallDivisionOperator: TcGlobals -> range -> ty1: TType -> ty2: TType -> retTy: TType -> Expr -> Expr -> Expr
+
+ val mkCallModulusOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallDefaultOf: TcGlobals -> range -> TType -> Expr
+
+ val mkCallBitwiseAndOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallBitwiseOrOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallBitwiseXorOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallShiftLeftOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallShiftRightOperator: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallUnaryNegOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallUnaryNotOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallAdditionChecked: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSubtractionChecked: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallMultiplyChecked: TcGlobals -> range -> ty1: TType -> ty2: TType -> retTy: TType -> Expr -> Expr -> Expr
+
+ val mkCallUnaryNegChecked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToByteChecked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToSByteChecked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToInt16Checked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUInt16Checked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToIntChecked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToInt32Checked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUInt32Checked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToInt64Checked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUInt64Checked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToIntPtrChecked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUIntPtrChecked: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToByteOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToSByteOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToInt16Operator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUInt16Operator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToInt32Operator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUInt32Operator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToInt64Operator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUInt64Operator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToSingleOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToDoubleOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToIntPtrOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToUIntPtrOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToCharOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallToEnumOperator: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallArrayLength: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallArrayGet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallArray2DGet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallArray3DGet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallArray4DGet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallArraySet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallArray2DSet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallArray3DSet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallArray4DSet: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallHash: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallBox: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallIsNull: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallRaise: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallNewDecimal: TcGlobals -> range -> Expr * Expr * Expr * Expr * Expr -> Expr
+
+ val tryMkCallBuiltInWitness: TcGlobals -> TraitConstraintInfo -> Expr list -> range -> Expr option
+
+ val tryMkCallCoreFunctionAsBuiltInWitness:
+ TcGlobals -> IntrinsicValRef -> TType list -> Expr list -> range -> Expr option
+
+ val TryEliminateDesugaredConstants: TcGlobals -> range -> Const -> Expr option
+
+ val mkCallSeqCollect: TcGlobals -> range -> TType -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSeqUsing: TcGlobals -> range -> TType -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSeqDelay: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallSeqAppend: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSeqGenerated: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSeqFinally: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSeqTryWith: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallSeqOfFunctions: TcGlobals -> range -> TType -> TType -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallSeqToArray: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallSeqToList: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallSeqMap: TcGlobals -> range -> TType -> TType -> Expr -> Expr -> Expr
+
+ val mkCallSeqSingleton: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallSeqEmpty: TcGlobals -> range -> TType -> Expr
+
+ /// Make a call to the 'isprintf' function for string interpolation
+ val mkCall_sprintf: g: TcGlobals -> m: range -> funcTy: TType -> fmtExpr: Expr -> fillExprs: Expr list -> Expr
+
+ val mkCallDeserializeQuotationFSharp20Plus: TcGlobals -> range -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallDeserializeQuotationFSharp40Plus: TcGlobals -> range -> Expr -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkCallCastQuotation: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallLiftValue: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallLiftValueWithName: TcGlobals -> range -> TType -> string -> Expr -> Expr
+
+ val mkCallLiftValueWithDefn: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallCheckThis: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkCallFailInit: TcGlobals -> range -> Expr
+
+ val mkCallFailStaticInit: TcGlobals -> range -> Expr
+
+ val mkCallQuoteToLinqLambdaExpression: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkOptionToNullable: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkOptionDefaultValue: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkLazyDelayed: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkLazyForce: TcGlobals -> range -> TType -> Expr -> Expr
+
+ val mkGetString: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ val mkGetStringChar: (TcGlobals -> range -> Expr -> Expr -> Expr)
+
+ val mkGetStringLength: TcGlobals -> range -> Expr -> Expr
+
+ val mkStaticCall_String_Concat2: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ val mkStaticCall_String_Concat3: TcGlobals -> range -> Expr -> Expr -> Expr -> Expr
+
+ val mkStaticCall_String_Concat4: TcGlobals -> range -> Expr -> Expr -> Expr -> Expr -> Expr
+
+ val mkStaticCall_String_Concat_Array: TcGlobals -> range -> Expr -> Expr
+
+ val mkDecr: TcGlobals -> range -> Expr -> Expr
+
+ val mkIncr: TcGlobals -> range -> Expr -> Expr
+
+ val mkLdlen: TcGlobals -> range -> Expr -> Expr
+
+ val mkLdelem: TcGlobals -> range -> TType -> Expr -> Expr -> Expr
+
+ val mkILAsmCeq: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ val mkILAsmClt: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ val mkNull: range -> TType -> Expr
+
+ val mkThrow: range -> TType -> Expr -> Expr
+
+ val mkReraiseLibCall: TcGlobals -> TType -> range -> Expr
+
+ val mkReraise: range -> TType -> Expr
+
+ /// Add a label to use as the target for a goto
+ val mkLabelled: range -> ILCodeLabel -> Expr -> Expr
+
+ val mkNullTest: TcGlobals -> range -> Expr -> Expr -> Expr -> Expr
+
+ val mkNonNullTest: TcGlobals -> range -> Expr -> Expr
+
+ val mkNonNullCond: TcGlobals -> range -> TType -> Expr -> Expr -> Expr -> Expr
+
+ /// Build an if-then statement
+ val mkIfThen: TcGlobals -> range -> Expr -> Expr -> Expr
+
+ /// Build the application of a (possibly generic, possibly curried) function value to a set of type and expression arguments
+ val primMkApp: Expr * TType -> TypeInst -> Exprs -> range -> Expr
+
+ /// Build the application of a (possibly generic, possibly curried) function value to a set of type and expression arguments.
+ /// Reduce the application via let-bindings if the function value is a lambda expression.
+ val mkApps: TcGlobals -> (Expr * TType) * TType list list * Exprs * range -> Expr
+
+ val mkExprAppAux: TcGlobals -> Expr -> TType -> Exprs -> range -> Expr
+
+ val mkAppsAux: TcGlobals -> Expr -> TType -> TType list list -> Exprs -> range -> Expr
+
+ /// Build the application of a generic construct to a set of type arguments.
+ /// Reduce the application via substitution if the function value is a typed lambda expression.
+ val mkTyAppExpr: range -> Expr * TType -> TType list -> Expr
+
+ val mkUnionCaseTest: TcGlobals -> Expr * UnionCaseRef * TypeInst * range -> Expr
+
+[]
+module internal ExprTransforms =
+
+ /// Given a lambda expression taking multiple variables, build a corresponding lambda taking a tuple
+ val MultiLambdaToTupledLambda: TcGlobals -> Val list -> Expr -> Val * Expr
+
+ /// Given a lambda expression, adjust it to have be one or two lambda expressions (fun a -> (fun b -> ...))
+ /// where the first has the given arguments.
+ val AdjustArityOfLambdaBody: TcGlobals -> int -> Val list -> Expr -> Val list * Expr
+
+ /// Make an application expression, doing beta reduction by introducing let-bindings
+ /// if the function expression is a construction of a lambda
+ val MakeApplicationAndBetaReduce: TcGlobals -> Expr * TType * TypeInst list * Exprs * range -> Expr
+
+ /// Make a delegate invoke expression for an F# delegate type, doing beta reduction by introducing let-bindings
+ /// if the delegate expression is a construction of a delegate.
+ val MakeFSharpDelegateInvokeAndTryBetaReduce:
+ TcGlobals ->
+ delInvokeRef: Expr * delExpr: Expr * delInvokeTy: TType * tyargs: TypeInst * delInvokeArg: Expr * m: range ->
+ Expr
+
+ val MakeArgsForTopArgs: TcGlobals -> range -> (TType * ArgReprInfo) list list -> TyparInstantiation -> Val list list
+
+ val AdjustValForExpectedValReprInfo: TcGlobals -> range -> ValRef -> ValUseFlag -> ValReprInfo -> Expr * TType
+
+ val AdjustValToHaveValReprInfo: Val -> ParentRef -> ValReprInfo -> unit
+
+ val stripTupledFunTy: TcGlobals -> TType -> TType list list * TType
+
+ []
+ val (|ExprValWithPossibleTypeInst|_|): Expr -> (ValRef * ValUseFlag * TypeInst * range) voption
+
+ val mkCoerceIfNeeded: TcGlobals -> TType -> TType -> Expr -> Expr
+
+ val mkCompGenLetIn: range -> string -> TType -> Expr -> (Val * Expr -> Expr) -> Expr
+
+ val mkCompGenLetMutableIn: range -> string -> TType -> Expr -> (Val * Expr -> Expr) -> Expr
+
+ val AdjustPossibleSubsumptionExpr: TcGlobals -> Expr -> Exprs -> (Expr * Exprs) option
+
+ val NormalizeAndAdjustPossibleSubsumptionExprs: TcGlobals -> Expr -> Expr
+
+ val LinearizeTopMatch: TcGlobals -> ParentRef -> Expr -> Expr
+
+ val etaExpandTypeLambda: TcGlobals -> range -> Typars -> Expr * TType -> Expr
+
+ []
+ val (|NewDelegateExpr|_|): TcGlobals -> Expr -> (Unique * Val list * Expr * range * (Expr -> Expr)) voption
+
+ []
+ val (|DelegateInvokeExpr|_|): TcGlobals -> Expr -> (Expr * TType * TypeInst * Expr * Expr * range) voption
+
+ []
+ val (|OpPipeRight|_|): TcGlobals -> Expr -> (TType * Expr * Expr * range) voption
+
+ []
+ val (|OpPipeRight2|_|): TcGlobals -> Expr -> (TType * Expr * Expr * Expr * range) voption
+
+ []
+ val (|OpPipeRight3|_|): TcGlobals -> Expr -> (TType * Expr * Expr * Expr * Expr * range) voption
+
+ /// Mutate a value to indicate it should be considered a local rather than a module-bound definition
+ // REVIEW: this mutation should not be needed
+ val ClearValReprInfo: Val -> Val
+
+ val destInt32: Expr -> int32 option
+
+ val destThrow: Expr -> (range * TType * Expr) option
+
+ val isThrow: Expr -> bool
+
+ val isIDelegateEventType: TcGlobals -> TType -> bool
+
+ val destIDelegateEventType: TcGlobals -> TType -> TType
diff --git a/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs
new file mode 100644
index 0000000000..2c84aeb7b7
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs
@@ -0,0 +1,1552 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// Defines derived expression manipulation and construction functions.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal FreeTypeVars =
+
+ //---------------------------------------------------------------------------
+ // Find all type variables in a type, apart from those that have had
+ // an equation assigned by type inference.
+ //---------------------------------------------------------------------------
+
+ let emptyFreeLocals = Zset.empty valOrder
+
+ let unionFreeLocals s1 s2 =
+ if s1 === emptyFreeLocals then s2
+ elif s2 === emptyFreeLocals then s1
+ else Zset.union s1 s2
+
+ let emptyFreeRecdFields = Zset.empty recdFieldRefOrder
+
+ let unionFreeRecdFields s1 s2 =
+ if s1 === emptyFreeRecdFields then s2
+ elif s2 === emptyFreeRecdFields then s1
+ else Zset.union s1 s2
+
+ let emptyFreeUnionCases = Zset.empty unionCaseRefOrder
+
+ let unionFreeUnionCases s1 s2 =
+ if s1 === emptyFreeUnionCases then s2
+ elif s2 === emptyFreeUnionCases then s1
+ else Zset.union s1 s2
+
+ let emptyFreeTycons = Zset.empty tyconOrder
+
+ let unionFreeTycons s1 s2 =
+ if s1 === emptyFreeTycons then s2
+ elif s2 === emptyFreeTycons then s1
+ else Zset.union s1 s2
+
+ let typarOrder =
+ { new IComparer with
+ member x.Compare(v1: Typar, v2: Typar) = compareBy v1 v2 _.Stamp
+ }
+
+ let emptyFreeTypars = Zset.empty typarOrder
+
+ let unionFreeTypars s1 s2 =
+ if s1 === emptyFreeTypars then s2
+ elif s2 === emptyFreeTypars then s1
+ else Zset.union s1 s2
+
+ let emptyFreeTyvars =
+ {
+ FreeTycons = emptyFreeTycons
+ // The summary of values used as trait solutions
+ FreeTraitSolutions = emptyFreeLocals
+ FreeTypars = emptyFreeTypars
+ }
+
+ let isEmptyFreeTyvars ftyvs =
+ Zset.isEmpty ftyvs.FreeTypars && Zset.isEmpty ftyvs.FreeTycons
+
+ let unionFreeTyvars fvs1 fvs2 =
+ if fvs1 === emptyFreeTyvars then
+ fvs2
+ else if fvs2 === emptyFreeTyvars then
+ fvs1
+ else
+ {
+ FreeTycons = unionFreeTycons fvs1.FreeTycons fvs2.FreeTycons
+ FreeTraitSolutions = unionFreeLocals fvs1.FreeTraitSolutions fvs2.FreeTraitSolutions
+ FreeTypars = unionFreeTypars fvs1.FreeTypars fvs2.FreeTypars
+ }
+
+ type FreeVarOptions =
+ {
+ canCache: bool
+ collectInTypes: bool
+ includeLocalTycons: bool
+ includeTypars: bool
+ includeLocalTyconReprs: bool
+ includeRecdFields: bool
+ includeUnionCases: bool
+ includeLocals: bool
+ templateReplacement: ((TyconRef -> bool) * Typars) option
+ stackGuard: StackGuard option
+ }
+
+ member this.WithTemplateReplacement(f, typars) =
+ { this with
+ templateReplacement = Some(f, typars)
+ }
+
+ let CollectAllNoCaching =
+ {
+ canCache = false
+ collectInTypes = true
+ includeLocalTycons = true
+ includeLocalTyconReprs = true
+ includeRecdFields = true
+ includeUnionCases = true
+ includeTypars = true
+ includeLocals = true
+ templateReplacement = None
+ stackGuard = None
+ }
+
+ let CollectTyparsNoCaching =
+ {
+ canCache = false
+ collectInTypes = true
+ includeLocalTycons = false
+ includeTypars = true
+ includeLocalTyconReprs = false
+ includeRecdFields = false
+ includeUnionCases = false
+ includeLocals = false
+ templateReplacement = None
+ stackGuard = None
+ }
+
+ let CollectLocalsNoCaching =
+ {
+ canCache = false
+ collectInTypes = false
+ includeLocalTycons = false
+ includeTypars = false
+ includeLocalTyconReprs = false
+ includeRecdFields = false
+ includeUnionCases = false
+ includeLocals = true
+ templateReplacement = None
+ stackGuard = None
+ }
+
+ let CollectTyparsAndLocalsNoCaching =
+ {
+ canCache = false
+ collectInTypes = true
+ includeLocalTycons = false
+ includeLocalTyconReprs = false
+ includeRecdFields = false
+ includeUnionCases = false
+ includeTypars = true
+ includeLocals = true
+ templateReplacement = None
+ stackGuard = None
+ }
+
+ let CollectAll =
+ {
+ canCache = false
+ collectInTypes = true
+ includeLocalTycons = true
+ includeLocalTyconReprs = true
+ includeRecdFields = true
+ includeUnionCases = true
+ includeTypars = true
+ includeLocals = true
+ templateReplacement = None
+ stackGuard = None
+ }
+
+ let CollectTyparsAndLocalsImpl stackGuardOpt = // CollectAll
+ {
+ canCache = true // only cache for this one
+ collectInTypes = true
+ includeTypars = true
+ includeLocals = true
+ includeLocalTycons = false
+ includeLocalTyconReprs = false
+ includeRecdFields = false
+ includeUnionCases = false
+ templateReplacement = None
+ stackGuard = stackGuardOpt
+ }
+
+ let CollectTyparsAndLocals = CollectTyparsAndLocalsImpl None
+
+ let CollectTypars = CollectTyparsAndLocals
+
+ let CollectLocals = CollectTyparsAndLocals
+
+ let CollectTyparsAndLocalsWithStackGuard () =
+ let stackGuard = StackGuard("AccFreeVarsStackGuardDepth")
+ CollectTyparsAndLocalsImpl(Some stackGuard)
+
+ let CollectLocalsWithStackGuard () = CollectTyparsAndLocalsWithStackGuard()
+
+ let accFreeLocalTycon opts x acc =
+ if not opts.includeLocalTycons then
+ acc
+ else if Zset.contains x acc.FreeTycons then
+ acc
+ else
+ { acc with
+ FreeTycons = Zset.add x acc.FreeTycons
+ }
+
+ let rec accFreeTycon opts (tcref: TyconRef) acc =
+ let acc =
+ match opts.templateReplacement with
+ | Some(isTemplateTyconRef, cloFreeTyvars) when isTemplateTyconRef tcref ->
+ let cloInst = List.map mkTyparTy cloFreeTyvars
+ accFreeInTypes opts cloInst acc
+ | _ -> acc
+
+ if not opts.includeLocalTycons then
+ acc
+ elif tcref.IsLocalRef then
+ accFreeLocalTycon opts tcref.ResolvedTarget acc
+ else
+ acc
+
+ and boundTypars opts tps acc =
+ // Bound type vars form a recursively-referential set due to constraints, e.g. A: I, B: I
+ // So collect up free vars in all constraints first, then bind all variables
+ let acc =
+ List.foldBack (fun (tp: Typar) acc -> accFreeInTyparConstraints opts tp.Constraints acc) tps acc
+
+ List.foldBack
+ (fun tp acc ->
+ { acc with
+ FreeTypars = Zset.remove tp acc.FreeTypars
+ })
+ tps
+ acc
+
+ and accFreeInTyparConstraints opts cxs acc =
+ List.foldBack (accFreeInTyparConstraint opts) cxs acc
+
+ and accFreeInTyparConstraint opts tpc acc =
+ match tpc with
+ | TyparConstraint.CoercesTo(ty, _) -> accFreeInType opts ty acc
+ | TyparConstraint.MayResolveMember(traitInfo, _) -> accFreeInTrait opts traitInfo acc
+ | TyparConstraint.DefaultsTo(_, defaultTy, _) -> accFreeInType opts defaultTy acc
+ | TyparConstraint.SimpleChoice(tys, _) -> accFreeInTypes opts tys acc
+ | TyparConstraint.IsEnum(underlyingTy, _) -> accFreeInType opts underlyingTy acc
+ | TyparConstraint.IsDelegate(argTys, retTy, _) -> accFreeInType opts argTys (accFreeInType opts retTy acc)
+ | TyparConstraint.SupportsComparison _
+ | TyparConstraint.SupportsEquality _
+ | TyparConstraint.SupportsNull _
+ | TyparConstraint.NotSupportsNull _
+ | TyparConstraint.IsNonNullableStruct _
+ | TyparConstraint.IsReferenceType _
+ | TyparConstraint.IsUnmanaged _
+ | TyparConstraint.AllowsRefStruct _
+ | TyparConstraint.RequiresDefaultConstructor _ -> acc
+
+ and accFreeInTrait opts (TTrait(tys, _, _, argTys, retTy, _, sln)) acc =
+ Option.foldBack
+ (accFreeInTraitSln opts)
+ sln.Value
+ (accFreeInTypes opts tys (accFreeInTypes opts argTys (Option.foldBack (accFreeInType opts) retTy acc)))
+
+ and accFreeInTraitSln opts sln acc =
+ match sln with
+ | ILMethSln(ty, _, _, minst, staticTyOpt) ->
+ Option.foldBack (accFreeInType opts) staticTyOpt (accFreeInType opts ty (accFreeInTypes opts minst acc))
+ | FSMethSln(ty, vref, minst, staticTyOpt) ->
+ Option.foldBack
+ (accFreeInType opts)
+ staticTyOpt
+ (accFreeInType opts ty (accFreeValRefInTraitSln opts vref (accFreeInTypes opts minst acc)))
+ | FSAnonRecdFieldSln(_anonInfo, tinst, _n) -> accFreeInTypes opts tinst acc
+ | FSRecdFieldSln(tinst, _rfref, _isSet) -> accFreeInTypes opts tinst acc
+ | BuiltInSln -> acc
+ | ClosedExprSln _ -> acc // nothing to accumulate because it's a closed expression referring only to erasure of provided method calls
+
+ and accFreeLocalValInTraitSln _opts v fvs =
+ if Zset.contains v fvs.FreeTraitSolutions then
+ fvs
+ else
+ { fvs with
+ FreeTraitSolutions = Zset.add v fvs.FreeTraitSolutions
+ }
+
+ and accFreeValRefInTraitSln opts (vref: ValRef) fvs =
+ if vref.IsLocalRef then
+ accFreeLocalValInTraitSln opts vref.ResolvedTarget fvs
+ else
+ // non-local values do not contain free variables
+ fvs
+
+ and accFreeTyparRef opts (tp: Typar) acc =
+ if not opts.includeTypars then
+ acc
+ else if Zset.contains tp acc.FreeTypars then
+ acc
+ else
+ accFreeInTyparConstraints
+ opts
+ tp.Constraints
+ { acc with
+ FreeTypars = Zset.add tp acc.FreeTypars
+ }
+
+ and accFreeInType opts ty acc =
+ match stripTyparEqns ty with
+ | TType_tuple(tupInfo, l) -> accFreeInTypes opts l (accFreeInTupInfo opts tupInfo acc)
+
+ | TType_anon(anonInfo, l) -> accFreeInTypes opts l (accFreeInTupInfo opts anonInfo.TupInfo acc)
+
+ | TType_app(tcref, tinst, _) ->
+ let acc = accFreeTycon opts tcref acc
+
+ match tinst with
+ | [] -> acc // optimization to avoid unneeded call
+ | [ h ] -> accFreeInType opts h acc // optimization to avoid unneeded call
+ | _ -> accFreeInTypes opts tinst acc
+
+ | TType_ucase(UnionCaseRef(tcref, _), tinst) -> accFreeInTypes opts tinst (accFreeTycon opts tcref acc)
+
+ | TType_fun(domainTy, rangeTy, _) -> accFreeInType opts domainTy (accFreeInType opts rangeTy acc)
+
+ | TType_var(r, _) -> accFreeTyparRef opts r acc
+
+ | TType_forall(tps, r) -> unionFreeTyvars (boundTypars opts tps (freeInType opts r)) acc
+
+ | TType_measure unt -> accFreeInMeasure opts unt acc
+
+ and accFreeInTupInfo _opts unt acc =
+ match unt with
+ | TupInfo.Const _ -> acc
+
+ and accFreeInMeasure opts unt acc =
+ List.foldBack (fun (tp, _) acc -> accFreeTyparRef opts tp acc) (ListMeasureVarOccsWithNonZeroExponents unt) acc
+
+ and accFreeInTypes opts tys acc =
+ match tys with
+ | [] -> acc
+ | h :: t -> accFreeInTypes opts t (accFreeInType opts h acc)
+
+ and freeInType opts ty = accFreeInType opts ty emptyFreeTyvars
+
+ and accFreeInVal opts (v: Val) acc = accFreeInType opts v.val_type acc
+
+ let freeInTypes opts tys = accFreeInTypes opts tys emptyFreeTyvars
+ let freeInVal opts v = accFreeInVal opts v emptyFreeTyvars
+
+ let freeInTyparConstraints opts v =
+ accFreeInTyparConstraints opts v emptyFreeTyvars
+
+ let accFreeInTypars opts tps acc =
+ List.foldBack (accFreeTyparRef opts) tps acc
+
+ let rec addFreeInModuleTy (mtyp: ModuleOrNamespaceType) acc =
+ QueueList.foldBack
+ (typeOfVal >> accFreeInType CollectAllNoCaching)
+ mtyp.AllValsAndMembers
+ (QueueList.foldBack
+ (fun (mspec: ModuleOrNamespace) acc -> addFreeInModuleTy mspec.ModuleOrNamespaceType acc)
+ mtyp.AllEntities
+ acc)
+
+ let freeInModuleTy mtyp = addFreeInModuleTy mtyp emptyFreeTyvars
+
+ //--------------------------------------------------------------------------
+ // Free in type, left-to-right order preserved. This is used to determine the
+ // order of type variables for top-level definitions based on their signature,
+ // so be careful not to change the order. We accumulate in reverse
+ // order.
+ //--------------------------------------------------------------------------
+
+ let emptyFreeTyparsLeftToRight = []
+
+ let unionFreeTyparsLeftToRight fvs1 fvs2 =
+ ListSet.unionFavourRight typarEq fvs1 fvs2
+
+ let rec boundTyparsLeftToRight g cxFlag thruFlag acc tps =
+ // Bound type vars form a recursively-referential set due to constraints, e.g. A: I, B: I
+ // So collect up free vars in all constraints first, then bind all variables
+ List.fold (fun acc (tp: Typar) -> accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc tp.Constraints) tps acc
+
+ and accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc cxs =
+ List.fold (accFreeInTyparConstraintLeftToRight g cxFlag thruFlag) acc cxs
+
+ and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc =
+ match tpc with
+ | TyparConstraint.CoercesTo(ty, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc ty
+ | TyparConstraint.MayResolveMember(traitInfo, _) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo
+ | TyparConstraint.DefaultsTo(_, defaultTy, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc defaultTy
+ | TyparConstraint.SimpleChoice(tys, _) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tys
+ | TyparConstraint.IsEnum(underlyingTy, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc underlyingTy
+ | TyparConstraint.IsDelegate(argTys, retTy, _) ->
+ accFreeInTypeLeftToRight g cxFlag thruFlag (accFreeInTypeLeftToRight g cxFlag thruFlag acc argTys) retTy
+ | TyparConstraint.SupportsComparison _
+ | TyparConstraint.SupportsEquality _
+ | TyparConstraint.SupportsNull _
+ | TyparConstraint.NotSupportsNull _
+ | TyparConstraint.IsNonNullableStruct _
+ | TyparConstraint.IsUnmanaged _
+ | TyparConstraint.AllowsRefStruct _
+ | TyparConstraint.IsReferenceType _
+ | TyparConstraint.RequiresDefaultConstructor _ -> acc
+
+ and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(tys, _, _, argTys, retTy, _, _)) =
+ let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc tys
+ let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc argTys
+ let acc = Option.fold (accFreeInTypeLeftToRight g cxFlag thruFlag) acc retTy
+ acc
+
+ and accFreeTyparRefLeftToRight g cxFlag thruFlag acc (tp: Typar) =
+ if ListSet.contains typarEq tp acc then
+ acc
+ else
+ let acc = ListSet.insert typarEq tp acc
+
+ if cxFlag then
+ accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc tp.Constraints
+ else
+ acc
+
+ and accFreeInTypeLeftToRight g cxFlag thruFlag acc ty =
+ match (if thruFlag then stripTyEqns g ty else stripTyparEqns ty) with
+ | TType_anon(anonInfo, anonTys) ->
+ let acc = accFreeInTupInfoLeftToRight g cxFlag thruFlag acc anonInfo.TupInfo
+ accFreeInTypesLeftToRight g cxFlag thruFlag acc anonTys
+
+ | TType_tuple(tupInfo, tupTys) ->
+ let acc = accFreeInTupInfoLeftToRight g cxFlag thruFlag acc tupInfo
+ accFreeInTypesLeftToRight g cxFlag thruFlag acc tupTys
+
+ | TType_app(_, tinst, _) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst
+
+ | TType_ucase(_, tinst) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst
+
+ | TType_fun(domainTy, rangeTy, _) ->
+ let dacc = accFreeInTypeLeftToRight g cxFlag thruFlag acc domainTy
+ accFreeInTypeLeftToRight g cxFlag thruFlag dacc rangeTy
+
+ | TType_var(r, _) -> accFreeTyparRefLeftToRight g cxFlag thruFlag acc r
+
+ | TType_forall(tps, r) ->
+ let racc = accFreeInTypeLeftToRight g cxFlag thruFlag emptyFreeTyparsLeftToRight r
+ unionFreeTyparsLeftToRight (boundTyparsLeftToRight g cxFlag thruFlag tps racc) acc
+
+ | TType_measure unt ->
+ let mvars = ListMeasureVarOccsWithNonZeroExponents unt
+ List.foldBack (fun (tp, _) acc -> accFreeTyparRefLeftToRight g cxFlag thruFlag acc tp) mvars acc
+
+ and accFreeInTupInfoLeftToRight _g _cxFlag _thruFlag acc unt =
+ match unt with
+ | TupInfo.Const _ -> acc
+
+ and accFreeInTypesLeftToRight g cxFlag thruFlag acc tys =
+ match tys with
+ | [] -> acc
+ | h :: t -> accFreeInTypesLeftToRight g cxFlag thruFlag (accFreeInTypeLeftToRight g cxFlag thruFlag acc h) t
+
+ let freeInTypeLeftToRight g thruFlag ty =
+ accFreeInTypeLeftToRight g true thruFlag emptyFreeTyparsLeftToRight ty
+ |> List.rev
+
+ let freeInTypesLeftToRight g thruFlag ty =
+ accFreeInTypesLeftToRight g true thruFlag emptyFreeTyparsLeftToRight ty
+ |> List.rev
+
+ let freeInTypesLeftToRightSkippingConstraints g ty =
+ accFreeInTypesLeftToRight g false true emptyFreeTyparsLeftToRight ty |> List.rev
+
+[]
+module internal MemberRepresentation =
+
+ //--------------------------------------------------------------------------
+ // Values representing member functions on F# types
+ //--------------------------------------------------------------------------
+
+ // Pull apart the type for an F# value that represents an object model method. Do not strip off a 'unit' argument.
+ // Review: Should GetMemberTypeInFSharpForm have any other direct callers?
+ let GetMemberTypeInFSharpForm g (memberFlags: SynMemberFlags) arities ty m =
+ let tps, argInfos, retTy, retInfo = GetValReprTypeInFSharpForm g arities ty m
+
+ let argInfos =
+ if memberFlags.IsInstance then
+ match argInfos with
+ | [] ->
+ errorR (InternalError("value does not have a valid member type", m))
+ argInfos
+ | _ :: t -> t
+ else
+ argInfos
+
+ tps, argInfos, retTy, retInfo
+
+ // Check that an F# value represents an object model method.
+ // It will also always have an arity (inferred from syntax).
+ let checkMemberVal membInfo arity m =
+ match membInfo, arity with
+ | None, _ -> error (InternalError("checkMemberVal - no membInfo", m))
+ | _, None -> error (InternalError("checkMemberVal - no arity", m))
+ | Some membInfo, Some arity -> (membInfo, arity)
+
+ let checkMemberValRef (vref: ValRef) =
+ checkMemberVal vref.MemberInfo vref.ValReprInfo vref.Range
+
+ let GetFSharpViewOfReturnType (g: TcGlobals) retTy =
+ match retTy with
+ | None -> g.unit_ty
+ | Some retTy -> retTy
+
+ type TraitConstraintInfo with
+ member traitInfo.GetReturnType(g: TcGlobals) =
+ GetFSharpViewOfReturnType g traitInfo.CompiledReturnType
+
+ member traitInfo.GetObjectType() =
+ match traitInfo.MemberFlags.IsInstance, traitInfo.CompiledObjectAndArgumentTypes with
+ | true, objTy :: _ -> Some objTy
+ | _ -> None
+
+ // For static property traits:
+ // ^T: (static member Zero: ^T)
+ // The inner representation is
+ // TraitConstraintInfo([^T], get_Zero, Property, Static, [], ^T)
+ // and this returns
+ // []
+ //
+ // For the logically equivalent static get_property traits (i.e. the property as a get_ method)
+ // ^T: (static member get_Zero: unit -> ^T)
+ // The inner representation is
+ // TraitConstraintInfo([^T], get_Zero, Member, Static, [], ^T)
+ // and this returns
+ // []
+ //
+ // For instance property traits
+ // ^T: (member Length: int)
+ // The inner TraitConstraintInfo representation is
+ // TraitConstraintInfo([^T], get_Length, Property, Instance, [], int)
+ // and this returns
+ // []
+ //
+ // For the logically equivalent instance get_property traits (i.e. the property as a get_ method)
+ // ^T: (member get_Length: unit -> int)
+ // The inner TraitConstraintInfo representation is
+ // TraitConstraintInfo([^T], get_Length, Method, Instance, [^T], int)
+ // and this returns
+ // []
+ //
+ // For index property traits
+ // ^T: (member Item: int -> int with get)
+ // The inner TraitConstraintInfo representation is
+ // TraitConstraintInfo([^T], get_Item, Property, Instance, [^T; int], int)
+ // and this returns
+ // [int]
+ member traitInfo.GetCompiledArgumentTypes() =
+ match traitInfo.MemberFlags.IsInstance, traitInfo.CompiledObjectAndArgumentTypes with
+ | true, _ :: argTys -> argTys
+ | _, argTys -> argTys
+
+ // For static property traits:
+ // ^T: (static member Zero: ^T)
+ // The inner representation is
+ // TraitConstraintInfo([^T], get_Zero, PropertyGet, Static, [], ^T)
+ // and this returns
+ // []
+ //
+ // For the logically equivalent static get_property traits (i.e. the property as a get_ method)
+ // ^T: (static member get_Zero: unit -> ^T)
+ // The inner representation is
+ // TraitConstraintInfo([^T], get_Zero, Member, Static, [], ^T)
+ // and this returns
+ // [unit]
+ //
+ // For instance property traits
+ // ^T: (member Length: int)
+ // The inner TraitConstraintInfo representation is
+ // TraitConstraintInfo([^T], get_Length, PropertyGet, Instance, [^T], int)
+ // and this views the constraint as if it were
+ // []
+ //
+ // For the logically equivalent instance get_property traits (i.e. the property as a get_ method)
+ // ^T: (member get_Length: unit -> int)
+ // The inner TraitConstraintInfo representation is
+ // TraitConstraintInfo([^T], get_Length, Member, Instance, [^T], int)
+ // and this returns
+ // [unit]
+ //
+ // For index property traits
+ // (member Item: int -> int with get)
+ // The inner TraitConstraintInfo representation is
+ // TraitConstraintInfo([^T], get_Item, PropertyGet, [^T; int], int)
+ // and this returns
+ // [int]
+ member traitInfo.GetLogicalArgumentTypes(g: TcGlobals) =
+ match traitInfo.GetCompiledArgumentTypes(), traitInfo.MemberFlags.MemberKind with
+ | [], SynMemberKind.Member -> [ g.unit_ty ]
+ | argTys, _ -> argTys
+
+ member traitInfo.MemberDisplayNameCore =
+ let traitName0 = traitInfo.MemberLogicalName
+
+ match traitInfo.MemberFlags.MemberKind with
+ | SynMemberKind.PropertyGet
+ | SynMemberKind.PropertySet ->
+ match TryChopPropertyName traitName0 with
+ | Some nm -> nm
+ | None -> traitName0
+ | _ -> traitName0
+
+ /// Get the key associated with the member constraint.
+ member traitInfo.GetWitnessInfo() =
+ let (TTrait(tys, nm, memFlags, objAndArgTys, rty, _, _)) = traitInfo
+ TraitWitnessInfo(tys, nm, memFlags, objAndArgTys, rty)
+
+ /// Get information about the trait constraints for a set of typars.
+ /// Put these in canonical order.
+ let GetTraitConstraintInfosOfTypars g (tps: Typars) =
+ [
+ for tp in tps do
+ for cx in tp.Constraints do
+ match cx with
+ | TyparConstraint.MayResolveMember(traitInfo, _) -> traitInfo
+ | _ -> ()
+ ]
+ |> ListSet.setify (traitsAEquiv g TypeEquivEnv.EmptyIgnoreNulls)
+ |> List.sortBy (fun traitInfo -> traitInfo.MemberLogicalName, traitInfo.GetCompiledArgumentTypes().Length)
+
+ /// Get information about the runtime witnesses needed for a set of generalized typars
+ let GetTraitWitnessInfosOfTypars g numParentTypars typars =
+ let typs = typars |> List.skip numParentTypars
+ let cxs = GetTraitConstraintInfosOfTypars g typs
+ cxs |> List.map (fun cx -> cx.GetWitnessInfo())
+
+ /// Count the number of type parameters on the enclosing type
+ let CountEnclosingTyparsOfActualParentOfVal (v: Val) =
+ match v.ValReprInfo with
+ | None -> 0
+ | Some _ ->
+ if v.IsExtensionMember then 0
+ elif not v.IsMember then 0
+ else v.MemberApparentEntity.TyparsNoRange.Length
+
+ let GetValReprTypeInCompiledForm g valReprInfo numEnclosingTypars ty m =
+ let tps, paramArgInfos, retTy, retInfo =
+ GetValReprTypeInFSharpForm g valReprInfo ty m
+
+ let witnessInfos = GetTraitWitnessInfosOfTypars g numEnclosingTypars tps
+ // Eliminate lone single unit arguments
+ let paramArgInfos =
+ match paramArgInfos, valReprInfo.ArgInfos with
+ // static member and module value unit argument elimination
+ | [ [ (_argType, _) ] ], [ [] ] ->
+ //assert isUnitTy g argType
+ [ [] ]
+ // instance member unit argument elimination
+ | [ objInfo; [ (_argType, _) ] ], [ [ _objArg ]; [] ] ->
+ //assert isUnitTy g argType
+ [ objInfo; [] ]
+ | _ -> paramArgInfos
+
+ let retTy = if isUnitTy g retTy then None else Some retTy
+ (tps, witnessInfos, paramArgInfos, retTy, retInfo)
+
+ // Pull apart the type for an F# value that represents an object model method
+ // and see the "member" form for the type, i.e.
+ // detect methods with no arguments by (effectively) looking for single argument type of 'unit'.
+ // The analysis is driven of the inferred arity information for the value.
+ //
+ // This is used not only for the compiled form - it's also used for all type checking and object model
+ // logic such as determining if abstract methods have been implemented or not, and how
+ // many arguments the method takes etc.
+ let GetMemberTypeInMemberForm g memberFlags valReprInfo numEnclosingTypars ty m =
+ let tps, paramArgInfos, retTy, retInfo =
+ GetMemberTypeInFSharpForm g memberFlags valReprInfo ty m
+
+ let witnessInfos = GetTraitWitnessInfosOfTypars g numEnclosingTypars tps
+ // Eliminate lone single unit arguments
+ let paramArgInfos =
+ match paramArgInfos, valReprInfo.ArgInfos with
+ // static member and module value unit argument elimination
+ | [ [ (argTy, _) ] ], [ [] ] ->
+ assert isUnitTy g argTy
+ [ [] ]
+ // instance member unit argument elimination
+ | [ [ (argTy, _) ] ], [ [ _objArg ]; [] ] ->
+ assert isUnitTy g argTy
+ [ [] ]
+ | _ -> paramArgInfos
+
+ let retTy = if isUnitTy g retTy then None else Some retTy
+ (tps, witnessInfos, paramArgInfos, retTy, retInfo)
+
+ let GetTypeOfMemberInMemberForm g (vref: ValRef) =
+ //assert (not vref.IsExtensionMember)
+ let membInfo, valReprInfo = checkMemberValRef vref
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref
+ GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars vref.Type vref.Range
+
+ let GetTypeOfMemberInFSharpForm g (vref: ValRef) =
+ let membInfo, valReprInfo = checkMemberValRef vref
+ GetMemberTypeInFSharpForm g membInfo.MemberFlags valReprInfo vref.Type vref.Range
+
+ let PartitionValTyparsForApparentEnclosingType g (v: Val) =
+ match v.ValReprInfo with
+ | None -> error (InternalError("PartitionValTypars: not a top value", v.Range))
+ | Some arities ->
+ let fullTypars, _ = destTopForallTy g arities v.Type
+ let parent = v.MemberApparentEntity
+ let parentTypars = parent.TyparsNoRange
+ let nparentTypars = parentTypars.Length
+
+ if nparentTypars <= fullTypars.Length then
+ let memberParentTypars, memberMethodTypars = List.splitAt nparentTypars fullTypars
+
+ let memberToParentInst, tinst =
+ mkTyparToTyparRenaming memberParentTypars parentTypars
+
+ Some(parentTypars, memberParentTypars, memberMethodTypars, memberToParentInst, tinst)
+ else
+ None
+
+ /// Match up the type variables on an member value with the type
+ /// variables on the apparent enclosing type
+ let PartitionValTypars g (v: Val) =
+ match v.ValReprInfo with
+ | None -> error (InternalError("PartitionValTypars: not a top value", v.Range))
+ | Some arities ->
+ if v.IsExtensionMember then
+ let fullTypars, _ = destTopForallTy g arities v.Type
+ Some([], [], fullTypars, emptyTyparInst, [])
+ else
+ PartitionValTyparsForApparentEnclosingType g v
+
+ let PartitionValRefTypars g (vref: ValRef) = PartitionValTypars g vref.Deref
+
+ /// Get the arguments for an F# value that represents an object model method
+ let ArgInfosOfMemberVal g (v: Val) =
+ let membInfo, valReprInfo = checkMemberVal v.MemberInfo v.ValReprInfo v.Range
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+
+ let _, _, arginfos, _, _ =
+ GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars v.Type v.Range
+
+ arginfos
+
+ let ArgInfosOfMember g (vref: ValRef) = ArgInfosOfMemberVal g vref.Deref
+
+ /// Get the property "type" (getter return type) for an F# value that represents a getter or setter
+ /// of an object model property.
+ let ReturnTypeOfPropertyVal g (v: Val) =
+ let membInfo, valReprInfo = checkMemberVal v.MemberInfo v.ValReprInfo v.Range
+
+ match membInfo.MemberFlags.MemberKind with
+ | SynMemberKind.PropertySet ->
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+
+ let _, _, arginfos, _, _ =
+ GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars v.Type v.Range
+
+ if not arginfos.IsEmpty && not arginfos.Head.IsEmpty then
+ arginfos.Head |> List.last |> fst
+ else
+ error (Error(FSComp.SR.tastValueDoesNotHaveSetterType (), v.Range))
+ | SynMemberKind.PropertyGet ->
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+
+ let _, _, _, retTy, _ =
+ GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars v.Type v.Range
+
+ GetFSharpViewOfReturnType g retTy
+ | _ -> error (InternalError("ReturnTypeOfPropertyVal", v.Range))
+
+ /// Get the property arguments for an F# value that represents a getter or setter
+ /// of an object model property.
+ let ArgInfosOfPropertyVal g (v: Val) =
+ let membInfo, valReprInfo = checkMemberVal v.MemberInfo v.ValReprInfo v.Range
+
+ match membInfo.MemberFlags.MemberKind with
+ | SynMemberKind.PropertyGet -> ArgInfosOfMemberVal g v |> List.concat
+ | SynMemberKind.PropertySet ->
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+
+ let _, _, arginfos, _, _ =
+ GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars v.Type v.Range
+
+ if not arginfos.IsEmpty && not arginfos.Head.IsEmpty then
+ arginfos.Head |> List.frontAndBack |> fst
+ else
+ error (Error(FSComp.SR.tastValueDoesNotHaveSetterType (), v.Range))
+ | _ -> error (InternalError("ArgInfosOfPropertyVal", v.Range))
+
+ //---------------------------------------------------------------------------
+ // Generalize type constructors to types
+ //---------------------------------------------------------------------------
+
+ let generalTyconRefInst (tcref: TyconRef) = generalizeTypars tcref.TyparsNoRange
+
+ let generalizeTyconRef (g: TcGlobals) tcref =
+ let tinst = generalTyconRefInst tcref
+ tinst, TType_app(tcref, tinst, g.knownWithoutNull)
+
+ let generalizedTyconRef (g: TcGlobals) tcref =
+ let tinst = generalTyconRefInst tcref
+ TType_app(tcref, tinst, g.knownWithoutNull)
+
+ let isTTyparCoercesToType tpc =
+ match tpc with
+ | TyparConstraint.CoercesTo _ -> true
+ | _ -> false
+
+ //--------------------------------------------------------------------------
+ // Print Signatures/Types - prelude
+ //--------------------------------------------------------------------------
+
+ let prefixOfStaticReq s =
+ match s with
+ | TyparStaticReq.None -> "'"
+ | TyparStaticReq.HeadType -> "^"
+
+ let prefixOfInferenceTypar (typar: Typar) =
+ if typar.Rigidity <> TyparRigidity.Rigid then "_" else ""
+
+ let isTyparOrderMismatch (tps: Typars) (argInfos: CurriedArgInfos) =
+ let rec getTyparName (ty: TType) : string list =
+ match ty with
+ | TType_var(typar = tp) ->
+ if tp.Id.idText <> unassignedTyparName then
+ [ tp.Id.idText ]
+ else
+ match tp.Solution with
+ | None -> []
+ | Some solutionType -> getTyparName solutionType
+ | TType_fun(domainType, rangeType, _) -> [ yield! getTyparName domainType; yield! getTyparName rangeType ]
+ | TType_anon(tys = ti)
+ | TType_app(typeInstantiation = ti)
+ | TType_tuple(elementTypes = ti) -> List.collect getTyparName ti
+ | _ -> []
+
+ let typarNamesInArguments =
+ argInfos
+ |> List.collect (fun argInfos -> argInfos |> List.collect (fun (ty, _) -> getTyparName ty))
+ |> List.distinct
+
+ let typarNamesInDefinition =
+ tps |> List.map (fun (tp: Typar) -> tp.Id.idText) |> List.distinct
+
+ typarNamesInArguments.Length = typarNamesInDefinition.Length
+ && typarNamesInArguments <> typarNamesInDefinition
+
+ //---------------------------------------------------------------------------
+ // Prettify: PrettyTyparNames/PrettifyTypes - make typar names human friendly
+ //---------------------------------------------------------------------------
+
+ type TyparConstraintsWithTypars = (Typar * TyparConstraint) list
+
+ module PrettyTypes =
+ let newPrettyTypar (tp: Typar) nm =
+ Construct.NewTypar(
+ tp.Kind,
+ tp.Rigidity,
+ SynTypar(ident (nm, tp.Range), tp.StaticReq, false),
+ false,
+ TyparDynamicReq.Yes,
+ [],
+ false,
+ false
+ )
+
+ let NewPrettyTypars renaming tps names =
+ let niceTypars = List.map2 newPrettyTypar tps names
+ let tl, _tt = mkTyparToTyparRenaming tps niceTypars in
+ let renaming = renaming @ tl
+
+ (tps, niceTypars)
+ ||> List.iter2 (fun tp tpnice -> tpnice.SetConstraints(instTyparConstraints renaming tp.Constraints))
+
+ niceTypars, renaming
+
+ // We choose names for type parameters from 'a'..'t'
+ // We choose names for unit-of-measure from 'u'..'z'
+ // If we run off the end of these ranges, we use 'aX' for positive integer X or 'uX' for positive integer X
+ // Finally, we skip any names already in use
+ let NeedsPrettyTyparName (tp: Typar) =
+ tp.IsCompilerGenerated
+ && tp.ILName.IsNone
+ && (tp.typar_id.idText = unassignedTyparName)
+
+ let PrettyTyparNames pred alreadyInUse tps =
+ let rec choose (tps: Typar list) (typeIndex, measureIndex) acc =
+ match tps with
+ | [] -> List.rev acc
+ | tp :: tps ->
+
+ // Use a particular name, possibly after incrementing indexes
+ let useThisName (nm, typeIndex, measureIndex) =
+ choose tps (typeIndex, measureIndex) (nm :: acc)
+
+ // Give up, try again with incremented indexes
+ let tryAgain (typeIndex, measureIndex) =
+ choose (tp :: tps) (typeIndex, measureIndex) acc
+
+ let tryName (nm, typeIndex, measureIndex) f =
+ if List.contains nm alreadyInUse then
+ f ()
+ else
+ useThisName (nm, typeIndex, measureIndex)
+
+ if pred tp then
+ if NeedsPrettyTyparName tp then
+ let typeIndex, measureIndex, baseName, letters, i =
+ match tp.Kind with
+ | TyparKind.Type -> (typeIndex + 1, measureIndex, 'a', 20, typeIndex)
+ | TyparKind.Measure -> (typeIndex, measureIndex + 1, 'u', 6, measureIndex)
+
+ let nm =
+ if i < letters then
+ String.make 1 (char (int baseName + i))
+ else
+ String.make 1 baseName + string (i - letters + 1)
+
+ tryName (nm, typeIndex, measureIndex) (fun () -> tryAgain (typeIndex, measureIndex))
+
+ else
+ tryName (tp.Name, typeIndex, measureIndex) (fun () ->
+ // Use the next index and append it to the natural name
+ let typeIndex, measureIndex, nm =
+ match tp.Kind with
+ | TyparKind.Type -> (typeIndex + 1, measureIndex, tp.Name + string typeIndex)
+ | TyparKind.Measure -> (typeIndex, measureIndex + 1, tp.Name + string measureIndex)
+
+ tryName (nm, typeIndex, measureIndex) (fun () -> tryAgain (typeIndex, measureIndex)))
+ else
+ useThisName (tp.Name, typeIndex, measureIndex)
+
+ choose tps (0, 0) []
+
+ let AssignPrettyTyparNames typars prettyNames =
+ (typars, prettyNames)
+ ||> List.iter2 (fun tp nm ->
+ if NeedsPrettyTyparName tp then
+ tp.typar_id <- ident (nm, tp.Range))
+
+ let PrettifyThings g foldTys mapTys things =
+ let ftps =
+ foldTys (accFreeInTypeLeftToRight g true false) emptyFreeTyparsLeftToRight things
+
+ let ftps = List.rev ftps
+
+ let rec computeKeep (keep: Typars) change (tps: Typars) =
+ match tps with
+ | [] -> List.rev keep, List.rev change
+ | tp :: rest ->
+ if
+ not (NeedsPrettyTyparName tp)
+ && (not (keep |> List.exists (fun tp2 -> tp.Name = tp2.Name)))
+ then
+ computeKeep (tp :: keep) change rest
+ else
+ computeKeep keep (tp :: change) rest
+
+ let keep, change = computeKeep [] [] ftps
+
+ let alreadyInUse = keep |> List.map (fun x -> x.Name)
+ let names = PrettyTyparNames (fun x -> List.memq x change) alreadyInUse ftps
+
+ let niceTypars, renaming = NewPrettyTypars [] ftps names
+
+ // strip universal types for printing
+ let getTauStayTau ty =
+ match ty with
+ | TType_forall(_, tau) -> tau
+ | _ -> ty
+
+ let tauThings = mapTys getTauStayTau things
+
+ let prettyThings = mapTys (instType renaming) tauThings
+
+ let tpconstraints =
+ niceTypars
+ |> List.collect (fun tpnice -> List.map (fun tpc -> tpnice, tpc) tpnice.Constraints)
+
+ prettyThings, tpconstraints
+
+ let PrettifyType g x = PrettifyThings g id id x
+
+ let PrettifyTypePair g x =
+ PrettifyThings g (fun f -> foldPair (f, f)) (fun f -> mapPair (f, f)) x
+
+ let PrettifyTypes g x = PrettifyThings g List.fold List.map x
+
+ let PrettifyDiscriminantAndTypePairs g x =
+ let tys, cxs = (PrettifyThings g List.fold List.map (x |> List.map snd))
+ List.zip (List.map fst x) tys, cxs
+
+ let PrettifyCurriedTypes g x =
+ PrettifyThings g (List.fold >> List.fold) List.mapSquared x
+
+ let PrettifyCurriedSigTypes g x =
+ PrettifyThings g (fun f -> foldPair (List.fold (List.fold f), f)) (fun f -> mapPair (List.mapSquared f, f)) x
+
+ // Badly formed code may instantiate rigid declared typars to types.
+ // Hence we double check here that the thing is really a type variable
+ let safeDestAnyParTy orig g ty =
+ match tryAnyParTy g ty with
+ | ValueNone -> orig
+ | ValueSome x -> x
+
+ let foldUncurriedArgInfos f z (x: UncurriedArgInfos) = List.fold (fold1Of2 f) z x
+ let foldTypar f z (x: Typar) = foldOn mkTyparTy f z x
+
+ let mapTypar g f (x: Typar) : Typar =
+ (mkTyparTy >> f >> safeDestAnyParTy x g) x
+
+ let foldTypars f z (x: Typars) = List.fold (foldTypar f) z x
+ let mapTypars g f (x: Typars) : Typars = List.map (mapTypar g f) x
+
+ let foldTyparInst f z (x: TyparInstantiation) =
+ List.fold (foldPair (foldTypar f, f)) z x
+
+ let mapTyparInst g f (x: TyparInstantiation) : TyparInstantiation = List.map (mapPair (mapTypar g f, f)) x
+
+ let PrettifyInstAndTyparsAndType g x =
+ PrettifyThings
+ g
+ (fun f -> foldTriple (foldTyparInst f, foldTypars f, f))
+ (fun f -> mapTriple (mapTyparInst g f, mapTypars g f, f))
+ x
+
+ let PrettifyInstAndUncurriedSig g (x: TyparInstantiation * UncurriedArgInfos * TType) =
+ PrettifyThings
+ g
+ (fun f -> foldTriple (foldTyparInst f, foldUncurriedArgInfos f, f))
+ (fun f -> mapTriple (mapTyparInst g f, List.map (map1Of2 f), f))
+ x
+
+ let PrettifyInstAndCurriedSig g (x: TyparInstantiation * TTypes * CurriedArgInfos * TType) =
+ PrettifyThings
+ g
+ (fun f -> foldQuadruple (foldTyparInst f, List.fold f, List.fold (List.fold (fold1Of2 f)), f))
+ (fun f -> mapQuadruple (mapTyparInst g f, List.map f, List.mapSquared (map1Of2 f), f))
+ x
+
+ let PrettifyInstAndSig g x =
+ PrettifyThings
+ g
+ (fun f -> foldTriple (foldTyparInst f, List.fold f, f))
+ (fun f -> mapTriple (mapTyparInst g f, List.map f, f))
+ x
+
+ let PrettifyInstAndTypes g x =
+ PrettifyThings g (fun f -> foldPair (foldTyparInst f, List.fold f)) (fun f -> mapPair (mapTyparInst g f, List.map f)) x
+
+ let PrettifyInstAndType g x =
+ PrettifyThings g (fun f -> foldPair (foldTyparInst f, f)) (fun f -> mapPair (mapTyparInst g f, f)) x
+
+ let PrettifyInst g x =
+ PrettifyThings g foldTyparInst (fun f -> mapTyparInst g f) x
+
+ module SimplifyTypes =
+
+ // CAREFUL! This function does NOT walk constraints
+ let rec foldTypeButNotConstraints f z ty =
+ let ty = stripTyparEqns ty
+ let z = f z ty
+
+ match ty with
+ | TType_forall(_, bodyTy) -> foldTypeButNotConstraints f z bodyTy
+
+ | TType_app(_, tys, _)
+ | TType_ucase(_, tys)
+ | TType_anon(_, tys)
+ | TType_tuple(_, tys) -> List.fold (foldTypeButNotConstraints f) z tys
+
+ | TType_fun(domainTy, rangeTy, _) -> foldTypeButNotConstraints f (foldTypeButNotConstraints f z domainTy) rangeTy
+
+ | TType_var _ -> z
+
+ | TType_measure _ -> z
+
+ let incM x m =
+ if Zmap.mem x m then
+ Zmap.add x (1 + Zmap.find x m) m
+ else
+ Zmap.add x 1 m
+
+ let accTyparCounts z ty =
+ // Walk type to determine typars and their counts (for pprinting decisions)
+ (z, ty)
+ ||> foldTypeButNotConstraints (fun z ty ->
+ match ty with
+ | TType_var(tp, _) when tp.Rigidity = TyparRigidity.Rigid -> incM tp z
+ | _ -> z)
+
+ let emptyTyparCounts = Zmap.empty typarOrder
+
+ // print multiple fragments of the same type using consistent naming and formatting
+ let accTyparCountsMulti acc l = List.fold accTyparCounts acc l
+
+ type TypeSimplificationInfo =
+ {
+ singletons: Typar Zset
+ inplaceConstraints: Zmap
+ postfixConstraints: (Typar * TyparConstraint) list
+ }
+
+ let typeSimplificationInfo0 =
+ {
+ singletons = Zset.empty typarOrder
+ inplaceConstraints = Zmap.empty typarOrder
+ postfixConstraints = []
+ }
+
+ let categorizeConstraints simplify m cxs =
+ let singletons =
+ if simplify then
+ Zmap.chooseL (fun tp n -> if n = 1 then Some tp else None) m
+ else
+ []
+
+ let singletons = Zset.addList singletons (Zset.empty typarOrder)
+ // Here, singletons are typars that occur once in the type.
+ // However, they may also occur in a type constraint.
+ // If they do, they are really multiple occurrence - so we should remove them.
+ let constraintTypars =
+ (freeInTyparConstraints CollectTyparsNoCaching (List.map snd cxs)).FreeTypars
+
+ let usedInTypeConstraint typar = Zset.contains typar constraintTypars
+ let singletons = singletons |> Zset.filter (usedInTypeConstraint >> not)
+ // Here, singletons should really be used once
+ let inplace, postfix =
+ cxs
+ |> List.partition (fun (tp, tpc) ->
+ simplify
+ && isTTyparCoercesToType tpc
+ && Zset.contains tp singletons
+ && List.isSingleton tp.Constraints)
+
+ let inplace =
+ inplace
+ |> List.map (function
+ | tp, TyparConstraint.CoercesTo(ty, _) -> tp, ty
+ | _ -> failwith "not isTTyparCoercesToType")
+
+ {
+ singletons = singletons
+ inplaceConstraints = Zmap.ofList typarOrder inplace
+ postfixConstraints = postfix
+ }
+
+ let CollectInfo simplify tys cxs =
+ categorizeConstraints simplify (accTyparCountsMulti emptyTyparCounts tys) cxs
+
+ //--------------------------------------------------------------------------
+ // Print Signatures/Types
+ //--------------------------------------------------------------------------
+
+ type GenericParameterStyle =
+ | Implicit
+ | Prefix
+ | Suffix
+ | TopLevelPrefix of nested: GenericParameterStyle
+
+ []
+ type DisplayEnv =
+ {
+ includeStaticParametersInTypeNames: bool
+ openTopPathsSorted: InterruptibleLazy
+ openTopPathsRaw: string list list
+ shortTypeNames: bool
+ suppressNestedTypes: bool
+ maxMembers: int option
+ showObsoleteMembers: bool
+ showHiddenMembers: bool
+ showTyparBinding: bool
+ showInferenceTyparAnnotations: bool
+ suppressInlineKeyword: bool
+ suppressMutableKeyword: bool
+ showMemberContainers: bool
+ shortConstraints: bool
+ useColonForReturnType: bool
+ showAttributes: bool
+ showCsharpCodeAnalysisAttributes: bool
+ showOverrides: bool
+ showStaticallyResolvedTyparAnnotations: bool
+ showNullnessAnnotations: bool option
+ abbreviateAdditionalConstraints: bool
+ showTyparDefaultConstraints: bool
+ showDocumentation: bool
+ shrinkOverloads: bool
+ printVerboseSignatures: bool
+ escapeKeywordNames: bool
+ g: TcGlobals
+ contextAccessibility: Accessibility
+ generatedValueLayout: Val -> Layout option
+ genericParameterStyle: GenericParameterStyle
+ }
+
+ member x.SetOpenPaths paths =
+ { x with
+ openTopPathsSorted = InterruptibleLazy(fun _ -> paths |> List.sortWith (fun p1 p2 -> -(compare p1 p2)))
+ openTopPathsRaw = paths
+ }
+
+ static member Empty tcGlobals =
+ {
+ includeStaticParametersInTypeNames = false
+ openTopPathsRaw = []
+ openTopPathsSorted = notlazy []
+ shortTypeNames = false
+ suppressNestedTypes = false
+ maxMembers = None
+ showObsoleteMembers = false
+ showHiddenMembers = false
+ showTyparBinding = false
+ showInferenceTyparAnnotations = false
+ suppressInlineKeyword = true
+ suppressMutableKeyword = false
+ showMemberContainers = false
+ showAttributes = false
+ showCsharpCodeAnalysisAttributes = false
+ showOverrides = true
+ showStaticallyResolvedTyparAnnotations = true
+ showNullnessAnnotations = None
+ showDocumentation = false
+ abbreviateAdditionalConstraints = false
+ showTyparDefaultConstraints = false
+ shortConstraints = false
+ useColonForReturnType = false
+ shrinkOverloads = true
+ printVerboseSignatures = false
+ escapeKeywordNames = false
+ g = tcGlobals
+ contextAccessibility = taccessPublic
+ generatedValueLayout = (fun _ -> None)
+ genericParameterStyle = GenericParameterStyle.Implicit
+ }
+
+ member denv.AddOpenPath path =
+ denv.SetOpenPaths(path :: denv.openTopPathsRaw)
+
+ member denv.AddOpenModuleOrNamespace(modref: ModuleOrNamespaceRef) =
+ denv.AddOpenPath (fullCompPathOfModuleOrNamespace modref.Deref).DemangledPath
+
+ member denv.AddAccessibility access =
+ { denv with
+ contextAccessibility = combineAccess denv.contextAccessibility access
+ }
+
+ member denv.UseGenericParameterStyle style =
+ { denv with
+ genericParameterStyle = style
+ }
+
+ member denv.UseTopLevelPrefixGenericParameterStyle() =
+ let nestedStyle =
+ match denv.genericParameterStyle with
+ | TopLevelPrefix(nested) -> nested
+ | style -> style
+
+ { denv with
+ genericParameterStyle = TopLevelPrefix(nestedStyle)
+ }
+
+ static member InitialForSigFileGeneration g =
+ let denv =
+ { DisplayEnv.Empty g with
+ showInferenceTyparAnnotations = true
+ showHiddenMembers = true
+ showObsoleteMembers = true
+ showAttributes = true
+ suppressInlineKeyword = false
+ showDocumentation = true
+ shrinkOverloads = false
+ escapeKeywordNames = true
+ includeStaticParametersInTypeNames = true
+ }
+
+ denv.SetOpenPaths
+ [
+ RootPath
+ CorePath
+ CollectionsPath
+ ControlPath
+ (splitNamespace ExtraTopLevelOperatorsName)
+ ]
+
+ let (+.+) s1 s2 =
+ if String.IsNullOrEmpty(s1) then s2 else !!s1 + "." + s2
+
+ let layoutOfPath p =
+ sepListL SepL.dot (List.map (tagNamespace >> wordL) p)
+
+ let fullNameOfParentOfPubPath pp =
+ match pp with
+ | PubPath([| _ |]) -> ValueNone
+ | pp -> ValueSome(textOfPath pp.EnclosingPath)
+
+ let fullNameOfParentOfPubPathAsLayout pp =
+ match pp with
+ | PubPath([| _ |]) -> ValueNone
+ | pp -> ValueSome(layoutOfPath (Array.toList pp.EnclosingPath))
+
+ let fullNameOfPubPath (PubPath p) = textOfPath p
+ let fullNameOfPubPathAsLayout (PubPath p) = layoutOfPath (Array.toList p)
+
+ let fullNameOfParentOfNonLocalEntityRef (nlr: NonLocalEntityRef) =
+ if nlr.Path.Length < 2 then
+ ValueNone
+ else
+ ValueSome(textOfPath nlr.EnclosingMangledPath)
+
+ let fullNameOfParentOfNonLocalEntityRefAsLayout (nlr: NonLocalEntityRef) =
+ if nlr.Path.Length < 2 then
+ ValueNone
+ else
+ ValueSome(layoutOfPath (List.ofArray nlr.EnclosingMangledPath))
+
+ let fullNameOfParentOfEntityRef eref =
+ match eref with
+ | ERefLocal x ->
+ match x.PublicPath with
+ | None -> ValueNone
+ | Some ppath -> fullNameOfParentOfPubPath ppath
+ | ERefNonLocal nlr -> fullNameOfParentOfNonLocalEntityRef nlr
+
+ let fullNameOfParentOfEntityRefAsLayout eref =
+ match eref with
+ | ERefLocal x ->
+ match x.PublicPath with
+ | None -> ValueNone
+ | Some ppath -> fullNameOfParentOfPubPathAsLayout ppath
+ | ERefNonLocal nlr -> fullNameOfParentOfNonLocalEntityRefAsLayout nlr
+
+ let fullNameOfEntityRef nmF xref =
+ match fullNameOfParentOfEntityRef xref with
+ | ValueNone -> nmF xref
+ | ValueSome pathText -> pathText +.+ nmF xref
+
+ let tagEntityRefName (xref: EntityRef) name =
+ if xref.IsNamespace then
+ tagNamespace name
+ elif xref.IsModule then
+ tagModule name
+ elif xref.IsTypeAbbrev then
+ tagAlias name
+ elif xref.IsFSharpDelegateTycon then
+ tagDelegate name
+ elif xref.IsILEnumTycon || xref.IsFSharpEnumTycon then
+ tagEnum name
+ elif xref.IsStructOrEnumTycon then
+ tagStruct name
+ elif isInterfaceTyconRef xref then
+ tagInterface name
+ elif xref.IsUnionTycon then
+ tagUnion name
+ elif xref.IsRecordTycon then
+ tagRecord name
+ else
+ tagClass name
+
+ let fullDisplayTextOfTyconRef (tcref: TyconRef) =
+ fullNameOfEntityRef (fun tcref -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars) tcref
+
+ let fullNameOfEntityRefAsLayout nmF (xref: EntityRef) =
+ let navigableText =
+ tagEntityRefName xref (nmF xref) |> mkNav xref.DefinitionRange |> wordL
+
+ match fullNameOfParentOfEntityRefAsLayout xref with
+ | ValueNone -> navigableText
+ | ValueSome pathText -> pathText ^^ SepL.dot ^^ navigableText
+
+ let fullNameOfParentOfValRef vref =
+ match vref with
+ | VRefLocal x ->
+ match x.PublicPath with
+ | None -> ValueNone
+ | Some(ValPubPath(pp, _)) -> ValueSome(fullNameOfPubPath pp)
+ | VRefNonLocal nlr -> ValueSome(fullNameOfEntityRef (fun (x: EntityRef) -> x.DemangledModuleOrNamespaceName) nlr.EnclosingEntity)
+
+ let fullNameOfParentOfValRefAsLayout vref =
+ match vref with
+ | VRefLocal x ->
+ match x.PublicPath with
+ | None -> ValueNone
+ | Some(ValPubPath(pp, _)) -> ValueSome(fullNameOfPubPathAsLayout pp)
+ | VRefNonLocal nlr ->
+ ValueSome(fullNameOfEntityRefAsLayout (fun (x: EntityRef) -> x.DemangledModuleOrNamespaceName) nlr.EnclosingEntity)
+
+ let fullDisplayTextOfParentOfModRef eref = fullNameOfParentOfEntityRef eref
+
+ let fullDisplayTextOfModRef r =
+ fullNameOfEntityRef (fun eref -> eref.DemangledModuleOrNamespaceName) r
+
+ let fullDisplayTextOfTyconRefAsLayout tcref =
+ fullNameOfEntityRefAsLayout (fun tcref -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars) tcref
+
+ let fullDisplayTextOfExnRef tcref =
+ fullNameOfEntityRef (fun tcref -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars) tcref
+
+ let fullDisplayTextOfExnRefAsLayout tcref =
+ fullNameOfEntityRefAsLayout (fun tcref -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars) tcref
+
+ let fullDisplayTextOfUnionCaseRef (ucref: UnionCaseRef) =
+ fullDisplayTextOfTyconRef ucref.TyconRef +.+ ucref.CaseName
+
+ let fullDisplayTextOfRecdFieldRef (rfref: RecdFieldRef) =
+ fullDisplayTextOfTyconRef rfref.TyconRef +.+ rfref.FieldName
+
+ let fullDisplayTextOfValRef (vref: ValRef) =
+ match fullNameOfParentOfValRef vref with
+ | ValueNone -> vref.DisplayName
+ | ValueSome pathText -> pathText +.+ vref.DisplayName
+
+ let fullDisplayTextOfValRefAsLayout (vref: ValRef) =
+ let n =
+ match vref.MemberInfo with
+ | None ->
+ if vref.IsModuleBinding then
+ tagModuleBinding vref.DisplayName
+ else
+ tagUnknownEntity vref.DisplayName
+ | Some memberInfo ->
+ match memberInfo.MemberFlags.MemberKind with
+ | SynMemberKind.PropertyGet
+ | SynMemberKind.PropertySet
+ | SynMemberKind.PropertyGetSet -> tagProperty vref.DisplayName
+ | SynMemberKind.ClassConstructor
+ | SynMemberKind.Constructor -> tagMethod vref.DisplayName
+ | SynMemberKind.Member -> tagMember vref.DisplayName
+
+ match fullNameOfParentOfValRefAsLayout vref with
+ | ValueNone -> wordL n
+ | ValueSome pathText -> pathText ^^ SepL.dot ^^ wordL n
+ //pathText +.+ vref.DisplayName
+
+ let fullMangledPathToTyconRef (tcref: TyconRef) =
+ match tcref with
+ | ERefLocal _ ->
+ (match tcref.PublicPath with
+ | None -> [||]
+ | Some pp -> pp.EnclosingPath)
+ | ERefNonLocal nlr -> nlr.EnclosingMangledPath
+
+ /// generates a name like 'System.IComparable.Get'
+ let tyconRefToFullName (tcref: TyconRef) =
+ let namespaceParts =
+ // we need to ensure there are no collisions between (for example)
+ // - ``IB`` (non-generic)
+ // - IB<'T> instantiated with 'T = GlobalType
+ // This is only an issue for types inside the global namespace, because '.' is invalid even in a quoted identifier.
+ // So if the type is in the global namespace, prepend 'global`', because '`' is also illegal -> there can be no quoted identifer with that name.
+ match fullMangledPathToTyconRef tcref with
+ | [||] -> [| "global`" |]
+ | ns -> ns
+
+ seq {
+ yield! namespaceParts
+ yield tcref.DisplayName
+ }
+ |> String.concat "."
+
+ let rec qualifiedInterfaceImplementationNameAux g (x: TType) : string =
+ match stripMeasuresFromTy g (stripTyEqnsAndErase true g x) with
+ | TType_app(a, [], _) -> tyconRefToFullName a
+
+ | TType_anon(a, b) ->
+ let genericParameters =
+ b |> Seq.map (qualifiedInterfaceImplementationNameAux g) |> String.concat ", "
+
+ sprintf "%s<%s>" a.ILTypeRef.FullName genericParameters
+
+ | TType_app(a, b, _) ->
+ let genericParameters =
+ b |> Seq.map (qualifiedInterfaceImplementationNameAux g) |> String.concat ", "
+
+ sprintf "%s<%s>" (tyconRefToFullName a) genericParameters
+
+ | TType_var(v, _) -> "'" + v.Name
+
+ | _ -> failwithf "unexpected: expected TType_app but got %O" (x.GetType())
+
+ /// for types in the global namespace, `global is prepended (note the backtick)
+ let qualifiedInterfaceImplementationName g (ty: TType) memberName =
+ let interfaceName = ty |> qualifiedInterfaceImplementationNameAux g
+ sprintf "%s.%s" interfaceName memberName
+
+ let qualifiedMangledNameOfTyconRef tcref nm =
+ String.concat
+ "-"
+ (Array.toList (fullMangledPathToTyconRef tcref)
+ @ [ tcref.LogicalName + "-" + nm ])
+
+ let rec firstEq p1 p2 =
+ match p1 with
+ | [] -> true
+ | h1 :: t1 ->
+ match p2 with
+ | h2 :: t2 -> h1 = h2 && firstEq t1 t2
+ | _ -> false
+
+ let rec firstRem p1 p2 =
+ match p1 with
+ | [] -> p2
+ | _ :: t1 -> firstRem t1 (List.tail p2)
+
+ let trimPathByDisplayEnv denv path =
+ let findOpenedNamespace openedPath =
+ if firstEq openedPath path then
+ let t2 = firstRem openedPath path
+ if t2 <> [] then Some(textOfPath t2 + ".") else Some("")
+ else
+ None
+
+ match List.tryPick findOpenedNamespace (denv.openTopPathsSorted.Force()) with
+ | Some s -> s
+ | None -> if isNil path then "" else textOfPath path + "."
+
+ let superOfTycon (g: TcGlobals) (tycon: Tycon) =
+ match tycon.TypeContents.tcaug_super with
+ | None -> g.obj_ty_noNulls
+ | Some ty -> ty
+
+ /// walk a TyconRef's inheritance tree, yielding any parent types as an array
+ let supersOfTyconRef (tcref: TyconRef) =
+ tcref
+ |> Array.unfold (fun tcref ->
+ match tcref.TypeContents.tcaug_super with
+ | Some(TType_app(sup, _, _)) -> Some(sup, sup)
+ | _ -> None)
diff --git a/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi
new file mode 100644
index 0000000000..e7e37aef6e
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi
@@ -0,0 +1,383 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.TypedTreeOps
+
+open System.Collections.Generic
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TcGlobals
+
+[]
+module internal FreeTypeVars =
+
+ val emptyFreeLocals: FreeLocals
+
+ val unionFreeLocals: FreeLocals -> FreeLocals -> FreeLocals
+
+ val emptyFreeRecdFields: Zset
+
+ val unionFreeRecdFields: Zset -> Zset -> Zset
+
+ val emptyFreeUnionCases: Zset
+
+ val unionFreeUnionCases: Zset -> Zset -> Zset
+
+ val emptyFreeTycons: FreeTycons
+
+ val unionFreeTycons: FreeTycons -> FreeTycons -> FreeTycons
+
+ /// An ordering for type parameters, based on stamp
+ val typarOrder: IComparer
+
+ val emptyFreeTypars: FreeTypars
+
+ val unionFreeTypars: FreeTypars -> FreeTypars -> FreeTypars
+
+ val emptyFreeTyvars: FreeTyvars
+
+ val isEmptyFreeTyvars: FreeTyvars -> bool
+
+ val unionFreeTyvars: FreeTyvars -> FreeTyvars -> FreeTyvars
+
+ /// Represents the options to activate when collecting free variables
+ type FreeVarOptions =
+ { canCache: bool
+ collectInTypes: bool
+ includeLocalTycons: bool
+ includeTypars: bool
+ includeLocalTyconReprs: bool
+ includeRecdFields: bool
+ includeUnionCases: bool
+ includeLocals: bool
+ templateReplacement: ((TyconRef -> bool) * Typars) option
+ stackGuard: StackGuard option }
+
+ /// During backend code generation of state machines, register a template replacement for struct types.
+ /// This may introduce new free variables related to the instantiation of the struct type.
+ member WithTemplateReplacement: (TyconRef -> bool) * Typars -> FreeVarOptions
+
+ val CollectLocalsNoCaching: FreeVarOptions
+
+ val CollectTyparsNoCaching: FreeVarOptions
+
+ val CollectTyparsAndLocalsNoCaching: FreeVarOptions
+
+ val CollectTyparsAndLocals: FreeVarOptions
+
+ val CollectLocals: FreeVarOptions
+
+ val CollectLocalsWithStackGuard: unit -> FreeVarOptions
+
+ val CollectTyparsAndLocalsWithStackGuard: unit -> FreeVarOptions
+
+ val CollectTypars: FreeVarOptions
+
+ val CollectAllNoCaching: FreeVarOptions
+
+ val CollectAll: FreeVarOptions
+
+ val accFreeInTypes: FreeVarOptions -> TType list -> FreeTyvars -> FreeTyvars
+
+ val accFreeInType: FreeVarOptions -> TType -> FreeTyvars -> FreeTyvars
+
+ val accFreeTycon: FreeVarOptions -> TyconRef -> FreeTyvars -> FreeTyvars
+
+ val boundTypars: FreeVarOptions -> Typars -> FreeTyvars -> FreeTyvars
+
+ val accFreeInTrait: FreeVarOptions -> TraitConstraintInfo -> FreeTyvars -> FreeTyvars
+
+ val accFreeInTraitSln: FreeVarOptions -> TraitConstraintSln -> FreeTyvars -> FreeTyvars
+
+ val accFreeInTupInfo: FreeVarOptions -> TupInfo -> FreeTyvars -> FreeTyvars
+
+ val accFreeInVal: FreeVarOptions -> Val -> FreeTyvars -> FreeTyvars
+
+ val accFreeInTypars: FreeVarOptions -> Typars -> FreeTyvars -> FreeTyvars
+
+ val freeInType: FreeVarOptions -> TType -> FreeTyvars
+
+ val freeInTypes: FreeVarOptions -> TType list -> FreeTyvars
+
+ val freeInVal: FreeVarOptions -> Val -> FreeTyvars
+
+ // This one puts free variables in canonical left-to-right order.
+ val freeInTypeLeftToRight: TcGlobals -> bool -> TType -> Typars
+
+ val freeInTypesLeftToRight: TcGlobals -> bool -> TType list -> Typars
+
+ val freeInTypesLeftToRightSkippingConstraints: TcGlobals -> TType list -> Typars
+
+ val freeInModuleTy: ModuleOrNamespaceType -> FreeTyvars
+
+[]
+module internal MemberRepresentation =
+
+ val GetMemberTypeInFSharpForm:
+ TcGlobals -> SynMemberFlags -> ValReprInfo -> TType -> range -> Typars * CurriedArgInfos * TType * ArgReprInfo
+
+ val checkMemberValRef: ValRef -> ValMemberInfo * ValReprInfo
+
+ val generalTyconRefInst: TyconRef -> TypeInst
+
+ val generalizeTyconRef: TcGlobals -> TyconRef -> TTypes * TType
+
+ val generalizedTyconRef: TcGlobals -> TyconRef -> TType
+
+ val GetValReprTypeInCompiledForm:
+ TcGlobals ->
+ ValReprInfo ->
+ int ->
+ TType ->
+ range ->
+ Typars * TraitWitnessInfos * CurriedArgInfos * TType option * ArgReprInfo
+
+ val GetFSharpViewOfReturnType: TcGlobals -> TType option -> TType
+
+ //-------------------------------------------------------------------------
+ // Members
+ //-------------------------------------------------------------------------
+
+ val GetTypeOfMemberInFSharpForm: TcGlobals -> ValRef -> Typars * CurriedArgInfos * TType * ArgReprInfo
+
+ val GetTypeOfMemberInMemberForm:
+ TcGlobals -> ValRef -> Typars * TraitWitnessInfos * CurriedArgInfos * TType option * ArgReprInfo
+
+ val GetMemberTypeInMemberForm:
+ TcGlobals ->
+ SynMemberFlags ->
+ ValReprInfo ->
+ int ->
+ TType ->
+ range ->
+ Typars * TraitWitnessInfos * CurriedArgInfos * TType option * ArgReprInfo
+
+ /// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
+ val PartitionValTyparsForApparentEnclosingType:
+ TcGlobals -> Val -> (Typars * Typars * Typars * TyparInstantiation * TType list) option
+
+ /// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
+ val PartitionValTypars: TcGlobals -> Val -> (Typars * Typars * Typars * TyparInstantiation * TType list) option
+
+ /// Returns (parentTypars,memberParentTypars,memberMethodTypars,memberToParentInst,tinst)
+ val PartitionValRefTypars:
+ TcGlobals -> ValRef -> (Typars * Typars * Typars * TyparInstantiation * TType list) option
+
+ /// Count the number of type parameters on the enclosing type
+ val CountEnclosingTyparsOfActualParentOfVal: Val -> int
+
+ val ReturnTypeOfPropertyVal: TcGlobals -> Val -> TType
+
+ val ArgInfosOfPropertyVal: TcGlobals -> Val -> UncurriedArgInfos
+
+ val ArgInfosOfMember: TcGlobals -> ValRef -> CurriedArgInfos
+
+ /// Check if the order of defined typars is different from the order of used typars in the curried arguments.
+ val isTyparOrderMismatch: Typars -> CurriedArgInfos -> bool
+
+ //-------------------------------------------------------------------------
+ // Printing
+ //-------------------------------------------------------------------------
+
+ type TyparConstraintsWithTypars = (Typar * TyparConstraint) list
+
+ module PrettyTypes =
+
+ val NeedsPrettyTyparName: Typar -> bool
+
+ val NewPrettyTypars: TyparInstantiation -> Typars -> string list -> Typars * TyparInstantiation
+
+ val PrettyTyparNames: (Typar -> bool) -> string list -> Typars -> string list
+
+ /// Assign previously generated pretty names to typars
+ val AssignPrettyTyparNames: Typars -> string list -> unit
+
+ val PrettifyType: TcGlobals -> TType -> TType * TyparConstraintsWithTypars
+
+ val PrettifyInstAndTyparsAndType:
+ TcGlobals ->
+ TyparInstantiation * Typars * TType ->
+ (TyparInstantiation * Typars * TType) * TyparConstraintsWithTypars
+
+ val PrettifyTypePair: TcGlobals -> TType * TType -> (TType * TType) * TyparConstraintsWithTypars
+
+ val PrettifyTypes: TcGlobals -> TTypes -> TTypes * TyparConstraintsWithTypars
+
+ /// same as PrettifyTypes, but allows passing the types along with a discriminant value
+ /// useful to prettify many types that need to be sorted out after prettifying operation
+ /// took place.
+ val PrettifyDiscriminantAndTypePairs:
+ TcGlobals -> ('Discriminant * TType) list -> ('Discriminant * TType) list * TyparConstraintsWithTypars
+
+ val PrettifyInst: TcGlobals -> TyparInstantiation -> TyparInstantiation * TyparConstraintsWithTypars
+
+ val PrettifyInstAndType:
+ TcGlobals -> TyparInstantiation * TType -> (TyparInstantiation * TType) * TyparConstraintsWithTypars
+
+ val PrettifyInstAndTypes:
+ TcGlobals -> TyparInstantiation * TTypes -> (TyparInstantiation * TTypes) * TyparConstraintsWithTypars
+
+ val PrettifyInstAndSig:
+ TcGlobals ->
+ TyparInstantiation * TTypes * TType ->
+ (TyparInstantiation * TTypes * TType) * TyparConstraintsWithTypars
+
+ val PrettifyCurriedTypes: TcGlobals -> TType list list -> TType list list * TyparConstraintsWithTypars
+
+ val PrettifyCurriedSigTypes:
+ TcGlobals -> TType list list * TType -> (TType list list * TType) * TyparConstraintsWithTypars
+
+ val PrettifyInstAndUncurriedSig:
+ TcGlobals ->
+ TyparInstantiation * UncurriedArgInfos * TType ->
+ (TyparInstantiation * UncurriedArgInfos * TType) * TyparConstraintsWithTypars
+
+ val PrettifyInstAndCurriedSig:
+ TcGlobals ->
+ TyparInstantiation * TTypes * CurriedArgInfos * TType ->
+ (TyparInstantiation * TTypes * CurriedArgInfos * TType) * TyparConstraintsWithTypars
+
+ /// Describes how generic type parameters in a type will be formatted during printing
+ type GenericParameterStyle =
+ /// Use the IsPrefixDisplay member of the TyCon to determine the style
+ | Implicit
+ /// Force the prefix style: List
+ | Prefix
+ /// Force the suffix style: int List
+ | Suffix
+ /// Force the prefix style for a top-level type,
+ /// for example, `seq` instead of `int list seq`
+ | TopLevelPrefix of nested: GenericParameterStyle
+
+ type DisplayEnv =
+ {
+ includeStaticParametersInTypeNames: bool
+ openTopPathsSorted: InterruptibleLazy
+ openTopPathsRaw: string list list
+ shortTypeNames: bool
+ suppressNestedTypes: bool
+ maxMembers: int option
+ showObsoleteMembers: bool
+ showHiddenMembers: bool
+ showTyparBinding: bool
+ showInferenceTyparAnnotations: bool
+ suppressInlineKeyword: bool
+ suppressMutableKeyword: bool
+ showMemberContainers: bool
+ shortConstraints: bool
+ useColonForReturnType: bool
+ showAttributes: bool
+ showCsharpCodeAnalysisAttributes: bool
+ showOverrides: bool
+ showStaticallyResolvedTyparAnnotations: bool
+ showNullnessAnnotations: bool option
+ abbreviateAdditionalConstraints: bool
+ showTyparDefaultConstraints: bool
+ /// If set, signatures will be rendered with XML documentation comments for members if they exist
+ /// Defaults to false, expected use cases include things like signature file generation.
+ showDocumentation: bool
+ shrinkOverloads: bool
+ printVerboseSignatures: bool
+ escapeKeywordNames: bool
+ g: TcGlobals
+ contextAccessibility: Accessibility
+ generatedValueLayout: Val -> Layout option
+ genericParameterStyle: GenericParameterStyle
+ }
+
+ member SetOpenPaths: string list list -> DisplayEnv
+
+ static member Empty: TcGlobals -> DisplayEnv
+
+ member AddAccessibility: Accessibility -> DisplayEnv
+
+ member AddOpenPath: string list -> DisplayEnv
+
+ member AddOpenModuleOrNamespace: ModuleOrNamespaceRef -> DisplayEnv
+
+ member UseGenericParameterStyle: GenericParameterStyle -> DisplayEnv
+
+ member UseTopLevelPrefixGenericParameterStyle: unit -> DisplayEnv
+
+ static member InitialForSigFileGeneration: TcGlobals -> DisplayEnv
+
+ val tagEntityRefName: xref: EntityRef -> name: string -> TaggedText
+
+ /// Return the full text for an item as we want it displayed to the user as a fully qualified entity
+ val fullDisplayTextOfModRef: ModuleOrNamespaceRef -> string
+
+ val fullDisplayTextOfParentOfModRef: ModuleOrNamespaceRef -> string voption
+
+ val fullDisplayTextOfValRef: ValRef -> string
+
+ val fullDisplayTextOfValRefAsLayout: ValRef -> Layout
+
+ val fullDisplayTextOfTyconRef: TyconRef -> string
+
+ val fullDisplayTextOfTyconRefAsLayout: TyconRef -> Layout
+
+ val fullDisplayTextOfExnRef: TyconRef -> string
+
+ val fullDisplayTextOfExnRefAsLayout: TyconRef -> Layout
+
+ val fullDisplayTextOfUnionCaseRef: UnionCaseRef -> string
+
+ val fullDisplayTextOfRecdFieldRef: RecdFieldRef -> string
+
+ val fullMangledPathToTyconRef: TyconRef -> string array
+
+ /// A unique qualified name for each type definition, used to qualify the names of interface implementation methods
+ val qualifiedMangledNameOfTyconRef: TyconRef -> string -> string
+
+ val qualifiedInterfaceImplementationName: TcGlobals -> TType -> string -> string
+
+ val trimPathByDisplayEnv: DisplayEnv -> string list -> string
+
+ val prefixOfStaticReq: TyparStaticReq -> string
+
+ val prefixOfInferenceTypar: Typar -> string
+
+ /// Utilities used in simplifying types for visual presentation
+ module SimplifyTypes =
+
+ type TypeSimplificationInfo =
+ { singletons: Typar Zset
+ inplaceConstraints: Zmap
+ postfixConstraints: TyparConstraintsWithTypars }
+
+ val typeSimplificationInfo0: TypeSimplificationInfo
+
+ val CollectInfo: bool -> TType list -> TyparConstraintsWithTypars -> TypeSimplificationInfo
+
+ val superOfTycon: TcGlobals -> Tycon -> TType
+
+ /// walk a TyconRef's inheritance tree, yielding any parent types as an array
+ val supersOfTyconRef: TyconRef -> TyconRef array
+
+ val GetTraitConstraintInfosOfTypars: TcGlobals -> Typars -> TraitConstraintInfo list
+
+ val GetTraitWitnessInfosOfTypars: TcGlobals -> numParentTypars: int -> typars: Typars -> TraitWitnessInfos
+
+ type TraitConstraintInfo with
+
+ /// Get the argument types recorded in the member constraint suitable for building a TypedTree call.
+ member GetCompiledArgumentTypes: unit -> TType list
+
+ /// Get the argument types when the trait is used as a first-class value "^T.TraitName" which can then be applied
+ member GetLogicalArgumentTypes: g: TcGlobals -> TType list
+
+ member GetObjectType: unit -> TType option
+
+ member GetReturnType: g: TcGlobals -> TType
+
+ /// Get the name of the trait for textual call.
+ member MemberDisplayNameCore: string
+
+ /// Get the key associated with the member constraint.
+ member GetWitnessInfo: unit -> TraitWitnessInfo
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remap.fs b/src/Compiler/TypedTree/TypedTreeOps.Remap.fs
new file mode 100644
index 0000000000..b598acccef
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Remap.fs
@@ -0,0 +1,1693 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// Defines derived expression manipulation and construction functions.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal TypeRemapping =
+
+ let inline compareBy (x: 'T | null) (y: 'T | null) ([] func: 'T -> 'K) =
+ match x, y with
+ | null, null -> 0
+ | null, _ -> -1
+ | _, null -> 1
+ | x, y -> compare (func !!x) (func !!y)
+
+ //---------------------------------------------------------------------------
+ // Basic data structures
+ //---------------------------------------------------------------------------
+
+ []
+ type TyparMap<'T> =
+ | TPMap of StampMap<'T>
+
+ member tm.Item
+ with get (tp: Typar) =
+ let (TPMap m) = tm
+ m[tp.Stamp]
+
+ member tm.ContainsKey(tp: Typar) =
+ let (TPMap m) = tm
+ m.ContainsKey(tp.Stamp)
+
+ member tm.TryGetValue(tp: Typar) =
+ let (TPMap m) = tm
+ m.TryGetValue(tp.Stamp)
+
+ member tm.TryFind(tp: Typar) =
+ let (TPMap m) = tm
+ m.TryFind(tp.Stamp)
+
+ member tm.Add(tp: Typar, x) =
+ let (TPMap m) = tm
+ TPMap(m.Add(tp.Stamp, x))
+
+ static member Empty: TyparMap<'T> = TPMap Map.empty
+
+ []
+ type TyconRefMap<'T>(imap: StampMap<'T>) =
+ member _.Item
+ with get (tcref: TyconRef) = imap[tcref.Stamp]
+
+ member _.TryFind(tcref: TyconRef) = imap.TryFind tcref.Stamp
+ member _.ContainsKey(tcref: TyconRef) = imap.ContainsKey tcref.Stamp
+ member _.Add (tcref: TyconRef) x = TyconRefMap(imap.Add(tcref.Stamp, x))
+ member _.Remove(tcref: TyconRef) = TyconRefMap(imap.Remove tcref.Stamp)
+ member _.IsEmpty = imap.IsEmpty
+ member _.TryGetValue(tcref: TyconRef) = imap.TryGetValue tcref.Stamp
+
+ static member Empty: TyconRefMap<'T> = TyconRefMap Map.empty
+
+ static member OfList vs =
+ (vs, TyconRefMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add x y)
+
+ []
+ []
+ type ValMap<'T>(imap: StampMap<'T>) =
+
+ member _.Contents = imap
+
+ member _.Item
+ with get (v: Val) = imap[v.Stamp]
+
+ member _.TryFind(v: Val) = imap.TryFind v.Stamp
+ member _.ContainsVal(v: Val) = imap.ContainsKey v.Stamp
+ member _.Add (v: Val) x = ValMap(imap.Add(v.Stamp, x))
+ member _.Remove(v: Val) = ValMap(imap.Remove(v.Stamp))
+ static member Empty = ValMap<'T> Map.empty
+ member _.IsEmpty = imap.IsEmpty
+
+ static member OfList vs =
+ (vs, ValMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add x y)
+
+ //--------------------------------------------------------------------------
+ // renamings
+ //--------------------------------------------------------------------------
+
+ type TyparInstantiation = (Typar * TType) list
+
+ type TyconRefRemap = TyconRefMap
+ type ValRemap = ValMap
+
+ let emptyTyconRefRemap: TyconRefRemap = TyconRefMap<_>.Empty
+ let emptyTyparInst = ([]: TyparInstantiation)
+
+ []
+ type Remap =
+ {
+ tpinst: TyparInstantiation
+
+ /// Values to remap
+ valRemap: ValRemap
+
+ /// TyconRefs to remap
+ tyconRefRemap: TyconRefRemap
+
+ /// Remove existing trait solutions?
+ removeTraitSolutions: bool
+ }
+
+ let emptyRemap =
+ {
+ tpinst = emptyTyparInst
+ tyconRefRemap = emptyTyconRefRemap
+ valRemap = ValMap.Empty
+ removeTraitSolutions = false
+ }
+
+ type Remap with
+ static member Empty = emptyRemap
+
+ //--------------------------------------------------------------------------
+ // Substitute for type variables and remap type constructors
+ //--------------------------------------------------------------------------
+
+ let addTyconRefRemap tcref1 tcref2 tmenv =
+ { tmenv with
+ tyconRefRemap = tmenv.tyconRefRemap.Add tcref1 tcref2
+ }
+
+ let isRemapEmpty remap =
+ isNil remap.tpinst && remap.tyconRefRemap.IsEmpty && remap.valRemap.IsEmpty
+
+ let rec instTyparRef tpinst ty tp =
+ match tpinst with
+ | [] -> ty
+ | (tpR, tyR) :: t -> if typarEq tp tpR then tyR else instTyparRef t ty tp
+
+ let remapTyconRef (tcmap: TyconRefMap<_>) tcref =
+ match tcmap.TryFind tcref with
+ | Some tcref -> tcref
+ | None -> tcref
+
+ let remapUnionCaseRef tcmap (UnionCaseRef(tcref, nm)) =
+ UnionCaseRef(remapTyconRef tcmap tcref, nm)
+
+ let remapRecdFieldRef tcmap (RecdFieldRef(tcref, nm)) =
+ RecdFieldRef(remapTyconRef tcmap tcref, nm)
+
+ let mkTyparInst (typars: Typars) tyargs =
+ (List.zip typars tyargs: TyparInstantiation)
+
+ let generalizeTypar tp = mkTyparTy tp
+ let generalizeTypars tps = List.map generalizeTypar tps
+
+ let rec remapTypeAux (tyenv: Remap) (ty: TType) =
+ let ty = stripTyparEqns ty
+
+ match ty with
+ | TType_var(tp, nullness) as ty ->
+ let res = instTyparRef tyenv.tpinst ty tp
+ addNullnessToTy nullness res
+
+ | TType_app(tcref, tinst, flags) as ty ->
+ match tyenv.tyconRefRemap.TryFind tcref with
+ | Some tcrefR -> TType_app(tcrefR, remapTypesAux tyenv tinst, flags)
+ | None ->
+ match tinst with
+ | [] -> ty // optimization to avoid re-allocation of TType_app node in the common case
+ | _ ->
+ // avoid reallocation on idempotent
+ let tinstR = remapTypesAux tyenv tinst
+
+ if tinst === tinstR then
+ ty
+ else
+ TType_app(tcref, tinstR, flags)
+
+ | TType_ucase(UnionCaseRef(tcref, n), tinst) ->
+ match tyenv.tyconRefRemap.TryFind tcref with
+ | Some tcrefR -> TType_ucase(UnionCaseRef(tcrefR, n), remapTypesAux tyenv tinst)
+ | None -> TType_ucase(UnionCaseRef(tcref, n), remapTypesAux tyenv tinst)
+
+ | TType_anon(anonInfo, l) as ty ->
+ let tupInfoR = remapTupInfoAux tyenv anonInfo.TupInfo
+ let lR = remapTypesAux tyenv l
+
+ if anonInfo.TupInfo === tupInfoR && l === lR then
+ ty
+ else
+ TType_anon(AnonRecdTypeInfo.Create(anonInfo.Assembly, tupInfoR, anonInfo.SortedIds), lR)
+
+ | TType_tuple(tupInfo, l) as ty ->
+ let tupInfoR = remapTupInfoAux tyenv tupInfo
+ let lR = remapTypesAux tyenv l
+
+ if tupInfo === tupInfoR && l === lR then
+ ty
+ else
+ TType_tuple(tupInfoR, lR)
+
+ | TType_fun(domainTy, rangeTy, flags) as ty ->
+ let domainTyR = remapTypeAux tyenv domainTy
+ let retTyR = remapTypeAux tyenv rangeTy
+
+ if domainTy === domainTyR && rangeTy === retTyR then
+ ty
+ else
+ TType_fun(domainTyR, retTyR, flags)
+
+ | TType_forall(tps, ty) ->
+ let tpsR, tyenv = copyAndRemapAndBindTypars tyenv tps
+ TType_forall(tpsR, remapTypeAux tyenv ty)
+
+ | TType_measure unt -> TType_measure(remapMeasureAux tyenv unt)
+
+ and remapMeasureAux tyenv unt =
+ match unt with
+ | Measure.One _ -> unt
+ | Measure.Const(entityRef, m) ->
+ match tyenv.tyconRefRemap.TryFind entityRef with
+ | Some tcref -> Measure.Const(tcref, m)
+ | None -> unt
+ | Measure.Prod(u1, u2, m) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2, m)
+ | Measure.RationalPower(u, q) -> Measure.RationalPower(remapMeasureAux tyenv u, q)
+ | Measure.Inv u -> Measure.Inv(remapMeasureAux tyenv u)
+ | Measure.Var tp as unt ->
+ match tp.Solution with
+ | None ->
+ match ListAssoc.tryFind typarEq tp tyenv.tpinst with
+ | Some tpTy ->
+ match tpTy with
+ | TType_measure unt -> unt
+ | TType_var(typar = typar) when tp.Kind = TyparKind.Measure ->
+ // This is a measure typar that is not yet solved, so we can't remap it
+ error (Error(FSComp.SR.tcExpectedTypeParamMarkedWithUnitOfMeasureAttribute (), typar.Range))
+ | _ -> failwith "remapMeasureAux: incorrect kinds"
+ | None -> unt
+ | Some(TType_measure unt) -> remapMeasureAux tyenv unt
+ | Some ty -> failwithf "incorrect kinds: %A" ty
+
+ and remapTupInfoAux _tyenv unt =
+ match unt with
+ | TupInfo.Const _ -> unt
+
+ and remapTypesAux tyenv types = List.mapq (remapTypeAux tyenv) types
+
+ and remapTyparConstraintsAux tyenv cs =
+ cs
+ |> List.choose (fun x ->
+ match x with
+ | TyparConstraint.CoercesTo(ty, m) -> Some(TyparConstraint.CoercesTo(remapTypeAux tyenv ty, m))
+ | TyparConstraint.MayResolveMember(traitInfo, m) -> Some(TyparConstraint.MayResolveMember(remapTraitInfo tyenv traitInfo, m))
+ | TyparConstraint.DefaultsTo(priority, ty, m) -> Some(TyparConstraint.DefaultsTo(priority, remapTypeAux tyenv ty, m))
+ | TyparConstraint.IsEnum(underlyingTy, m) -> Some(TyparConstraint.IsEnum(remapTypeAux tyenv underlyingTy, m))
+ | TyparConstraint.IsDelegate(argTys, retTy, m) ->
+ Some(TyparConstraint.IsDelegate(remapTypeAux tyenv argTys, remapTypeAux tyenv retTy, m))
+ | TyparConstraint.SimpleChoice(tys, m) -> Some(TyparConstraint.SimpleChoice(remapTypesAux tyenv tys, m))
+ | TyparConstraint.SupportsComparison _
+ | TyparConstraint.SupportsEquality _
+ | TyparConstraint.SupportsNull _
+ | TyparConstraint.NotSupportsNull _
+ | TyparConstraint.IsUnmanaged _
+ | TyparConstraint.AllowsRefStruct _
+ | TyparConstraint.IsNonNullableStruct _
+ | TyparConstraint.IsReferenceType _
+ | TyparConstraint.RequiresDefaultConstructor _ -> Some x)
+
+ and remapTraitInfo tyenv (TTrait(tys, nm, flags, argTys, retTy, source, slnCell)) =
+ let slnCell =
+ match slnCell.Value with
+ | None -> None
+ | _ when tyenv.removeTraitSolutions -> None
+ | Some sln ->
+ let sln =
+ match sln with
+ | ILMethSln(ty, extOpt, ilMethRef, minst, staticTyOpt) ->
+ ILMethSln(
+ remapTypeAux tyenv ty,
+ extOpt,
+ ilMethRef,
+ remapTypesAux tyenv minst,
+ Option.map (remapTypeAux tyenv) staticTyOpt
+ )
+ | FSMethSln(ty, vref, minst, staticTyOpt) ->
+ FSMethSln(
+ remapTypeAux tyenv ty,
+ remapValRef tyenv vref,
+ remapTypesAux tyenv minst,
+ Option.map (remapTypeAux tyenv) staticTyOpt
+ )
+ | FSRecdFieldSln(tinst, rfref, isSet) ->
+ FSRecdFieldSln(remapTypesAux tyenv tinst, remapRecdFieldRef tyenv.tyconRefRemap rfref, isSet)
+ | FSAnonRecdFieldSln(anonInfo, tinst, n) -> FSAnonRecdFieldSln(anonInfo, remapTypesAux tyenv tinst, n)
+ | BuiltInSln -> BuiltInSln
+ | ClosedExprSln e -> ClosedExprSln e // no need to remap because it is a closed expression, referring only to external types
+
+ Some sln
+
+ let tysR = remapTypesAux tyenv tys
+ let argTysR = remapTypesAux tyenv argTys
+ let retTyR = Option.map (remapTypeAux tyenv) retTy
+
+ // Note: we reallocate a new solution cell on every traversal of a trait constraint
+ // This feels incorrect for trait constraints that are quantified: it seems we should have
+ // formal binders for trait constraints when they are quantified, just as
+ // we have formal binders for type variables.
+ //
+ // The danger here is that a solution for one syntactic occurrence of a trait constraint won't
+ // be propagated to other, "linked" solutions. However trait constraints don't appear in any algebra
+ // in the same way as types
+ let newSlnCell = ref slnCell
+
+ TTrait(tysR, nm, flags, argTysR, retTyR, source, newSlnCell)
+
+ and bindTypars tps tyargs tpinst =
+ match tps with
+ | [] -> tpinst
+ | _ -> List.map2 (fun tp tyarg -> (tp, tyarg)) tps tyargs @ tpinst
+
+ // This version is used to remap most type parameters, e.g. ones bound at tycons, vals, records
+ // See notes below on remapTypeFull for why we have a function that accepts remapAttribs as an argument
+ and copyAndRemapAndBindTyparsFull remapAttrib tyenv tps =
+ match tps with
+ | [] -> tps, tyenv
+ | _ ->
+ let tpsR = copyTypars false tps
+
+ let tyenv =
+ { tyenv with
+ tpinst = bindTypars tps (generalizeTypars tpsR) tyenv.tpinst
+ }
+
+ (tps, tpsR)
+ ||> List.iter2 (fun tporig tp ->
+ tp.SetConstraints(remapTyparConstraintsAux tyenv tporig.Constraints)
+ tp.SetAttribs(tporig.Attribs |> remapAttrib))
+
+ tpsR, tyenv
+
+ // copies bound typars, extends tpinst
+ and copyAndRemapAndBindTypars tyenv tps =
+ copyAndRemapAndBindTyparsFull (fun _ -> []) tyenv tps
+
+ and remapValLinkage tyenv (vlink: ValLinkageFullKey) =
+ let tyOpt = vlink.TypeForLinkage
+
+ let tyOptR =
+ match tyOpt with
+ | None -> tyOpt
+ | Some ty ->
+ let tyR = remapTypeAux tyenv ty
+ if ty === tyR then tyOpt else Some tyR
+
+ if tyOpt === tyOptR then
+ vlink
+ else
+ ValLinkageFullKey(vlink.PartialKey, tyOptR)
+
+ and remapNonLocalValRef tyenv (nlvref: NonLocalValOrMemberRef) =
+ let eref = nlvref.EnclosingEntity
+ let erefR = remapTyconRef tyenv.tyconRefRemap eref
+ let vlink = nlvref.ItemKey
+ let vlinkR = remapValLinkage tyenv vlink
+
+ if eref === erefR && vlink === vlinkR then
+ nlvref
+ else
+ {
+ EnclosingEntity = erefR
+ ItemKey = vlinkR
+ }
+
+ and remapValRef tmenv (vref: ValRef) =
+ match tmenv.valRemap.TryFind vref.Deref with
+ | None ->
+ if vref.IsLocalRef then
+ vref
+ else
+ let nlvref = vref.nlr
+ let nlvrefR = remapNonLocalValRef tmenv nlvref
+ if nlvref === nlvrefR then vref else VRefNonLocal nlvrefR
+ | Some res -> res
+
+ let remapType tyenv x =
+ if isRemapEmpty tyenv then x else remapTypeAux tyenv x
+
+ let remapTypes tyenv x =
+ if isRemapEmpty tyenv then x else remapTypesAux tyenv x
+
+ /// Use this one for any type that may be a forall type where the type variables may contain attributes
+ /// Logically speaking this is mutually recursive with remapAttribImpl defined much later in this file,
+ /// because types may contain forall types that contain attributes, which need to be remapped.
+ /// We currently break the recursion by passing in remapAttribImpl as a function parameter.
+ /// Use this one for any type that may be a forall type where the type variables may contain attributes
+ let remapTypeFull remapAttrib tyenv ty =
+ if isRemapEmpty tyenv then
+ ty
+ else
+ match stripTyparEqns ty with
+ | TType_forall(tps, tau) ->
+ let tpsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv tps
+ TType_forall(tpsR, remapType tyenvinner tau)
+ | _ -> remapType tyenv ty
+
+ let remapParam tyenv (TSlotParam(nm, ty, fl1, fl2, fl3, attribs) as x) =
+ if isRemapEmpty tyenv then
+ x
+ else
+ TSlotParam(nm, remapTypeAux tyenv ty, fl1, fl2, fl3, attribs)
+
+ let remapSlotSig remapAttrib tyenv (TSlotSig(nm, ty, ctps, methTypars, paraml, retTy) as x) =
+ if isRemapEmpty tyenv then
+ x
+ else
+ let tyR = remapTypeAux tyenv ty
+ let ctpsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv ctps
+
+ let methTyparsR, tyenvinner =
+ copyAndRemapAndBindTyparsFull remapAttrib tyenvinner methTypars
+
+ TSlotSig(
+ nm,
+ tyR,
+ ctpsR,
+ methTyparsR,
+ List.mapSquared (remapParam tyenvinner) paraml,
+ Option.map (remapTypeAux tyenvinner) retTy
+ )
+
+ let mkInstRemap tpinst =
+ {
+ tyconRefRemap = emptyTyconRefRemap
+ tpinst = tpinst
+ valRemap = ValMap.Empty
+ removeTraitSolutions = false
+ }
+
+ // entry points for "typar -> TType" instantiation
+ let instType tpinst x =
+ if isNil tpinst then
+ x
+ else
+ remapTypeAux (mkInstRemap tpinst) x
+
+ let instTypes tpinst x =
+ if isNil tpinst then
+ x
+ else
+ remapTypesAux (mkInstRemap tpinst) x
+
+ let instTrait tpinst x =
+ if isNil tpinst then
+ x
+ else
+ remapTraitInfo (mkInstRemap tpinst) x
+
+ let instTyparConstraints tpinst x =
+ if isNil tpinst then
+ x
+ else
+ remapTyparConstraintsAux (mkInstRemap tpinst) x
+
+ let instSlotSig tpinst ss =
+ remapSlotSig (fun _ -> []) (mkInstRemap tpinst) ss
+
+ let copySlotSig ss =
+ remapSlotSig (fun _ -> []) Remap.Empty ss
+
+ let mkTyparToTyparRenaming tpsorig tps =
+ let tinst = generalizeTypars tps
+ mkTyparInst tpsorig tinst, tinst
+
+ let mkTyconInst (tycon: Tycon) tinst = mkTyparInst tycon.TyparsNoRange tinst
+ let mkTyconRefInst (tcref: TyconRef) tinst = mkTyconInst tcref.Deref tinst
+
+[]
+module internal MeasureOps =
+
+ //---------------------------------------------------------------------------
+ // Basic equalities
+ //---------------------------------------------------------------------------
+
+ let tyconRefEq (g: TcGlobals) tcref1 tcref2 =
+ primEntityRefEq g.compilingFSharpCore g.fslibCcu tcref1 tcref2
+
+ let valRefEq (g: TcGlobals) vref1 vref2 =
+ primValRefEq g.compilingFSharpCore g.fslibCcu vref1 vref2
+
+ //---------------------------------------------------------------------------
+ // Remove inference equations and abbreviations from units
+ //---------------------------------------------------------------------------
+
+ let reduceTyconRefAbbrevMeasureable (tcref: TyconRef) =
+ let abbrev = tcref.TypeAbbrev
+
+ match abbrev with
+ | Some(TType_measure ms) -> ms
+ | _ -> invalidArg "tcref" "not a measure abbreviation, or incorrect kind"
+
+ let rec stripUnitEqnsFromMeasureAux canShortcut unt =
+ match stripUnitEqnsAux canShortcut unt with
+ | Measure.Const(tyconRef = tcref) when tcref.IsTypeAbbrev ->
+ stripUnitEqnsFromMeasureAux canShortcut (reduceTyconRefAbbrevMeasureable tcref)
+ | m -> m
+
+ let stripUnitEqnsFromMeasure m = stripUnitEqnsFromMeasureAux false m
+
+ //---------------------------------------------------------------------------
+ // Basic unit stuff
+ //---------------------------------------------------------------------------
+
+ /// What is the contribution of unit-of-measure constant ucref to unit-of-measure expression measure?
+ let rec MeasureExprConExponent g abbrev ucref unt =
+ match
+ (if abbrev then
+ stripUnitEqnsFromMeasure unt
+ else
+ stripUnitEqns unt)
+ with
+ | Measure.Const(tyconRef = ucrefR) ->
+ if tyconRefEq g ucrefR ucref then
+ OneRational
+ else
+ ZeroRational
+ | Measure.Inv untR -> NegRational(MeasureExprConExponent g abbrev ucref untR)
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) ->
+ AddRational (MeasureExprConExponent g abbrev ucref unt1) (MeasureExprConExponent g abbrev ucref unt2)
+ | Measure.RationalPower(measure = untR; power = q) -> MulRational (MeasureExprConExponent g abbrev ucref untR) q
+ | _ -> ZeroRational
+
+ /// What is the contribution of unit-of-measure constant ucref to unit-of-measure expression measure
+ /// after remapping tycons?
+ let rec MeasureConExponentAfterRemapping g r ucref unt =
+ match stripUnitEqnsFromMeasure unt with
+ | Measure.Const(tyconRef = ucrefR) ->
+ if tyconRefEq g (r ucrefR) ucref then
+ OneRational
+ else
+ ZeroRational
+ | Measure.Inv untR -> NegRational(MeasureConExponentAfterRemapping g r ucref untR)
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) ->
+ AddRational (MeasureConExponentAfterRemapping g r ucref unt1) (MeasureConExponentAfterRemapping g r ucref unt2)
+ | Measure.RationalPower(measure = untR; power = q) -> MulRational (MeasureConExponentAfterRemapping g r ucref untR) q
+ | _ -> ZeroRational
+
+ /// What is the contribution of unit-of-measure variable tp to unit-of-measure expression unt?
+ let rec MeasureVarExponent tp unt =
+ match stripUnitEqnsFromMeasure unt with
+ | Measure.Var tpR -> if typarEq tp tpR then OneRational else ZeroRational
+ | Measure.Inv untR -> NegRational(MeasureVarExponent tp untR)
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) -> AddRational (MeasureVarExponent tp unt1) (MeasureVarExponent tp unt2)
+ | Measure.RationalPower(measure = untR; power = q) -> MulRational (MeasureVarExponent tp untR) q
+ | _ -> ZeroRational
+
+ /// List the *literal* occurrences of unit variables in a unit expression, without repeats
+ let ListMeasureVarOccs unt =
+ let rec gather acc unt =
+ match stripUnitEqnsFromMeasure unt with
+ | Measure.Var tp -> if List.exists (typarEq tp) acc then acc else tp :: acc
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) -> gather (gather acc unt1) unt2
+ | Measure.RationalPower(measure = untR) -> gather acc untR
+ | Measure.Inv untR -> gather acc untR
+ | _ -> acc
+
+ gather [] unt
+
+ /// List the *observable* occurrences of unit variables in a unit expression, without repeats, paired with their non-zero exponents
+ let ListMeasureVarOccsWithNonZeroExponents untexpr =
+ let rec gather acc unt =
+ match stripUnitEqnsFromMeasure unt with
+ | Measure.Var tp ->
+ if List.exists (fun (tpR, _) -> typarEq tp tpR) acc then
+ acc
+ else
+ let e = MeasureVarExponent tp untexpr
+ if e = ZeroRational then acc else (tp, e) :: acc
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) -> gather (gather acc unt1) unt2
+ | Measure.Inv untR -> gather acc untR
+ | Measure.RationalPower(measure = untR) -> gather acc untR
+ | _ -> acc
+
+ gather [] untexpr
+
+ /// List the *observable* occurrences of unit constants in a unit expression, without repeats, paired with their non-zero exponents
+ let ListMeasureConOccsWithNonZeroExponents g eraseAbbrevs untexpr =
+ let rec gather acc unt =
+ match
+ (if eraseAbbrevs then
+ stripUnitEqnsFromMeasure unt
+ else
+ stripUnitEqns unt)
+ with
+ | Measure.Const(tyconRef = c) ->
+ if List.exists (fun (cR, _) -> tyconRefEq g c cR) acc then
+ acc
+ else
+ let e = MeasureExprConExponent g eraseAbbrevs c untexpr
+ if e = ZeroRational then acc else (c, e) :: acc
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) -> gather (gather acc unt1) unt2
+ | Measure.Inv untR -> gather acc untR
+ | Measure.RationalPower(measure = untR) -> gather acc untR
+ | _ -> acc
+
+ gather [] untexpr
+
+ /// List the *literal* occurrences of unit constants in a unit expression, without repeats,
+ /// and after applying a remapping function r to tycons
+ let ListMeasureConOccsAfterRemapping g r unt =
+ let rec gather acc unt =
+ match stripUnitEqnsFromMeasure unt with
+ | Measure.Const(tyconRef = c) ->
+ if List.exists (tyconRefEq g (r c)) acc then
+ acc
+ else
+ r c :: acc
+ | Measure.Prod(measure1 = unt1; measure2 = unt2) -> gather (gather acc unt1) unt2
+ | Measure.RationalPower(measure = untR) -> gather acc untR
+ | Measure.Inv untR -> gather acc untR
+ | _ -> acc
+
+ gather [] unt
+
+ /// Construct a measure expression representing the n'th power of a measure
+ let MeasurePower u n =
+ if n = 1 then u
+ elif n = 0 then Measure.One(range0)
+ else Measure.RationalPower(u, intToRational n)
+
+ let MeasureProdOpt m1 m2 =
+ match m1, m2 with
+ | Measure.One _, _ -> m2
+ | _, Measure.One _ -> m1
+ | _, _ -> Measure.Prod(m1, m2, unionRanges m1.Range m2.Range)
+
+ /// Construct a measure expression representing the product of a list of measures
+ let ProdMeasures ms =
+ match ms with
+ | [] -> Measure.One(range0)
+ | m :: ms -> List.foldBack MeasureProdOpt ms m
+
+ let isDimensionless g ty =
+ match stripTyparEqns ty with
+ | TType_measure unt ->
+ isNil (ListMeasureVarOccsWithNonZeroExponents unt)
+ && isNil (ListMeasureConOccsWithNonZeroExponents g true unt)
+ | _ -> false
+
+ let destUnitParMeasure g unt =
+ let vs = ListMeasureVarOccsWithNonZeroExponents unt
+ let cs = ListMeasureConOccsWithNonZeroExponents g true unt
+
+ match vs, cs with
+ | [ (v, e) ], [] when e = OneRational -> v
+ | _, _ -> failwith "destUnitParMeasure: not a unit-of-measure parameter"
+
+ let isUnitParMeasure g unt =
+ let vs = ListMeasureVarOccsWithNonZeroExponents unt
+ let cs = ListMeasureConOccsWithNonZeroExponents g true unt
+
+ match vs, cs with
+ | [ (_, e) ], [] when e = OneRational -> true
+ | _, _ -> false
+
+ let normalizeMeasure g ms =
+ let vs = ListMeasureVarOccsWithNonZeroExponents ms
+ let cs = ListMeasureConOccsWithNonZeroExponents g false ms
+
+ match vs, cs with
+ | [], [] -> Measure.One(ms.Range)
+ | [ (v, e) ], [] when e = OneRational -> Measure.Var v
+ | vs, cs ->
+ List.foldBack
+ (fun (v, e) ->
+ fun unt ->
+ let measureVar = Measure.Var(v)
+ let measureRational = Measure.RationalPower(measureVar, e)
+ Measure.Prod(measureRational, unt, unionRanges measureRational.Range unt.Range))
+ vs
+ (List.foldBack
+ (fun (c, e) ->
+ fun unt ->
+ let measureConst = Measure.Const(c, c.Range)
+ let measureRational = Measure.RationalPower(measureConst, e)
+ let prodM = unionRanges measureConst.Range unt.Range
+ Measure.Prod(measureRational, unt, prodM))
+ cs
+ (Measure.One(ms.Range)))
+
+ let tryNormalizeMeasureInType g ty =
+ match ty with
+ | TType_measure(Measure.Var v) ->
+ match v.Solution with
+ | Some(TType_measure ms) ->
+ v.typar_solution <- Some(TType_measure(normalizeMeasure g ms))
+ ty
+ | _ -> ty
+ | _ -> ty
+
+[]
+module internal TypeBuilders =
+
+ //---------------------------------------------------------------------------
+ // Some basic type builders
+ //---------------------------------------------------------------------------
+
+ let mkForallTy d r = TType_forall(d, r)
+
+ let mkForallTyIfNeeded d r = if isNil d then r else mkForallTy d r
+
+ let (+->) d r = mkForallTyIfNeeded d r
+
+ //---------------------------------------------------------------------------
+ // Make some common types
+ //---------------------------------------------------------------------------
+
+ let mkFunTy (g: TcGlobals) domainTy rangeTy =
+ TType_fun(domainTy, rangeTy, g.knownWithoutNull)
+
+ let mkIteratedFunTy g dl r = List.foldBack (mkFunTy g) dl r
+
+ let mkNativePtrTy (g: TcGlobals) ty =
+ assert g.nativeptr_tcr.CanDeref // this should always be available, but check anyway
+ TType_app(g.nativeptr_tcr, [ ty ], g.knownWithoutNull)
+
+ let mkByrefTy (g: TcGlobals) ty =
+ assert g.byref_tcr.CanDeref // this should always be available, but check anyway
+ TType_app(g.byref_tcr, [ ty ], g.knownWithoutNull)
+
+ let mkInByrefTy (g: TcGlobals) ty =
+ if g.inref_tcr.CanDeref then // If not using sufficient FSharp.Core, then inref = byref, see RFC FS-1053.md
+ TType_app(g.inref_tcr, [ ty ], g.knownWithoutNull)
+ else
+ mkByrefTy g ty
+
+ let mkOutByrefTy (g: TcGlobals) ty =
+ if g.outref_tcr.CanDeref then // If not using sufficient FSharp.Core, then outref = byref, see RFC FS-1053.md
+ TType_app(g.outref_tcr, [ ty ], g.knownWithoutNull)
+ else
+ mkByrefTy g ty
+
+ let mkByrefTyWithFlag g readonly ty =
+ if readonly then mkInByrefTy g ty else mkByrefTy g ty
+
+ let mkByref2Ty (g: TcGlobals) ty1 ty2 =
+ assert g.byref2_tcr.CanDeref // check we are using sufficient FSharp.Core, caller should check this
+ TType_app(g.byref2_tcr, [ ty1; ty2 ], g.knownWithoutNull)
+
+ let mkVoidPtrTy (g: TcGlobals) =
+ assert g.voidptr_tcr.CanDeref // check we are using sufficient FSharp.Core, caller should check this
+ TType_app(g.voidptr_tcr, [], g.knownWithoutNull)
+
+ let mkByrefTyWithInference (g: TcGlobals) ty1 ty2 =
+ if g.byref2_tcr.CanDeref then // If not using sufficient FSharp.Core, then inref = byref, see RFC FS-1053.md
+ TType_app(g.byref2_tcr, [ ty1; ty2 ], g.knownWithoutNull)
+ else
+ TType_app(g.byref_tcr, [ ty1 ], g.knownWithoutNull)
+
+ let mkArrayTy (g: TcGlobals) rank nullness ty m =
+ if rank < 1 || rank > 32 then
+ errorR (Error(FSComp.SR.tastopsMaxArrayThirtyTwo rank, m))
+ TType_app(g.il_arr_tcr_map[3], [ ty ], nullness)
+ else
+ TType_app(g.il_arr_tcr_map[rank - 1], [ ty ], nullness)
+
+ //--------------------------------------------------------------------------
+ // Tuple compilation (types)
+ //------------------------------------------------------------------------
+
+ let maxTuple = 8
+ let goodTupleFields = maxTuple - 1
+
+ let isCompiledTupleTyconRef g tcref =
+ tyconRefEq g g.ref_tuple1_tcr tcref
+ || tyconRefEq g g.ref_tuple2_tcr tcref
+ || tyconRefEq g g.ref_tuple3_tcr tcref
+ || tyconRefEq g g.ref_tuple4_tcr tcref
+ || tyconRefEq g g.ref_tuple5_tcr tcref
+ || tyconRefEq g g.ref_tuple6_tcr tcref
+ || tyconRefEq g g.ref_tuple7_tcr tcref
+ || tyconRefEq g g.ref_tuple8_tcr tcref
+ || tyconRefEq g g.struct_tuple1_tcr tcref
+ || tyconRefEq g g.struct_tuple2_tcr tcref
+ || tyconRefEq g g.struct_tuple3_tcr tcref
+ || tyconRefEq g g.struct_tuple4_tcr tcref
+ || tyconRefEq g g.struct_tuple5_tcr tcref
+ || tyconRefEq g g.struct_tuple6_tcr tcref
+ || tyconRefEq g g.struct_tuple7_tcr tcref
+ || tyconRefEq g g.struct_tuple8_tcr tcref
+
+ let mkCompiledTupleTyconRef (g: TcGlobals) isStruct n =
+ if n = 1 then
+ (if isStruct then g.struct_tuple1_tcr else g.ref_tuple1_tcr)
+ elif n = 2 then
+ (if isStruct then g.struct_tuple2_tcr else g.ref_tuple2_tcr)
+ elif n = 3 then
+ (if isStruct then g.struct_tuple3_tcr else g.ref_tuple3_tcr)
+ elif n = 4 then
+ (if isStruct then g.struct_tuple4_tcr else g.ref_tuple4_tcr)
+ elif n = 5 then
+ (if isStruct then g.struct_tuple5_tcr else g.ref_tuple5_tcr)
+ elif n = 6 then
+ (if isStruct then g.struct_tuple6_tcr else g.ref_tuple6_tcr)
+ elif n = 7 then
+ (if isStruct then g.struct_tuple7_tcr else g.ref_tuple7_tcr)
+ elif n = 8 then
+ (if isStruct then g.struct_tuple8_tcr else g.ref_tuple8_tcr)
+ else
+ failwithf "mkCompiledTupleTyconRef, n = %d" n
+
+ /// Convert from F# tuple types to .NET tuple types
+ let rec mkCompiledTupleTy g isStruct tupElemTys =
+ let n = List.length tupElemTys
+
+ if n < maxTuple then
+ TType_app(mkCompiledTupleTyconRef g isStruct n, tupElemTys, g.knownWithoutNull)
+ else
+ let tysA, tysB = List.splitAfter goodTupleFields tupElemTys
+
+ TType_app(
+ (if isStruct then g.struct_tuple8_tcr else g.ref_tuple8_tcr),
+ tysA @ [ mkCompiledTupleTy g isStruct tysB ],
+ g.knownWithoutNull
+ )
+
+ /// Convert from F# tuple types to .NET tuple types, but only the outermost level
+ let mkOuterCompiledTupleTy g isStruct tupElemTys =
+ let n = List.length tupElemTys
+
+ if n < maxTuple then
+ TType_app(mkCompiledTupleTyconRef g isStruct n, tupElemTys, g.knownWithoutNull)
+ else
+ let tysA, tysB = List.splitAfter goodTupleFields tupElemTys
+ let tcref = (if isStruct then g.struct_tuple8_tcr else g.ref_tuple8_tcr)
+ // In the case of an 8-tuple we add the Tuple<_> marker. For other sizes we keep the type
+ // as a regular F# tuple type.
+ match tysB with
+ | [ tyB ] ->
+ let marker =
+ TType_app(mkCompiledTupleTyconRef g isStruct 1, [ tyB ], g.knownWithoutNull)
+
+ TType_app(tcref, tysA @ [ marker ], g.knownWithoutNull)
+ | _ -> TType_app(tcref, tysA @ [ TType_tuple(mkTupInfo isStruct, tysB) ], g.knownWithoutNull)
+
+[]
+module internal TypeAbbreviations =
+
+ //---------------------------------------------------------------------------
+ // Remove inference equations and abbreviations from types
+ //---------------------------------------------------------------------------
+
+ let applyTyconAbbrev abbrevTy tycon tyargs =
+ if isNil tyargs then
+ abbrevTy
+ else
+ instType (mkTyconInst tycon tyargs) abbrevTy
+
+ let reduceTyconAbbrev (tycon: Tycon) tyargs =
+ let abbrev = tycon.TypeAbbrev
+
+ match abbrev with
+ | None -> invalidArg "tycon" "this type definition is not an abbreviation"
+ | Some abbrevTy -> applyTyconAbbrev abbrevTy tycon tyargs
+
+ let reduceTyconRefAbbrev (tcref: TyconRef) tyargs = reduceTyconAbbrev tcref.Deref tyargs
+
+ let reduceTyconMeasureableOrProvided (g: TcGlobals) (tycon: Tycon) tyargs =
+#if NO_TYPEPROVIDERS
+ ignore g // otherwise g would be unused
+#endif
+ let repr = tycon.TypeReprInfo
+
+ match repr with
+ | TMeasureableRepr ty ->
+ if isNil tyargs then
+ ty
+ else
+ instType (mkTyconInst tycon tyargs) ty
+#if !NO_TYPEPROVIDERS
+ | TProvidedTypeRepr info when info.IsErased -> info.BaseTypeForErased(range0, g.obj_ty_withNulls)
+#endif
+ | _ -> invalidArg "tc" "this type definition is not a refinement"
+
+ let reduceTyconRefMeasureableOrProvided (g: TcGlobals) (tcref: TyconRef) tyargs =
+ reduceTyconMeasureableOrProvided g tcref.Deref tyargs
+
+[]
+module internal TypeDecomposition =
+
+ let rec stripTyEqnsA g canShortcut ty =
+ let ty = stripTyparEqnsAux KnownWithoutNull canShortcut ty
+
+ match ty with
+ | TType_app(tcref, tinst, nullness) ->
+ let tycon = tcref.Deref
+
+ match tycon.TypeAbbrev with
+ | Some abbrevTy ->
+ let reducedTy = applyTyconAbbrev abbrevTy tycon tinst
+ let reducedTy2 = addNullnessToTy nullness reducedTy
+ stripTyEqnsA g canShortcut reducedTy2
+ | None ->
+ // This is the point where we get to add additional conditional normalizing equations
+ // into the type system. Such power!
+ //
+ // Add the equation byref<'T> = byref<'T, ByRefKinds.InOut> for when using sufficient FSharp.Core
+ // See RFC FS-1053.md
+ if
+ tyconRefEq g tcref g.byref_tcr
+ && g.byref2_tcr.CanDeref
+ && g.byrefkind_InOut_tcr.CanDeref
+ then
+ mkByref2Ty g tinst[0] (TType_app(g.byrefkind_InOut_tcr, [], g.knownWithoutNull))
+
+ // Add the equation double<1> = double for units of measure.
+ elif tycon.IsMeasureableReprTycon && List.forall (isDimensionless g) tinst then
+ let reducedTy = reduceTyconMeasureableOrProvided g tycon tinst
+ let reducedTy2 = addNullnessToTy nullness reducedTy
+ stripTyEqnsA g canShortcut reducedTy2
+ else
+ ty
+ | ty -> ty
+
+ let stripTyEqns g ty = stripTyEqnsA g false ty
+
+ let evalTupInfoIsStruct aexpr =
+ match aexpr with
+ | TupInfo.Const b -> b
+
+ let evalAnonInfoIsStruct (anonInfo: AnonRecdTypeInfo) = evalTupInfoIsStruct anonInfo.TupInfo
+
+ /// This erases outermost occurrences of inference equations, type abbreviations, non-generated provided types
+ /// and measurable types (float<_>).
+ /// It also optionally erases all "compilation representations", i.e. function and
+ /// tuple types, and also "nativeptr<'T> --> System.IntPtr"
+ let rec stripTyEqnsAndErase eraseFuncAndTuple (g: TcGlobals) ty =
+ let ty = stripTyEqns g ty
+
+ match ty with
+ | TType_app(tcref, args, nullness) ->
+ let tycon = tcref.Deref
+
+ if tycon.IsErased then
+ let reducedTy = reduceTyconMeasureableOrProvided g tycon args
+ let reducedTy2 = addNullnessToTy nullness reducedTy
+ stripTyEqnsAndErase eraseFuncAndTuple g reducedTy2
+ elif tyconRefEq g tcref g.nativeptr_tcr && eraseFuncAndTuple then
+ // Regression fix (issue #7428): nativeptr<'T> erases to ilsigptr<'T>, not nativeint
+ stripTyEqnsAndErase eraseFuncAndTuple g (TType_app(g.ilsigptr_tcr, args, nullness))
+ else
+ ty
+
+ | TType_fun(domainTy, rangeTy, nullness) when eraseFuncAndTuple -> TType_app(g.fastFunc_tcr, [ domainTy; rangeTy ], nullness)
+
+ | TType_tuple(tupInfo, l) when eraseFuncAndTuple -> mkCompiledTupleTy g (evalTupInfoIsStruct tupInfo) l
+
+ | ty -> ty
+
+ let stripTyEqnsAndMeasureEqns g ty = stripTyEqnsAndErase false g ty
+
+ type Erasure =
+ | EraseAll
+ | EraseMeasures
+ | EraseNone
+
+ let stripTyEqnsWrtErasure erasureFlag g ty =
+ match erasureFlag with
+ | EraseAll -> stripTyEqnsAndErase true g ty
+ | EraseMeasures -> stripTyEqnsAndErase false g ty
+ | _ -> stripTyEqns g ty
+
+ let rec stripExnEqns (eref: TyconRef) =
+ let exnc = eref.Deref
+
+ match exnc.ExceptionInfo with
+ | TExnAbbrevRepr eref -> stripExnEqns eref
+ | _ -> exnc
+
+ let primDestForallTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_forall(tyvs, tau) -> (tyvs, tau)
+ | _ -> failwith "primDestForallTy: not a forall type")
+
+ let destFunTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_fun(domainTy, rangeTy, _) -> (domainTy, rangeTy)
+ | _ -> failwith "destFunTy: not a function type")
+
+ let destAnyTupleTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple(tupInfo, l) -> tupInfo, l
+ | _ -> failwith "destAnyTupleTy: not a tuple type")
+
+ let destRefTupleTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple(tupInfo, l) when not (evalTupInfoIsStruct tupInfo) -> l
+ | _ -> failwith "destRefTupleTy: not a reference tuple type")
+
+ let destStructTupleTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple(tupInfo, l) when evalTupInfoIsStruct tupInfo -> l
+ | _ -> failwith "destStructTupleTy: not a struct tuple type")
+
+ let destTyparTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var(v, _) -> v
+ | _ -> failwith "destTyparTy: not a typar type")
+
+ let destAnyParTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var(v, _) -> v
+ | TType_measure unt -> destUnitParMeasure g unt
+ | _ -> failwith "destAnyParTy: not a typar or unpar type")
+
+ let destMeasureTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_measure m -> m
+ | _ -> failwith "destMeasureTy: not a unit-of-measure type")
+
+ let destAnonRecdTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_anon(anonInfo, tys) -> anonInfo, tys
+ | _ -> failwith "destAnonRecdTy: not an anonymous record type")
+
+ let destStructAnonRecdTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_anon(anonInfo, tys) when evalAnonInfoIsStruct anonInfo -> tys
+ | _ -> failwith "destAnonRecdTy: not a struct anonymous record type")
+
+ let isFunTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_fun _ -> true
+ | _ -> false)
+
+ let isForallTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_forall _ -> true
+ | _ -> false)
+
+ let isAnyTupleTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple _ -> true
+ | _ -> false)
+
+ let isRefTupleTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple(tupInfo, _) -> not (evalTupInfoIsStruct tupInfo)
+ | _ -> false)
+
+ let isStructTupleTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple(tupInfo, _) -> evalTupInfoIsStruct tupInfo
+ | _ -> false)
+
+ let isAnonRecdTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_anon _ -> true
+ | _ -> false)
+
+ let isStructAnonRecdTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_anon(anonInfo, _) -> evalAnonInfoIsStruct anonInfo
+ | _ -> false)
+
+ let isUnionTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsUnionTycon
+ | _ -> false)
+
+ let isStructUnionTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsUnionTycon && tcref.Deref.entity_flags.IsStructRecordOrUnionType
+ | _ -> false)
+
+ let isReprHiddenTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsHiddenReprTycon
+ | _ -> false)
+
+ let isFSharpObjModelTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsFSharpObjectModelTycon
+ | _ -> false)
+
+ let isRecdTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsRecordTycon
+ | _ -> false)
+
+ let isFSharpStructOrEnumTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsFSharpStructOrEnumTycon
+ | _ -> false)
+
+ let isFSharpEnumTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref.IsFSharpEnumTycon
+ | _ -> false)
+
+ let isTyparTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var _ -> true
+ | _ -> false)
+
+ let isAnyParTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var _ -> true
+ | TType_measure unt -> isUnitParMeasure g unt
+ | _ -> false)
+
+ let isMeasureTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_measure _ -> true
+ | _ -> false)
+
+ let isProvenUnionCaseTy ty =
+ match ty with
+ | TType_ucase _ -> true
+ | _ -> false
+
+ let mkWoNullAppTy tcref tyargs =
+ TType_app(tcref, tyargs, KnownWithoutNull)
+
+ let mkProvenUnionCaseTy ucref tyargs = TType_ucase(ucref, tyargs)
+
+ let isAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app _ -> true
+ | _ -> false)
+
+ let tryAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, tinst, _) -> ValueSome(tcref, tinst)
+ | _ -> ValueNone)
+
+ let destAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, tinst, _) -> tcref, tinst
+ | _ -> failwith "destAppTy")
+
+ let tcrefOfAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> tcref
+ | _ -> failwith "tcrefOfAppTy")
+
+ let argsOfAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(_, tinst, _) -> tinst
+ | _ -> [])
+
+ let tryDestTyparTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var(v, _) -> ValueSome v
+ | _ -> ValueNone)
+
+ let tryDestFunTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_fun(domainTy, rangeTy, _) -> ValueSome(domainTy, rangeTy)
+ | _ -> ValueNone)
+
+ let tryTcrefOfAppTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, _, _) -> ValueSome tcref
+ | _ -> ValueNone)
+
+ let tryDestAnonRecdTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_anon(anonInfo, tys) -> ValueSome(anonInfo, tys)
+ | _ -> ValueNone)
+
+ let tryAnyParTy g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var(v, _) -> ValueSome v
+ | TType_measure unt when isUnitParMeasure g unt -> ValueSome(destUnitParMeasure g unt)
+ | _ -> ValueNone)
+
+ let tryAnyParTyOption g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_var(v, _) -> Some v
+ | TType_measure unt when isUnitParMeasure g unt -> Some(destUnitParMeasure g unt)
+ | _ -> None)
+
+ []
+ let (|AppTy|_|) g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_app(tcref, tinst, _) -> ValueSome(tcref, tinst)
+ | _ -> ValueNone)
+
+ []
+ let (|RefTupleTy|_|) g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_tuple(tupInfo, tys) when not (evalTupInfoIsStruct tupInfo) -> ValueSome tys
+ | _ -> ValueNone)
+
+ []
+ let (|FunTy|_|) g ty =
+ ty
+ |> stripTyEqns g
+ |> (function
+ | TType_fun(domainTy, rangeTy, _) -> ValueSome(domainTy, rangeTy)
+ | _ -> ValueNone)
+
+ let tryNiceEntityRefOfTy ty =
+ let ty = stripTyparEqnsAux KnownWithoutNull false ty
+
+ match ty with
+ | TType_app(tcref, _, _) -> ValueSome tcref
+ | TType_measure(Measure.Const(tyconRef = tcref)) -> ValueSome tcref
+ | _ -> ValueNone
+
+ let tryNiceEntityRefOfTyOption ty =
+ let ty = stripTyparEqnsAux KnownWithoutNull false ty
+
+ match ty with
+ | TType_app(tcref, _, _) -> Some tcref
+ | TType_measure(Measure.Const(tyconRef = tcref)) -> Some tcref
+ | _ -> None
+
+ let mkInstForAppTy g ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, tinst) -> mkTyconRefInst tcref tinst
+ | _ -> []
+
+ let domainOfFunTy g ty = fst (destFunTy g ty)
+ let rangeOfFunTy g ty = snd (destFunTy g ty)
+
+ let convertToTypeWithMetadataIfPossible g ty =
+ if isAnyTupleTy g ty then
+ let tupInfo, tupElemTys = destAnyTupleTy g ty
+ mkOuterCompiledTupleTy g (evalTupInfoIsStruct tupInfo) tupElemTys
+ elif isFunTy g ty then
+ let a, b = destFunTy g ty
+ mkWoNullAppTy g.fastFunc_tcr [ a; b ]
+ else
+ ty
+
+ //---------------------------------------------------------------------------
+ // TType modifications
+ //---------------------------------------------------------------------------
+
+ let stripMeasuresFromTy g ty =
+ match ty with
+ | TType_app(tcref, tinst, nullness) ->
+ let tinstR = tinst |> List.filter (isMeasureTy g >> not)
+ TType_app(tcref, tinstR, nullness)
+ | _ -> ty
+
+ let mkAnyTupledTy (g: TcGlobals) tupInfo tys =
+ match tys with
+ | [] -> g.unit_ty
+ | [ h ] -> h
+ | _ -> TType_tuple(tupInfo, tys)
+
+ let mkAnyAnonRecdTy (_g: TcGlobals) anonInfo tys = TType_anon(anonInfo, tys)
+
+ let mkRefTupledTy g tys = mkAnyTupledTy g tupInfoRef tys
+
+ let mkRefTupledVarsTy g vs = mkRefTupledTy g (typesOfVals vs)
+
+ let mkMethodTy g argTys retTy =
+ mkIteratedFunTy g (List.map (mkRefTupledTy g) argTys) retTy
+
+ let mkArrayType (g: TcGlobals) ty =
+ TType_app(g.array_tcr_nice, [ ty ], g.knownWithoutNull)
+
+ let mkByteArrayTy (g: TcGlobals) = mkArrayType g g.byte_ty
+
+ let isQuotedExprTy g ty =
+ match tryAppTy g ty with
+ | ValueSome(tcref, _) -> tyconRefEq g tcref g.expr_tcr
+ | _ -> false
+
+ let destQuotedExprTy g ty =
+ match tryAppTy g ty with
+ | ValueSome(_, [ ty ]) -> ty
+ | _ -> failwith "destQuotedExprTy"
+
+ let mkQuotedExprTy (g: TcGlobals) ty =
+ TType_app(g.expr_tcr, [ ty ], g.knownWithoutNull)
+
+ let mkRawQuotedExprTy (g: TcGlobals) =
+ TType_app(g.raw_expr_tcr, [], g.knownWithoutNull)
+
+ let mkIEventType (g: TcGlobals) ty1 ty2 =
+ TType_app(g.fslib_IEvent2_tcr, [ ty1; ty2 ], g.knownWithoutNull)
+
+ let mkIObservableType (g: TcGlobals) ty1 =
+ TType_app(g.tcref_IObservable, [ ty1 ], g.knownWithoutNull)
+
+ let mkIObserverType (g: TcGlobals) ty1 =
+ TType_app(g.tcref_IObserver, [ ty1 ], g.knownWithoutNull)
+
+ let mkSeqTy (g: TcGlobals) ty = mkWoNullAppTy g.seq_tcr [ ty ]
+
+ let mkIEnumeratorTy (g: TcGlobals) ty =
+ mkWoNullAppTy g.tcref_System_Collections_Generic_IEnumerator [ ty ]
+
+[]
+module internal TypeEquivalence =
+
+ //---------------------------------------------------------------------------
+ // Equivalence of types up to alpha-equivalence
+ //---------------------------------------------------------------------------
+
+ []
+ type TypeEquivEnv =
+ {
+ EquivTypars: TyparMap
+ EquivTycons: TyconRefRemap
+ NullnessMustEqual: bool
+ }
+
+ let private nullnessEqual anev (n1: Nullness) (n2: Nullness) =
+ if anev.NullnessMustEqual then
+ (n1.Evaluate() = NullnessInfo.WithNull) = (n2.Evaluate() = NullnessInfo.WithNull)
+ else
+ true
+
+ // allocate a singleton
+ let private typeEquivEnvEmpty =
+ {
+ EquivTypars = TyparMap.Empty
+ EquivTycons = emptyTyconRefRemap
+ NullnessMustEqual = false
+ }
+
+ let private typeEquivCheckNullness =
+ { typeEquivEnvEmpty with
+ NullnessMustEqual = true
+ }
+
+ type TypeEquivEnv with
+ static member EmptyIgnoreNulls = typeEquivEnvEmpty
+
+ static member EmptyWithNullChecks(g: TcGlobals) =
+ if g.checkNullness then
+ typeEquivCheckNullness
+ else
+ typeEquivEnvEmpty
+
+ member aenv.BindTyparsToTypes tps1 tys2 =
+ { aenv with
+ EquivTypars =
+ (tps1, tys2, aenv.EquivTypars)
+ |||> List.foldBack2 (fun tp ty tpmap -> tpmap.Add(tp, ty))
+ }
+
+ member aenv.BindEquivTypars tps1 tps2 =
+ aenv.BindTyparsToTypes tps1 (List.map mkTyparTy tps2)
+
+ member aenv.FromTyparInst tpinst =
+ let tps, tys = List.unzip tpinst
+ aenv.BindTyparsToTypes tps tys
+
+ member aenv.FromEquivTypars tps1 tps2 = aenv.BindEquivTypars tps1 tps2
+
+ member anev.ResetEquiv =
+ if anev.NullnessMustEqual then
+ typeEquivCheckNullness
+ else
+ typeEquivEnvEmpty
+
+ let rec traitsAEquivAux erasureFlag g aenv traitInfo1 traitInfo2 =
+ let (TTrait(tys1, nm, mf1, argTys, retTy, _, _)) = traitInfo1
+ let (TTrait(tys2, nm2, mf2, argTys2, retTy2, _, _)) = traitInfo2
+
+ mf1.IsInstance = mf2.IsInstance
+ && nm = nm2
+ && ListSet.equals (typeAEquivAux erasureFlag g aenv) tys1 tys2
+ && returnTypesAEquivAux erasureFlag g aenv retTy retTy2
+ && List.lengthsEqAndForall2 (typeAEquivAux erasureFlag g aenv) argTys argTys2
+
+ and traitKeysAEquivAux erasureFlag g aenv witnessInfo1 witnessInfo2 =
+ let (TraitWitnessInfo(tys1, nm, mf1, argTys, retTy)) = witnessInfo1
+ let (TraitWitnessInfo(tys2, nm2, mf2, argTys2, retTy2)) = witnessInfo2
+
+ mf1.IsInstance = mf2.IsInstance
+ && nm = nm2
+ && ListSet.equals (typeAEquivAux erasureFlag g aenv) tys1 tys2
+ && returnTypesAEquivAux erasureFlag g aenv retTy retTy2
+ && List.lengthsEqAndForall2 (typeAEquivAux erasureFlag g aenv) argTys argTys2
+
+ and returnTypesAEquivAux erasureFlag g aenv retTy retTy2 =
+ match retTy, retTy2 with
+ | None, None -> true
+ | Some ty1, Some ty2 -> typeAEquivAux erasureFlag g aenv ty1 ty2
+ | _ -> false
+
+ and typarConstraintsAEquivAux erasureFlag g aenv tpc1 tpc2 =
+ match tpc1, tpc2 with
+ | TyparConstraint.CoercesTo(tgtTy1, _), TyparConstraint.CoercesTo(tgtTy2, _) -> typeAEquivAux erasureFlag g aenv tgtTy1 tgtTy2
+
+ | TyparConstraint.MayResolveMember(trait1, _), TyparConstraint.MayResolveMember(trait2, _) ->
+ traitsAEquivAux erasureFlag g aenv trait1 trait2
+
+ | TyparConstraint.DefaultsTo(_, dfltTy1, _), TyparConstraint.DefaultsTo(_, dfltTy2, _) ->
+ typeAEquivAux erasureFlag g aenv dfltTy1 dfltTy2
+
+ | TyparConstraint.IsEnum(underlyingTy1, _), TyparConstraint.IsEnum(underlyingTy2, _) ->
+ typeAEquivAux erasureFlag g aenv underlyingTy1 underlyingTy2
+
+ | TyparConstraint.IsDelegate(argTys1, retTy1, _), TyparConstraint.IsDelegate(argTys2, retTy2, _) ->
+ typeAEquivAux erasureFlag g aenv argTys1 argTys2
+ && typeAEquivAux erasureFlag g aenv retTy1 retTy2
+
+ | TyparConstraint.SimpleChoice(tys1, _), TyparConstraint.SimpleChoice(tys2, _) ->
+ ListSet.equals (typeAEquivAux erasureFlag g aenv) tys1 tys2
+
+ | TyparConstraint.SupportsComparison _, TyparConstraint.SupportsComparison _
+ | TyparConstraint.SupportsEquality _, TyparConstraint.SupportsEquality _
+ | TyparConstraint.SupportsNull _, TyparConstraint.SupportsNull _
+ | TyparConstraint.NotSupportsNull _, TyparConstraint.NotSupportsNull _
+ | TyparConstraint.IsNonNullableStruct _, TyparConstraint.IsNonNullableStruct _
+ | TyparConstraint.IsReferenceType _, TyparConstraint.IsReferenceType _
+ | TyparConstraint.IsUnmanaged _, TyparConstraint.IsUnmanaged _
+ | TyparConstraint.AllowsRefStruct _, TyparConstraint.AllowsRefStruct _
+ | TyparConstraint.RequiresDefaultConstructor _, TyparConstraint.RequiresDefaultConstructor _ -> true
+ | _ -> false
+
+ and typarConstraintSetsAEquivAux erasureFlag g aenv (tp1: Typar) (tp2: Typar) =
+ tp1.StaticReq = tp2.StaticReq
+ && ListSet.equals (typarConstraintsAEquivAux erasureFlag g aenv) tp1.Constraints tp2.Constraints
+
+ and typarsAEquivAux erasureFlag g (aenv: TypeEquivEnv) tps1 tps2 =
+ List.length tps1 = List.length tps2
+ && let aenv = aenv.BindEquivTypars tps1 tps2 in
+ List.forall2 (typarConstraintSetsAEquivAux erasureFlag g aenv) tps1 tps2
+
+ and tcrefAEquiv g aenv tcref1 tcref2 =
+ tyconRefEq g tcref1 tcref2
+ || (match aenv.EquivTycons.TryFind tcref1 with
+ | Some v -> tyconRefEq g v tcref2
+ | None -> false)
+
+ and typeAEquivAux erasureFlag g aenv ty1 ty2 =
+ let ty1 = stripTyEqnsWrtErasure erasureFlag g ty1
+ let ty2 = stripTyEqnsWrtErasure erasureFlag g ty2
+
+ match ty1, ty2 with
+ | TType_forall(tps1, rty1), TType_forall(tps2, retTy2) ->
+ typarsAEquivAux erasureFlag g aenv tps1 tps2
+ && typeAEquivAux erasureFlag g (aenv.BindEquivTypars tps1 tps2) rty1 retTy2
+
+ | TType_var(tp1, n1), TType_var(tp2, n2) when typarEq tp1 tp2 -> nullnessEqual aenv n1 n2
+
+ | TType_var(tp1, n1), _ ->
+ match aenv.EquivTypars.TryFind tp1 with
+ | Some tpTy1 ->
+ let tpTy1 =
+ if (nullnessEqual aenv n1 g.knownWithoutNull) then
+ tpTy1
+ else
+ addNullnessToTy n1 tpTy1
+
+ typeAEquivAux erasureFlag g aenv.ResetEquiv tpTy1 ty2
+ | None -> false
+
+ | TType_app(tcref1, tinst1, n1), TType_app(tcref2, tinst2, n2) ->
+ nullnessEqual aenv n1 n2
+ && tcrefAEquiv g aenv tcref1 tcref2
+ && typesAEquivAux erasureFlag g aenv tinst1 tinst2
+
+ | TType_ucase(UnionCaseRef(tcref1, ucase1), tinst1), TType_ucase(UnionCaseRef(tcref2, ucase2), tinst2) ->
+ ucase1 = ucase2
+ && tcrefAEquiv g aenv tcref1 tcref2
+ && typesAEquivAux erasureFlag g aenv tinst1 tinst2
+
+ | TType_tuple(tupInfo1, l1), TType_tuple(tupInfo2, l2) ->
+ structnessAEquiv tupInfo1 tupInfo2 && typesAEquivAux erasureFlag g aenv l1 l2
+
+ | TType_fun(domainTy1, rangeTy1, n1), TType_fun(domainTy2, rangeTy2, n2) ->
+ nullnessEqual aenv n1 n2
+ && typeAEquivAux erasureFlag g aenv domainTy1 domainTy2
+ && typeAEquivAux erasureFlag g aenv rangeTy1 rangeTy2
+
+ | TType_anon(anonInfo1, l1), TType_anon(anonInfo2, l2) ->
+ anonInfoEquiv anonInfo1 anonInfo2 && typesAEquivAux erasureFlag g aenv l1 l2
+
+ | TType_measure m1, TType_measure m2 ->
+ match erasureFlag with
+ | EraseNone -> measureAEquiv g aenv m1 m2
+ | _ -> true
+
+ | _ -> false
+
+ and anonInfoEquiv (anonInfo1: AnonRecdTypeInfo) (anonInfo2: AnonRecdTypeInfo) =
+ ccuEq anonInfo1.Assembly anonInfo2.Assembly
+ && structnessAEquiv anonInfo1.TupInfo anonInfo2.TupInfo
+ && anonInfo1.SortedNames = anonInfo2.SortedNames
+
+ and structnessAEquiv un1 un2 =
+ match un1, un2 with
+ | TupInfo.Const b1, TupInfo.Const b2 -> (b1 = b2)
+
+ and measureAEquiv g aenv un1 un2 =
+ let vars1 = ListMeasureVarOccs un1
+
+ let trans tp1 =
+ match aenv.EquivTypars.TryGetValue tp1 with
+ | true, etv -> destAnyParTy g etv
+ | false, _ -> tp1
+
+ let remapTyconRef tcref =
+ match aenv.EquivTycons.TryGetValue tcref with
+ | true, tval -> tval
+ | false, _ -> tcref
+
+ let vars1R = List.map trans vars1
+ let vars2 = ListSet.subtract typarEq (ListMeasureVarOccs un2) vars1R
+ let cons1 = ListMeasureConOccsAfterRemapping g remapTyconRef un1
+ let cons2 = ListMeasureConOccsAfterRemapping g remapTyconRef un2
+
+ vars1
+ |> List.forall (fun v -> MeasureVarExponent v un1 = MeasureVarExponent (trans v) un2)
+ && vars2
+ |> List.forall (fun v -> MeasureVarExponent v un1 = MeasureVarExponent v un2)
+ && (cons1 @ cons2)
+ |> List.forall (fun c ->
+ MeasureConExponentAfterRemapping g remapTyconRef c un1 = MeasureConExponentAfterRemapping g remapTyconRef c un2)
+
+ and typesAEquivAux erasureFlag g aenv l1 l2 =
+ List.lengthsEqAndForall2 (typeAEquivAux erasureFlag g aenv) l1 l2
+
+ and typeEquivAux erasureFlag g ty1 ty2 =
+ typeAEquivAux erasureFlag g TypeEquivEnv.EmptyIgnoreNulls ty1 ty2
+
+ let typeAEquiv g aenv ty1 ty2 = typeAEquivAux EraseNone g aenv ty1 ty2
+
+ let typeEquiv g ty1 ty2 = typeEquivAux EraseNone g ty1 ty2
+
+ let traitsAEquiv g aenv t1 t2 = traitsAEquivAux EraseNone g aenv t1 t2
+
+ let traitKeysAEquiv g aenv t1 t2 =
+ traitKeysAEquivAux EraseNone g aenv t1 t2
+
+ let typarConstraintsAEquiv g aenv c1 c2 =
+ typarConstraintsAEquivAux EraseNone g aenv c1 c2
+
+ let typarsAEquiv g aenv d1 d2 = typarsAEquivAux EraseNone g aenv d1 d2
+
+ let isConstraintAllowedAsExtra cx =
+ match cx with
+ | TyparConstraint.NotSupportsNull _ -> true
+ | _ -> false
+
+ let typarsAEquivWithFilter g (aenv: TypeEquivEnv) (reqTypars: Typars) (declaredTypars: Typars) allowExtraInDecl =
+ List.length reqTypars = List.length declaredTypars
+ && let aenv = aenv.BindEquivTypars reqTypars declaredTypars in
+ let cxEquiv = typarConstraintsAEquivAux EraseNone g aenv in
+
+ (reqTypars, declaredTypars)
+ ||> List.forall2 (fun reqTp declTp ->
+ reqTp.StaticReq = declTp.StaticReq
+ && ListSet.isSubsetOf cxEquiv reqTp.Constraints declTp.Constraints
+ && declTp.Constraints
+ |> List.forall (fun declCx ->
+ allowExtraInDecl declCx
+ || reqTp.Constraints |> List.exists (fun reqCx -> cxEquiv reqCx declCx)))
+
+ let typarsAEquivWithAddedNotNullConstraintsAllowed g aenv reqTypars declaredTypars =
+ typarsAEquivWithFilter g aenv reqTypars declaredTypars isConstraintAllowedAsExtra
+
+ let returnTypesAEquiv g aenv t1 t2 =
+ returnTypesAEquivAux EraseNone g aenv t1 t2
+
+ let measureEquiv g m1 m2 =
+ measureAEquiv g TypeEquivEnv.EmptyIgnoreNulls m1 m2
+
+ /// An immutable mapping from witnesses to some data.
+ ///
+ /// Note: this uses an immutable HashMap/Dictionary with an IEqualityComparer that captures TcGlobals, see EmptyTraitWitnessInfoHashMap
+ type TraitWitnessInfoHashMap<'T> = ImmutableDictionary
+
+ /// Create an empty immutable mapping from witnesses to some data
+ let EmptyTraitWitnessInfoHashMap g : TraitWitnessInfoHashMap<'T> =
+ ImmutableDictionary.Create(
+ { new IEqualityComparer<_> with
+ member _.Equals(a, b) =
+ nullSafeEquality a b (fun a b -> traitKeysAEquiv g TypeEquivEnv.EmptyIgnoreNulls a b)
+
+ member _.GetHashCode(a) = hash a.MemberName
+ }
+ )
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi b/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi
new file mode 100644
index 0000000000..090d07beeb
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi
@@ -0,0 +1,568 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.TypedTreeOps
+
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Rational
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Text
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TcGlobals
+
+[]
+module internal TypeRemapping =
+
+ val inline compareBy: x: ('T | null) -> y: ('T | null) -> func: ('T -> 'K) -> int when 'K: comparison
+
+ /// Maps type parameters to entries based on stamp keys
+ []
+ type TyparMap<'T> =
+
+ /// Get the entry for the given type parameter
+ member Item: Typar -> 'T with get
+
+ /// Determine is the map contains an entry for the given type parameter
+ member ContainsKey: Typar -> bool
+
+ member TryGetValue: Typar -> bool * 'T
+
+ /// Try to find the entry for the given type parameter
+ member TryFind: Typar -> 'T option
+
+ /// Make a new map, containing a new entry for the given type parameter
+ member Add: Typar * 'T -> TyparMap<'T>
+
+ /// The empty map
+ static member Empty: TyparMap<'T>
+
+ /// Maps TyconRef to T based on stamp keys
+ []
+ type TyconRefMap<'T> =
+
+ /// Get the entry for the given type definition
+ member Item: TyconRef -> 'T with get
+
+ /// Try to find the entry for the given type definition
+ member TryFind: TyconRef -> 'T option
+
+ /// Determine is the map contains an entry for the given type definition
+ member ContainsKey: TyconRef -> bool
+
+ /// Make a new map, containing a new entry for the given type definition
+ member Add: TyconRef -> 'T -> TyconRefMap<'T>
+
+ /// Remove the entry for the given type definition, if any
+ member Remove: TyconRef -> TyconRefMap<'T>
+
+ /// Determine if the map is empty
+ member IsEmpty: bool
+
+ member TryGetValue: TyconRef -> bool * 'T
+
+ /// The empty map
+ static member Empty: TyconRefMap<'T>
+
+ /// Make a new map, containing entries for the given type definitions
+ static member OfList: (TyconRef * 'T) list -> TyconRefMap<'T>
+
+ /// Maps Val to T, based on stamps
+ []
+ type ValMap<'T> =
+
+ member Contents: StampMap<'T>
+
+ member Item: Val -> 'T with get
+
+ member TryFind: Val -> 'T option
+
+ member ContainsVal: Val -> bool
+
+ member Add: Val -> 'T -> ValMap<'T>
+
+ member Remove: Val -> ValMap<'T>
+
+ member IsEmpty: bool
+
+ static member Empty: ValMap<'T>
+
+ static member OfList: (Val * 'T) list -> ValMap<'T>
+
+ /// Represents an instantiation where types replace type parameters
+ type TyparInstantiation = (Typar * TType) list
+
+ /// Represents an instantiation where type definition references replace other type definition references
+ type TyconRefRemap = TyconRefMap
+
+ /// Represents an instantiation where value references replace other value references
+ type ValRemap = ValMap
+
+ val emptyTyconRefRemap: TyconRefRemap
+
+ val emptyTyparInst: TyparInstantiation
+
+ /// Represents a combination of substitutions/instantiations where things replace other things during remapping
+ []
+ type Remap =
+ { tpinst: TyparInstantiation
+ valRemap: ValRemap
+ tyconRefRemap: TyconRefRemap
+ removeTraitSolutions: bool }
+
+ static member Empty: Remap
+
+ val emptyRemap: Remap
+
+ val addTyconRefRemap: TyconRef -> TyconRef -> Remap -> Remap
+
+ val isRemapEmpty: Remap -> bool
+
+ val instTyparRef: tpinst: (Typar * 'a) list -> ty: 'a -> tp: Typar -> 'a
+
+ /// Remap a reference to a type definition using the given remapping substitution
+ val remapTyconRef: TyconRefMap -> TyconRef -> TyconRef
+
+ /// Remap a reference to a union case using the given remapping substitution
+ val remapUnionCaseRef: TyconRefMap -> UnionCaseRef -> UnionCaseRef
+
+ /// Remap a reference to a record field using the given remapping substitution
+ val remapRecdFieldRef: TyconRefMap -> RecdFieldRef -> RecdFieldRef
+
+ val mkTyparInst: Typars -> TTypes -> TyparInstantiation
+
+ val generalizeTypar: Typar -> TType
+
+ /// From typars to types
+ val generalizeTypars: Typars -> TypeInst
+
+ val remapTypeAux: Remap -> TType -> TType
+
+ val remapMeasureAux: Remap -> Measure -> Measure
+
+ val remapTupInfoAux: Remap -> TupInfo -> TupInfo
+
+ val remapTypesAux: Remap -> TType list -> TType list
+
+ val remapTyparConstraintsAux: Remap -> TyparConstraint list -> TyparConstraint list
+
+ val remapTraitInfo: Remap -> TraitConstraintInfo -> TraitConstraintInfo
+
+ val bindTypars: tps: 'a list -> tyargs: 'b list -> tpinst: ('a * 'b) list -> ('a * 'b) list
+
+ val copyAndRemapAndBindTyparsFull: (Attrib list -> Attrib list) -> Remap -> Typars -> Typars * Remap
+
+ val copyAndRemapAndBindTypars: Remap -> Typars -> Typars * Remap
+
+ val remapValLinkage: Remap -> ValLinkageFullKey -> ValLinkageFullKey
+
+ val remapNonLocalValRef: Remap -> NonLocalValOrMemberRef -> NonLocalValOrMemberRef
+
+ /// Remap a reference to a value using the given remapping substitution
+ val remapValRef: Remap -> ValRef -> ValRef
+
+ val remapType: Remap -> TType -> TType
+
+ val remapTypes: Remap -> TType list -> TType list
+
+ /// Use this one for any type that may be a forall type where the type variables may contain attributes
+ val remapTypeFull: (Attrib list -> Attrib list) -> Remap -> TType -> TType
+
+ val remapParam: Remap -> SlotParam -> SlotParam
+
+ val remapSlotSig: (Attrib list -> Attrib list) -> Remap -> SlotSig -> SlotSig
+
+ val mkInstRemap: TyparInstantiation -> Remap
+
+ val instType: TyparInstantiation -> TType -> TType
+
+ val instTypes: TyparInstantiation -> TypeInst -> TypeInst
+
+ val instTrait: TyparInstantiation -> TraitConstraintInfo -> TraitConstraintInfo
+
+ val instTyparConstraints: TyparInstantiation -> TyparConstraint list -> TyparConstraint list
+
+ /// Instantiate the generic type parameters in a method slot signature, building a new one
+ val instSlotSig: TyparInstantiation -> SlotSig -> SlotSig
+
+ /// Copy a method slot signature, including new generic type parameters if the slot signature represents a generic method
+ val copySlotSig: SlotSig -> SlotSig
+
+ val mkTyparToTyparRenaming: Typars -> Typars -> TyparInstantiation * TTypes
+
+ val mkTyconInst: Tycon -> TypeInst -> TyparInstantiation
+
+ val mkTyconRefInst: TyconRef -> TypeInst -> TyparInstantiation
+
+[]
+module internal MeasureOps =
+
+ /// Equality for type definition references
+ val tyconRefEq: TcGlobals -> TyconRef -> TyconRef -> bool
+
+ /// Equality for value references
+ val valRefEq: TcGlobals -> ValRef -> ValRef -> bool
+
+ val reduceTyconRefAbbrevMeasureable: TyconRef -> Measure
+
+ val stripUnitEqnsFromMeasureAux: bool -> Measure -> Measure
+
+ val stripUnitEqnsFromMeasure: Measure -> Measure
+
+ val MeasureExprConExponent: TcGlobals -> bool -> TyconRef -> Measure -> Rational
+
+ val MeasureConExponentAfterRemapping: TcGlobals -> (TyconRef -> TyconRef) -> TyconRef -> Measure -> Rational
+
+ val MeasureVarExponent: Typar -> Measure -> Rational
+
+ val ListMeasureVarOccs: Measure -> Typar list
+
+ val ListMeasureVarOccsWithNonZeroExponents: Measure -> (Typar * Rational) list
+
+ val ListMeasureConOccsWithNonZeroExponents: TcGlobals -> bool -> Measure -> (TyconRef * Rational) list
+
+ val ListMeasureConOccsAfterRemapping: TcGlobals -> (TyconRef -> TyconRef) -> Measure -> TyconRef list
+
+ val MeasurePower: Measure -> int -> Measure
+
+ val MeasureProdOpt: Measure -> Measure -> Measure
+
+ val ProdMeasures: Measure list -> Measure
+
+ val isDimensionless: TcGlobals -> TType -> bool
+
+ val destUnitParMeasure: TcGlobals -> Measure -> Typar
+
+ val isUnitParMeasure: TcGlobals -> Measure -> bool
+
+ val normalizeMeasure: TcGlobals -> Measure -> Measure
+
+ val tryNormalizeMeasureInType: TcGlobals -> TType -> TType
+
+[]
+module internal TypeBuilders =
+
+ val mkForallTy: Typars -> TType -> TType
+
+ /// Build a type-forall anonymous generic type if necessary
+ val mkForallTyIfNeeded: Typars -> TType -> TType
+
+ val (+->): Typars -> TType -> TType
+
+ /// Build a function type
+ val mkFunTy: TcGlobals -> TType -> TType -> TType
+
+ /// Build a curried function type
+ val mkIteratedFunTy: TcGlobals -> TTypes -> TType -> TType
+
+ /// Build a nativeptr type
+ val mkNativePtrTy: TcGlobals -> TType -> TType
+
+ val mkByrefTy: TcGlobals -> TType -> TType
+
+ /// Make a in-byref type with a in kind parameter
+ val mkInByrefTy: TcGlobals -> TType -> TType
+
+ /// Make an out-byref type with an out kind parameter
+ val mkOutByrefTy: TcGlobals -> TType -> TType
+
+ val mkByrefTyWithFlag: TcGlobals -> bool -> TType -> TType
+
+ val mkByref2Ty: TcGlobals -> TType -> TType -> TType
+
+ /// Build a 'voidptr' type
+ val mkVoidPtrTy: TcGlobals -> TType
+
+ /// Make a byref type with a in/out kind inference parameter
+ val mkByrefTyWithInference: TcGlobals -> TType -> TType -> TType
+
+ /// Build an array type of the given rank
+ val mkArrayTy: TcGlobals -> int -> Nullness -> TType -> range -> TType
+
+ /// The largest tuple before we start encoding, i.e. 7
+ val maxTuple: int
+
+ /// The number of fields in the largest tuple before we start encoding, i.e. 7
+ val goodTupleFields: int
+
+ /// Check if a TyconRef is for a .NET tuple type
+ val isCompiledTupleTyconRef: TcGlobals -> TyconRef -> bool
+
+ /// Get a TyconRef for a .NET tuple type
+ val mkCompiledTupleTyconRef: TcGlobals -> bool -> int -> TyconRef
+
+ /// Convert from F# tuple types to .NET tuple types.
+ val mkCompiledTupleTy: TcGlobals -> bool -> TTypes -> TType
+
+ /// Convert from F# tuple types to .NET tuple types, but only the outermost level
+ val mkOuterCompiledTupleTy: TcGlobals -> bool -> TTypes -> TType
+
+[]
+module internal TypeAbbreviations =
+
+ val applyTyconAbbrev: TType -> Tycon -> TypeInst -> TType
+
+ val reduceTyconAbbrev: Tycon -> TypeInst -> TType
+
+ val reduceTyconRefAbbrev: TyconRef -> TypeInst -> TType
+
+ val reduceTyconMeasureableOrProvided: TcGlobals -> Tycon -> TypeInst -> TType
+
+ val reduceTyconRefMeasureableOrProvided: TcGlobals -> TyconRef -> TypeInst -> TType
+
+[]
+module internal TypeDecomposition =
+
+ val stripTyEqnsA: TcGlobals -> canShortcut: bool -> TType -> TType
+
+ val stripTyEqns: TcGlobals -> TType -> TType
+
+ /// Evaluate the TupInfo to work out if it is a struct or a ref.
+ val evalTupInfoIsStruct: TupInfo -> bool
+
+ /// Evaluate the AnonRecdTypeInfo to work out if it is a struct or a ref.
+ val evalAnonInfoIsStruct: AnonRecdTypeInfo -> bool
+
+ val stripTyEqnsAndErase: bool -> TcGlobals -> TType -> TType
+
+ val stripTyEqnsAndMeasureEqns: TcGlobals -> TType -> TType
+
+ type Erasure =
+ | EraseAll
+ | EraseMeasures
+ | EraseNone
+
+ /// Reduce a type to its more canonical form subject to an erasure flag, inference equations and abbreviations
+ val stripTyEqnsWrtErasure: Erasure -> TcGlobals -> TType -> TType
+
+ /// See through F# exception abbreviations
+ val stripExnEqns: TyconRef -> Tycon
+
+ val primDestForallTy: TcGlobals -> TType -> Typars * TType
+
+ val destFunTy: TcGlobals -> TType -> TType * TType
+
+ val destAnyTupleTy: TcGlobals -> TType -> TupInfo * TTypes
+
+ val destRefTupleTy: TcGlobals -> TType -> TTypes
+
+ val destStructTupleTy: TcGlobals -> TType -> TTypes
+
+ val destTyparTy: TcGlobals -> TType -> Typar
+
+ val destAnyParTy: TcGlobals -> TType -> Typar
+
+ val destMeasureTy: TcGlobals -> TType -> Measure
+
+ val destAnonRecdTy: TcGlobals -> TType -> AnonRecdTypeInfo * TTypes
+
+ val destStructAnonRecdTy: TcGlobals -> TType -> TTypes
+
+ val isFunTy: TcGlobals -> TType -> bool
+
+ val isForallTy: TcGlobals -> TType -> bool
+
+ val isAnyTupleTy: TcGlobals -> TType -> bool
+
+ val isRefTupleTy: TcGlobals -> TType -> bool
+
+ val isStructTupleTy: TcGlobals -> TType -> bool
+
+ val isAnonRecdTy: TcGlobals -> TType -> bool
+
+ val isStructAnonRecdTy: TcGlobals -> TType -> bool
+
+ val isUnionTy: TcGlobals -> TType -> bool
+
+ val isStructUnionTy: TcGlobals -> TType -> bool
+
+ val isReprHiddenTy: TcGlobals -> TType -> bool
+
+ val isFSharpObjModelTy: TcGlobals -> TType -> bool
+
+ val isRecdTy: TcGlobals -> TType -> bool
+
+ val isFSharpStructOrEnumTy: TcGlobals -> TType -> bool
+
+ val isFSharpEnumTy: TcGlobals -> TType -> bool
+
+ val isTyparTy: TcGlobals -> TType -> bool
+
+ val isAnyParTy: TcGlobals -> TType -> bool
+
+ val isMeasureTy: TcGlobals -> TType -> bool
+
+ val isProvenUnionCaseTy: TType -> bool
+
+ val mkWoNullAppTy: TyconRef -> TypeInst -> TType
+
+ val mkProvenUnionCaseTy: UnionCaseRef -> TypeInst -> TType
+
+ val isAppTy: TcGlobals -> TType -> bool
+
+ val tryAppTy: TcGlobals -> TType -> (TyconRef * TypeInst) voption
+
+ val destAppTy: TcGlobals -> TType -> TyconRef * TypeInst
+
+ val tcrefOfAppTy: TcGlobals -> TType -> TyconRef
+
+ val argsOfAppTy: TcGlobals -> TType -> TypeInst
+
+ val tryTcrefOfAppTy: TcGlobals -> TType -> TyconRef voption
+
+ /// Returns ValueSome if this type is a type variable, even after abbreviations are expanded and
+ /// variables have been solved through unification.
+ val tryDestTyparTy: TcGlobals -> TType -> Typar voption
+
+ val tryDestFunTy: TcGlobals -> TType -> (TType * TType) voption
+
+ val tryDestAnonRecdTy: TcGlobals -> TType -> (AnonRecdTypeInfo * TType list) voption
+
+ val tryAnyParTy: TcGlobals -> TType -> Typar voption
+
+ val tryAnyParTyOption: TcGlobals -> TType -> Typar option
+
+ []
+ val (|AppTy|_|): TcGlobals -> TType -> (TyconRef * TypeInst) voption
+
+ []
+ val (|RefTupleTy|_|): TcGlobals -> TType -> TTypes voption
+
+ []
+ val (|FunTy|_|): TcGlobals -> TType -> (TType * TType) voption
+
+ /// Try to get a TyconRef for a type without erasing type abbreviations
+ val tryNiceEntityRefOfTy: TType -> TyconRef voption
+
+ val tryNiceEntityRefOfTyOption: TType -> TyconRef option
+
+ val mkInstForAppTy: TcGlobals -> TType -> TyparInstantiation
+
+ val domainOfFunTy: TcGlobals -> TType -> TType
+
+ val rangeOfFunTy: TcGlobals -> TType -> TType
+
+ /// If it is a tuple type, ensure it's outermost type is a .NET tuple type, otherwise leave unchanged
+ val convertToTypeWithMetadataIfPossible: TcGlobals -> TType -> TType
+
+ val stripMeasuresFromTy: TcGlobals -> TType -> TType
+
+ val mkAnyTupledTy: TcGlobals -> TupInfo -> TType list -> TType
+
+ val mkAnyAnonRecdTy: TcGlobals -> AnonRecdTypeInfo -> TType list -> TType
+
+ val mkRefTupledTy: TcGlobals -> TType list -> TType
+
+ val mkRefTupledVarsTy: TcGlobals -> Val list -> TType
+
+ val mkMethodTy: TcGlobals -> TType list list -> TType -> TType
+
+ /// Build a single-dimensional array type
+ val mkArrayType: TcGlobals -> TType -> TType
+
+ val mkByteArrayTy: TcGlobals -> TType
+
+ val isQuotedExprTy: TcGlobals -> TType -> bool
+
+ val destQuotedExprTy: TcGlobals -> TType -> TType
+
+ val mkQuotedExprTy: TcGlobals -> TType -> TType
+
+ val mkRawQuotedExprTy: TcGlobals -> TType
+
+ val mkIEventType: TcGlobals -> TType -> TType -> TType
+
+ val mkIObservableType: TcGlobals -> TType -> TType
+
+ val mkIObserverType: TcGlobals -> TType -> TType
+
+ val mkSeqTy: TcGlobals -> TType -> TType
+
+ val mkIEnumeratorTy: TcGlobals -> TType -> TType
+
+[]
+module internal TypeEquivalence =
+
+ []
+ type TypeEquivEnv =
+ { EquivTypars: TyparMap
+ EquivTycons: TyconRefRemap
+ NullnessMustEqual: bool }
+
+ static member EmptyIgnoreNulls: TypeEquivEnv
+ static member EmptyWithNullChecks: TcGlobals -> TypeEquivEnv
+
+ member BindTyparsToTypes: Typars -> TType list -> TypeEquivEnv
+
+ member BindEquivTypars: Typars -> Typars -> TypeEquivEnv
+
+ member FromTyparInst: TyparInstantiation -> TypeEquivEnv
+
+ member FromEquivTypars: Typars -> Typars -> TypeEquivEnv
+
+ member ResetEquiv: TypeEquivEnv
+
+ val traitsAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> TraitConstraintInfo -> TraitConstraintInfo -> bool
+
+ val traitKeysAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> TraitWitnessInfo -> TraitWitnessInfo -> bool
+
+ val returnTypesAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> TType option -> TType option -> bool
+
+ val typarConstraintsAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> TyparConstraint -> TyparConstraint -> bool
+
+ val typarConstraintSetsAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> Typar -> Typar -> bool
+
+ val typarsAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> Typars -> Typars -> bool
+
+ val tcrefAEquiv: TcGlobals -> TypeEquivEnv -> TyconRef -> TyconRef -> bool
+
+ val typeAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> TType -> TType -> bool
+
+ val anonInfoEquiv: AnonRecdTypeInfo -> AnonRecdTypeInfo -> bool
+
+ val structnessAEquiv: TupInfo -> TupInfo -> bool
+
+ val measureAEquiv: TcGlobals -> TypeEquivEnv -> Measure -> Measure -> bool
+
+ val typesAEquivAux: Erasure -> TcGlobals -> TypeEquivEnv -> TType list -> TType list -> bool
+
+ /// Check the equivalence of two types up to an erasure flag
+ val typeEquivAux: Erasure -> TcGlobals -> TType -> TType -> bool
+
+ val typeAEquiv: TcGlobals -> TypeEquivEnv -> TType -> TType -> bool
+
+ /// Check the equivalence of two types
+ val typeEquiv: TcGlobals -> TType -> TType -> bool
+
+ val traitsAEquiv: TcGlobals -> TypeEquivEnv -> TraitConstraintInfo -> TraitConstraintInfo -> bool
+
+ val traitKeysAEquiv: TcGlobals -> TypeEquivEnv -> TraitWitnessInfo -> TraitWitnessInfo -> bool
+
+ val typarConstraintsAEquiv: TcGlobals -> TypeEquivEnv -> TyparConstraint -> TyparConstraint -> bool
+
+ val typarsAEquiv: TcGlobals -> TypeEquivEnv -> Typars -> Typars -> bool
+
+ /// Constraints that may be present in an implementation/extension but not required by a signature/base type.
+ val isConstraintAllowedAsExtra: TyparConstraint -> bool
+
+ /// Check if declaredTypars are compatible with reqTypars for a type extension.
+ /// Allows declaredTypars to have extra NotSupportsNull constraints.
+ val typarsAEquivWithAddedNotNullConstraintsAllowed: TcGlobals -> TypeEquivEnv -> Typars -> Typars -> bool
+
+ val returnTypesAEquiv: TcGlobals -> TypeEquivEnv -> TType option -> TType option -> bool
+
+ /// Check the equivalence of two units-of-measure
+ val measureEquiv: TcGlobals -> Measure -> Measure -> bool
+
+ /// An immutable mapping from witnesses to some data.
+ ///
+ /// Note: this uses an immutable HashMap/Dictionary with an IEqualityComparer that captures TcGlobals, see EmptyTraitWitnessInfoHashMap
+ type TraitWitnessInfoHashMap<'T> = ImmutableDictionary
+
+ /// Create an empty immutable mapping from witnesses to some data
+ val EmptyTraitWitnessInfoHashMap: TcGlobals -> TraitWitnessInfoHashMap<'T>
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs
new file mode 100644
index 0000000000..de28bc3413
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs
@@ -0,0 +1,2927 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// TypedTreeOps.Remapping: signature operations, expression free variables, expression remapping, and expression shape queries.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal SignatureOps =
+
+ //--------------------------------------------------------------------------
+ // Helpers related to type checking modules & namespaces
+ //--------------------------------------------------------------------------
+
+ let wrapModuleOrNamespaceType id cpath mtyp =
+ Construct.NewModuleOrNamespace (Some cpath) taccessPublic id XmlDoc.Empty [] (MaybeLazy.Strict mtyp)
+
+ let wrapModuleOrNamespaceTypeInNamespace id cpath mtyp =
+ let mspec = wrapModuleOrNamespaceType id cpath mtyp
+ Construct.NewModuleOrNamespaceType (Namespace false) [ mspec ] [], mspec
+
+ let wrapModuleOrNamespaceContentsInNamespace isModule (id: Ident) (cpath: CompilationPath) mexpr =
+ let mspec =
+ wrapModuleOrNamespaceType id cpath (Construct.NewEmptyModuleOrNamespaceType(Namespace(not isModule)))
+
+ TMDefRec(false, [], [], [ ModuleOrNamespaceBinding.Module(mspec, mexpr) ], id.idRange)
+
+ //--------------------------------------------------------------------------
+ // Data structures representing what gets hidden and what gets remapped
+ // when a module signature is applied to a module.
+ //--------------------------------------------------------------------------
+
+ type SignatureRepackageInfo =
+ {
+ RepackagedVals: (ValRef * ValRef) list
+ RepackagedEntities: (TyconRef * TyconRef) list
+ }
+
+ member remapInfo.ImplToSigMapping g =
+ { TypeEquivEnv.EmptyWithNullChecks g with
+ EquivTycons = TyconRefMap.OfList remapInfo.RepackagedEntities
+ }
+
+ static member Empty =
+ {
+ RepackagedVals = []
+ RepackagedEntities = []
+ }
+
+ type SignatureHidingInfo =
+ {
+ HiddenTycons: Zset
+ HiddenTyconReprs: Zset
+ HiddenVals: Zset
+ HiddenRecdFields: Zset
+ HiddenUnionCases: Zset
+ }
+
+ static member Empty =
+ {
+ HiddenTycons = Zset.empty tyconOrder
+ HiddenTyconReprs = Zset.empty tyconOrder
+ HiddenVals = Zset.empty valOrder
+ HiddenRecdFields = Zset.empty recdFieldRefOrder
+ HiddenUnionCases = Zset.empty unionCaseRefOrder
+ }
+
+ let addValRemap v vNew tmenv =
+ { tmenv with
+ valRemap = tmenv.valRemap.Add v (mkLocalValRef vNew)
+ }
+
+ let mkRepackageRemapping mrpi =
+ {
+ valRemap = ValMap.OfList(mrpi.RepackagedVals |> List.map (fun (vref, x) -> vref.Deref, x))
+ tpinst = emptyTyparInst
+ tyconRefRemap = TyconRefMap.OfList mrpi.RepackagedEntities
+ removeTraitSolutions = false
+ }
+
+ //--------------------------------------------------------------------------
+ // Compute instances of the above for mty -> mty
+ //--------------------------------------------------------------------------
+
+ let accEntityRemap (msigty: ModuleOrNamespaceType) (entity: Entity) (mrpi, mhi) =
+ let sigtyconOpt =
+ (NameMap.tryFind entity.LogicalName msigty.AllEntitiesByCompiledAndLogicalMangledNames)
+
+ match sigtyconOpt with
+ | None ->
+ // The type constructor is not present in the signature. Hence it is hidden.
+ let mhi =
+ { mhi with
+ HiddenTycons = Zset.add entity mhi.HiddenTycons
+ }
+
+ (mrpi, mhi)
+ | Some sigtycon ->
+ // The type constructor is in the signature. Hence record the repackage entry
+ let sigtcref = mkLocalTyconRef sigtycon
+ let tcref = mkLocalTyconRef entity
+
+ let mrpi =
+ { mrpi with
+ RepackagedEntities = ((tcref, sigtcref) :: mrpi.RepackagedEntities)
+ }
+ // OK, now look for hidden things
+ let mhi =
+ if
+ (match entity.TypeReprInfo with
+ | TNoRepr -> false
+ | _ -> true)
+ && (match sigtycon.TypeReprInfo with
+ | TNoRepr -> true
+ | _ -> false)
+ then
+ // The type representation is absent in the signature, hence it is hidden
+ { mhi with
+ HiddenTyconReprs = Zset.add entity mhi.HiddenTyconReprs
+ }
+ else
+ // The type representation is present in the signature.
+ // Find the fields that have been hidden or which were non-public anyway.
+ let mhi =
+ (entity.AllFieldsArray, mhi)
+ ||> Array.foldBack (fun rfield mhi ->
+ match sigtycon.GetFieldByName(rfield.LogicalName) with
+ | Some _ ->
+ // The field is in the signature. Hence it is not hidden.
+ mhi
+ | _ ->
+ // The field is not in the signature. Hence it is regarded as hidden.
+ let rfref = tcref.MakeNestedRecdFieldRef rfield
+
+ { mhi with
+ HiddenRecdFields = Zset.add rfref mhi.HiddenRecdFields
+ })
+
+ let mhi =
+ (entity.UnionCasesAsList, mhi)
+ ||> List.foldBack (fun ucase mhi ->
+ match sigtycon.GetUnionCaseByName ucase.LogicalName with
+ | Some _ ->
+ // The constructor is in the signature. Hence it is not hidden.
+ mhi
+ | _ ->
+ // The constructor is not in the signature. Hence it is regarded as hidden.
+ let ucref = tcref.MakeNestedUnionCaseRef ucase
+
+ { mhi with
+ HiddenUnionCases = Zset.add ucref mhi.HiddenUnionCases
+ })
+
+ mhi
+
+ (mrpi, mhi)
+
+ let accSubEntityRemap (msigty: ModuleOrNamespaceType) (entity: Entity) (mrpi, mhi) =
+ let sigtyconOpt =
+ (NameMap.tryFind entity.LogicalName msigty.AllEntitiesByCompiledAndLogicalMangledNames)
+
+ match sigtyconOpt with
+ | None ->
+ // The type constructor is not present in the signature. Hence it is hidden.
+ let mhi =
+ { mhi with
+ HiddenTycons = Zset.add entity mhi.HiddenTycons
+ }
+
+ (mrpi, mhi)
+ | Some sigtycon ->
+ // The type constructor is in the signature. Hence record the repackage entry
+ let sigtcref = mkLocalTyconRef sigtycon
+ let tcref = mkLocalTyconRef entity
+
+ let mrpi =
+ { mrpi with
+ RepackagedEntities = ((tcref, sigtcref) :: mrpi.RepackagedEntities)
+ }
+
+ (mrpi, mhi)
+
+ let valLinkageAEquiv g aenv (v1: Val) (v2: Val) =
+ (v1.GetLinkagePartialKey() = v2.GetLinkagePartialKey())
+ && (if v1.IsMember && v2.IsMember then
+ typeAEquivAux EraseAll g aenv v1.Type v2.Type
+ else
+ true)
+
+ let accValRemap g aenv (msigty: ModuleOrNamespaceType) (implVal: Val) (mrpi, mhi) =
+ let implValKey = implVal.GetLinkagePartialKey()
+
+ let sigValOpt =
+ msigty.AllValsAndMembersByPartialLinkageKey
+ |> MultiMap.find implValKey
+ |> List.tryFind (fun sigVal -> valLinkageAEquiv g aenv implVal sigVal)
+
+ let vref = mkLocalValRef implVal
+
+ match sigValOpt with
+ | None ->
+ let mhi =
+ { mhi with
+ HiddenVals = Zset.add implVal mhi.HiddenVals
+ }
+
+ (mrpi, mhi)
+ | Some(sigVal: Val) ->
+ // The value is in the signature. Add the repackage entry.
+ let mrpi =
+ { mrpi with
+ RepackagedVals = (vref, mkLocalValRef sigVal) :: mrpi.RepackagedVals
+ }
+
+ (mrpi, mhi)
+
+ let getCorrespondingSigTy nm (msigty: ModuleOrNamespaceType) =
+ match NameMap.tryFind nm msigty.AllEntitiesByCompiledAndLogicalMangledNames with
+ | None -> Construct.NewEmptyModuleOrNamespaceType ModuleOrType
+ | Some sigsubmodul -> sigsubmodul.ModuleOrNamespaceType
+
+ let rec accEntityRemapFromModuleOrNamespaceType (mty: ModuleOrNamespaceType) (msigty: ModuleOrNamespaceType) acc =
+ let acc =
+ (mty.AllEntities, acc)
+ ||> QueueList.foldBack (fun e acc ->
+ accEntityRemapFromModuleOrNamespaceType e.ModuleOrNamespaceType (getCorrespondingSigTy e.LogicalName msigty) acc)
+
+ let acc = (mty.AllEntities, acc) ||> QueueList.foldBack (accEntityRemap msigty)
+ acc
+
+ let rec accValRemapFromModuleOrNamespaceType g aenv (mty: ModuleOrNamespaceType) msigty acc =
+ let acc =
+ (mty.AllEntities, acc)
+ ||> QueueList.foldBack (fun e acc ->
+ accValRemapFromModuleOrNamespaceType g aenv e.ModuleOrNamespaceType (getCorrespondingSigTy e.LogicalName msigty) acc)
+
+ let acc =
+ (mty.AllValsAndMembers, acc) ||> QueueList.foldBack (accValRemap g aenv msigty)
+
+ acc
+
+ let ComputeRemappingFromInferredSignatureToExplicitSignature g mty msigty =
+ let mrpi, _ as entityRemap =
+ accEntityRemapFromModuleOrNamespaceType mty msigty (SignatureRepackageInfo.Empty, SignatureHidingInfo.Empty)
+
+ let aenv = mrpi.ImplToSigMapping g
+
+ let valAndEntityRemap =
+ accValRemapFromModuleOrNamespaceType g aenv mty msigty entityRemap
+
+ valAndEntityRemap
+
+ //--------------------------------------------------------------------------
+ // Compute instances of the above for mexpr -> mty
+ //--------------------------------------------------------------------------
+
+ /// At TMDefRec nodes abstract (virtual) vslots are effectively binders, even
+ /// though they are tucked away inside the tycon. This helper function extracts the
+ /// virtual slots to aid with finding this babies.
+ let abstractSlotValRefsOfTycons (tycons: Tycon list) =
+ tycons
+ |> List.collect (fun tycon ->
+ if tycon.IsFSharpObjectModelTycon then
+ tycon.FSharpTyconRepresentationData.fsobjmodel_vslots
+ else
+ [])
+
+ let abstractSlotValsOfTycons (tycons: Tycon list) =
+ abstractSlotValRefsOfTycons tycons |> List.map (fun v -> v.Deref)
+
+ let rec accEntityRemapFromModuleOrNamespace msigty x acc =
+ match x with
+ | TMDefRec(_, _, tycons, mbinds, _) ->
+ let acc =
+ (mbinds, acc) ||> List.foldBack (accEntityRemapFromModuleOrNamespaceBind msigty)
+
+ let acc = (tycons, acc) ||> List.foldBack (accEntityRemap msigty)
+
+ let acc =
+ (tycons, acc)
+ ||> List.foldBack (fun e acc ->
+ accEntityRemapFromModuleOrNamespaceType e.ModuleOrNamespaceType (getCorrespondingSigTy e.LogicalName msigty) acc)
+
+ acc
+ | TMDefLet _ -> acc
+ | TMDefOpens _ -> acc
+ | TMDefDo _ -> acc
+ | TMDefs defs -> accEntityRemapFromModuleOrNamespaceDefs msigty defs acc
+
+ and accEntityRemapFromModuleOrNamespaceDefs msigty mdefs acc =
+ List.foldBack (accEntityRemapFromModuleOrNamespace msigty) mdefs acc
+
+ and accEntityRemapFromModuleOrNamespaceBind msigty x acc =
+ match x with
+ | ModuleOrNamespaceBinding.Binding _ -> acc
+ | ModuleOrNamespaceBinding.Module(mspec, def) ->
+ accSubEntityRemap msigty mspec (accEntityRemapFromModuleOrNamespace (getCorrespondingSigTy mspec.LogicalName msigty) def acc)
+
+ let rec accValRemapFromModuleOrNamespace g aenv msigty x acc =
+ match x with
+ | TMDefRec(_, _, tycons, mbinds, _) ->
+ let acc =
+ (mbinds, acc)
+ ||> List.foldBack (accValRemapFromModuleOrNamespaceBind g aenv msigty)
+ // Abstract (virtual) vslots in the tycons at TMDefRec nodes are binders. They also need to be added to the remapping.
+ let vslotvs = abstractSlotValsOfTycons tycons
+ let acc = (vslotvs, acc) ||> List.foldBack (accValRemap g aenv msigty)
+ acc
+ | TMDefLet(bind, _) -> accValRemap g aenv msigty bind.Var acc
+ | TMDefOpens _ -> acc
+ | TMDefDo _ -> acc
+ | TMDefs defs -> accValRemapFromModuleOrNamespaceDefs g aenv msigty defs acc
+
+ and accValRemapFromModuleOrNamespaceBind g aenv msigty x acc =
+ match x with
+ | ModuleOrNamespaceBinding.Binding bind -> accValRemap g aenv msigty bind.Var acc
+ | ModuleOrNamespaceBinding.Module(mspec, def) ->
+ accSubEntityRemap
+ msigty
+ mspec
+ (accValRemapFromModuleOrNamespace g aenv (getCorrespondingSigTy mspec.LogicalName msigty) def acc)
+
+ and accValRemapFromModuleOrNamespaceDefs g aenv msigty mdefs acc =
+ List.foldBack (accValRemapFromModuleOrNamespace g aenv msigty) mdefs acc
+
+ let ComputeRemappingFromImplementationToSignature g mdef msigty =
+ let mrpi, _ as entityRemap =
+ accEntityRemapFromModuleOrNamespace msigty mdef (SignatureRepackageInfo.Empty, SignatureHidingInfo.Empty)
+
+ let aenv = mrpi.ImplToSigMapping g
+
+ let valAndEntityRemap =
+ accValRemapFromModuleOrNamespace g aenv msigty mdef entityRemap
+
+ valAndEntityRemap
+
+ //--------------------------------------------------------------------------
+ // Compute instances of the above for the assembly boundary
+ //--------------------------------------------------------------------------
+
+ let accTyconHidingInfoAtAssemblyBoundary (tycon: Tycon) mhi =
+ if not (canAccessFromEverywhere tycon.Accessibility) then
+ // The type constructor is not public, hence hidden at the assembly boundary.
+ { mhi with
+ HiddenTycons = Zset.add tycon mhi.HiddenTycons
+ }
+ elif not (canAccessFromEverywhere tycon.TypeReprAccessibility) then
+ { mhi with
+ HiddenTyconReprs = Zset.add tycon mhi.HiddenTyconReprs
+ }
+ else
+ let mhi =
+ (tycon.AllFieldsArray, mhi)
+ ||> Array.foldBack (fun rfield mhi ->
+ if not (canAccessFromEverywhere rfield.Accessibility) then
+ let tcref = mkLocalTyconRef tycon
+ let rfref = tcref.MakeNestedRecdFieldRef rfield
+
+ { mhi with
+ HiddenRecdFields = Zset.add rfref mhi.HiddenRecdFields
+ }
+ else
+ mhi)
+
+ let mhi =
+ (tycon.UnionCasesAsList, mhi)
+ ||> List.foldBack (fun ucase mhi ->
+ if not (canAccessFromEverywhere ucase.Accessibility) then
+ let tcref = mkLocalTyconRef tycon
+ let ucref = tcref.MakeNestedUnionCaseRef ucase
+
+ { mhi with
+ HiddenUnionCases = Zset.add ucref mhi.HiddenUnionCases
+ }
+ else
+ mhi)
+
+ mhi
+
+ // Collect up the values hidden at the assembly boundary. This is used by IsHiddenVal to
+ // determine if something is considered hidden. This is used in turn to eliminate optimization
+ // information at the assembly boundary and to decide to label things as "internal".
+ let accValHidingInfoAtAssemblyBoundary (vspec: Val) mhi =
+ if // anything labelled "internal" or more restrictive is considered to be hidden at the assembly boundary
+ not (canAccessFromEverywhere vspec.Accessibility)
+ ||
+ // compiler generated members for class function 'let' bindings are considered to be hidden at the assembly boundary
+ vspec.IsIncrClassGeneratedMember
+ ||
+ // anything that's not a module or member binding gets assembly visibility
+ not vspec.IsMemberOrModuleBinding
+ then
+ // The value is not public, hence hidden at the assembly boundary.
+ { mhi with
+ HiddenVals = Zset.add vspec mhi.HiddenVals
+ }
+ else
+ mhi
+
+ let rec accModuleOrNamespaceHidingInfoAtAssemblyBoundary mty acc =
+ let acc =
+ QueueList.foldBack
+ (fun (e: Entity) acc -> accModuleOrNamespaceHidingInfoAtAssemblyBoundary e.ModuleOrNamespaceType acc)
+ mty.AllEntities
+ acc
+
+ let acc =
+ QueueList.foldBack accTyconHidingInfoAtAssemblyBoundary mty.AllEntities acc
+
+ let acc =
+ QueueList.foldBack accValHidingInfoAtAssemblyBoundary mty.AllValsAndMembers acc
+
+ acc
+
+ let ComputeSignatureHidingInfoAtAssemblyBoundary mty acc =
+ accModuleOrNamespaceHidingInfoAtAssemblyBoundary mty acc
+
+ let rec accImplHidingInfoAtAssemblyBoundary mdef acc =
+ match mdef with
+ | TMDefRec(_isRec, _opens, tycons, mbinds, _m) ->
+ let acc = List.foldBack accTyconHidingInfoAtAssemblyBoundary tycons acc
+
+ let acc =
+ (mbinds, acc)
+ ||> List.foldBack (fun mbind acc ->
+ match mbind with
+ | ModuleOrNamespaceBinding.Binding bind -> accValHidingInfoAtAssemblyBoundary bind.Var acc
+ | ModuleOrNamespaceBinding.Module(_mspec, def) -> accImplHidingInfoAtAssemblyBoundary def acc)
+
+ acc
+
+ | TMDefOpens _openDecls -> acc
+
+ | TMDefLet(bind, _m) -> accValHidingInfoAtAssemblyBoundary bind.Var acc
+
+ | TMDefDo _ -> acc
+
+ | TMDefs defs -> List.foldBack accImplHidingInfoAtAssemblyBoundary defs acc
+
+ let ComputeImplementationHidingInfoAtAssemblyBoundary mty acc =
+ accImplHidingInfoAtAssemblyBoundary mty acc
+
+ let DoRemap setF remapF =
+ let rec remap mrmi x =
+
+ match mrmi with
+ | [] -> x
+ | (rpi, mhi) :: rest ->
+ // Explicitly hidden?
+ if Zset.contains x (setF mhi) then
+ x
+ else
+ remap rest (remapF rpi x)
+
+ fun mrmi x -> remap mrmi x
+
+ let DoRemapTycon mrmi x =
+ DoRemap (fun mhi -> mhi.HiddenTycons) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x
+
+ let DoRemapVal mrmi x =
+ DoRemap (fun mhi -> mhi.HiddenVals) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) mrmi x
+
+ //--------------------------------------------------------------------------
+ // Compute instances of the above for mexpr -> mty
+ //--------------------------------------------------------------------------
+ let IsHidden setF accessF remapF =
+ let rec check mrmi x =
+ // Internal/private?
+ not (canAccessFromEverywhere (accessF x))
+ || (match mrmi with
+ | [] -> false // Ah! we escaped to freedom!
+ | (rpi, mhi) :: rest ->
+ // Explicitly hidden?
+ Zset.contains x (setF mhi)
+ ||
+ // Recurse...
+ check rest (remapF rpi x))
+
+ check
+
+ let IsHiddenTycon mrmi x =
+ IsHidden
+ (fun mhi -> mhi.HiddenTycons)
+ (fun tc -> tc.Accessibility)
+ (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref)
+ mrmi
+ x
+
+ let IsHiddenTyconRepr mrmi x =
+ IsHidden
+ (fun mhi -> mhi.HiddenTyconReprs)
+ (fun v -> v.TypeReprAccessibility)
+ (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref)
+ mrmi
+ x
+
+ let IsHiddenVal mrmi x =
+ IsHidden (fun mhi -> mhi.HiddenVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) mrmi x
+
+ let IsHiddenRecdField mrmi x =
+ IsHidden
+ (fun mhi -> mhi.HiddenRecdFields)
+ (fun rfref -> rfref.RecdField.Accessibility)
+ (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x)
+ mrmi
+ x
+
+ //--------------------------------------------------------------------------
+ // Generic operations on module types
+ //--------------------------------------------------------------------------
+
+ let foldModuleOrNamespaceTy ft fv mty acc =
+ let rec go mty acc =
+ let acc =
+ QueueList.foldBack (fun (e: Entity) acc -> go e.ModuleOrNamespaceType acc) mty.AllEntities acc
+
+ let acc = QueueList.foldBack ft mty.AllEntities acc
+ let acc = QueueList.foldBack fv mty.AllValsAndMembers acc
+ acc
+
+ go mty acc
+
+ let allValsOfModuleOrNamespaceTy m =
+ foldModuleOrNamespaceTy (fun _ acc -> acc) (fun v acc -> v :: acc) m []
+
+ let allEntitiesOfModuleOrNamespaceTy m =
+ foldModuleOrNamespaceTy (fun ft acc -> ft :: acc) (fun _ acc -> acc) m []
+
+ //---------------------------------------------------------------------------
+ // Free variables in terms. Are all constructs public accessible?
+ //---------------------------------------------------------------------------
+
+ let isPublicVal (lv: Val) = (lv.Accessibility = taccessPublic)
+
+ let isPublicUnionCase (ucr: UnionCaseRef) =
+ (ucr.UnionCase.Accessibility = taccessPublic)
+
+ let isPublicRecdField (rfr: RecdFieldRef) =
+ (rfr.RecdField.Accessibility = taccessPublic)
+
+ let isPublicTycon (tcref: Tycon) = (tcref.Accessibility = taccessPublic)
+
+ let freeVarsAllPublic fvs =
+ // Are any non-public items used in the expr (which corresponded to the fvs)?
+ // Recall, taccess occurs in:
+ // EntityData has ReprAccessibility and Accessibility
+ // UnionCase has Accessibility
+ // RecdField has Accessibility
+ // ValData has Accessibility
+ // The freevars and FreeTyvars collect local constructs.
+ // Here, we test that all those constructs are public.
+ //
+ // CODE REVIEW:
+ // What about non-local vals. This fix assumes non-local vals must be public. OK?
+ Zset.forall isPublicVal fvs.FreeLocals
+ && Zset.forall isPublicUnionCase fvs.FreeUnionCases
+ && Zset.forall isPublicRecdField fvs.FreeRecdFields
+ && Zset.forall isPublicTycon fvs.FreeTyvars.FreeTycons
+
+ let freeTyvarsAllPublic tyvars =
+ Zset.forall isPublicTycon tyvars.FreeTycons
+
+ /// Combine a list of ModuleOrNamespaceType's making up the description of a CCU. checking there are now
+ /// duplicate modules etc.
+ let CombineCcuContentFragments l =
+
+ /// Combine module types when multiple namespace fragments contribute to the
+ /// same namespace, making new module specs as we go.
+ let rec CombineModuleOrNamespaceTypes path (mty1: ModuleOrNamespaceType) (mty2: ModuleOrNamespaceType) =
+ let kind = mty1.ModuleOrNamespaceKind
+ let tab1 = mty1.AllEntitiesByLogicalMangledName
+ let tab2 = mty2.AllEntitiesByLogicalMangledName
+
+ let entities =
+ [
+ for e1 in mty1.AllEntities do
+ match tab2.TryGetValue e1.LogicalName with
+ | true, e2 -> yield CombineEntities path e1 e2
+ | _ -> yield e1
+
+ for e2 in mty2.AllEntities do
+ match tab1.TryGetValue e2.LogicalName with
+ | true, _ -> ()
+ | _ -> yield e2
+ ]
+
+ let vals = QueueList.append mty1.AllValsAndMembers mty2.AllValsAndMembers
+
+ ModuleOrNamespaceType(kind, vals, QueueList.ofList entities)
+
+ and CombineEntities path (entity1: Entity) (entity2: Entity) =
+
+ let path2 = path @ [ entity2.DemangledModuleOrNamespaceName ]
+
+ match entity1.IsNamespace, entity2.IsNamespace, entity1.IsModule, entity2.IsModule with
+ | true, true, _, _ -> ()
+ | true, _, _, _
+ | _, true, _, _ -> errorR (Error(FSComp.SR.tastNamespaceAndModuleWithSameNameInAssembly (textOfPath path2), entity2.Range))
+ | false, false, false, false ->
+ errorR (Error(FSComp.SR.tastDuplicateTypeDefinitionInAssembly (entity2.LogicalName, textOfPath path), entity2.Range))
+ | false, false, true, true -> errorR (Error(FSComp.SR.tastTwoModulesWithSameNameInAssembly (textOfPath path2), entity2.Range))
+ | _ ->
+ errorR (
+ Error(FSComp.SR.tastConflictingModuleAndTypeDefinitionInAssembly (entity2.LogicalName, textOfPath path), entity2.Range)
+ )
+
+ entity1
+ |> Construct.NewModifiedTycon(fun data1 ->
+ let xml = XmlDoc.Merge entity1.XmlDoc entity2.XmlDoc
+
+ { data1 with
+ entity_attribs =
+ if entity2.Attribs.IsEmpty then
+ entity1.EntityAttribs
+ elif entity1.Attribs.IsEmpty then
+ entity2.EntityAttribs
+ else
+ WellKnownEntityAttribs.Create(entity1.Attribs @ entity2.Attribs)
+ entity_modul_type =
+ MaybeLazy.Lazy(
+ InterruptibleLazy(fun _ ->
+ CombineModuleOrNamespaceTypes path2 entity1.ModuleOrNamespaceType entity2.ModuleOrNamespaceType)
+ )
+ entity_opt_data =
+ match data1.entity_opt_data with
+ | Some optData -> Some { optData with entity_xmldoc = xml }
+ | _ ->
+ Some
+ { Entity.NewEmptyEntityOptData() with
+ entity_xmldoc = xml
+ }
+ })
+
+ and CombineModuleOrNamespaceTypeList path l =
+ match l with
+ | h :: t -> List.fold (CombineModuleOrNamespaceTypes path) h t
+ | _ -> failwith "CombineModuleOrNamespaceTypeList"
+
+ CombineModuleOrNamespaceTypeList [] l
+
+ //--------------------------------------------------------------------------
+ // Build a Remap that converts all "local" references to "public" things
+ // accessed via non local references.
+ //--------------------------------------------------------------------------
+
+ let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) =
+
+ let accEntityRemap (entity: Entity) acc =
+ match tryRescopeEntity viewedCcu entity with
+ | ValueSome eref -> addTyconRefRemap (mkLocalTyconRef entity) eref acc
+ | _ ->
+ if entity.IsNamespace then
+ acc
+ else
+ error (InternalError("Unexpected entity without a pubpath when remapping assembly data", entity.Range))
+
+ let accValRemap (vspec: Val) acc =
+ // The acc contains the entity remappings
+ match tryRescopeVal viewedCcu acc vspec with
+ | ValueSome vref ->
+ { acc with
+ valRemap = acc.valRemap.Add vspec vref
+ }
+ | _ -> error (InternalError("Unexpected value without a pubpath when remapping assembly data", vspec.Range))
+
+ let mty = mspec.ModuleOrNamespaceType
+ let entities = allEntitiesOfModuleOrNamespaceTy mty
+ let vs = allValsOfModuleOrNamespaceTy mty
+ // Remap the entities first so we can correctly remap the types in the signatures of the ValLinkageFullKey's in the value references
+ let acc = List.foldBack accEntityRemap entities Remap.Empty
+ let allRemap = List.foldBack accValRemap vs acc
+ allRemap
+
+ let updateSeqTypeIsPrefix (fsharpCoreMSpec: ModuleOrNamespace) =
+ let findModuleOrNamespace (name: string) (entity: Entity) =
+ if not entity.IsModuleOrNamespace then
+ None
+ else
+ entity.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName
+ |> Map.tryFind name
+
+ findModuleOrNamespace "Microsoft" fsharpCoreMSpec
+ |> Option.bind (findModuleOrNamespace "FSharp")
+ |> Option.bind (findModuleOrNamespace "Collections")
+ |> Option.iter (fun collectionsEntity ->
+ collectionsEntity.ModuleOrNamespaceType.AllEntitiesByLogicalMangledName
+ |> Map.tryFind "seq`1"
+ |> Option.iter (fun seqEntity ->
+ seqEntity.entity_flags <-
+ EntityFlags(
+ false,
+ seqEntity.entity_flags.IsModuleOrNamespace,
+ seqEntity.entity_flags.PreEstablishedHasDefaultConstructor,
+ seqEntity.entity_flags.HasSelfReferentialConstructor,
+ seqEntity.entity_flags.IsStructRecordOrUnionType
+ )))
+
+ /// Matches a ModuleOrNamespaceContents that is empty from a signature printing point of view.
+ /// Signatures printed via the typed tree in NicePrint don't print TMDefOpens or TMDefDo.
+ /// This will match anything that does not have any types or bindings.
+ []
+ let (|EmptyModuleOrNamespaces|_|) (moduleOrNamespaceContents: ModuleOrNamespaceContents) =
+ match moduleOrNamespaceContents with
+ | TMDefs(defs = defs) ->
+ let mdDefsLength =
+ defs
+ |> List.count (function
+ | ModuleOrNamespaceContents.TMDefRec _
+ | ModuleOrNamespaceContents.TMDefs _ -> true
+ | _ -> false)
+
+ let emptyModuleOrNamespaces =
+ defs
+ |> List.choose (function
+ | ModuleOrNamespaceContents.TMDefRec _ as defRec
+ | ModuleOrNamespaceContents.TMDefs(defs = [ ModuleOrNamespaceContents.TMDefRec _ as defRec ]) ->
+ match defRec with
+ | TMDefRec(bindings = [ ModuleOrNamespaceBinding.Module(mspec, ModuleOrNamespaceContents.TMDefs(defs = defs)) ]) ->
+ defs
+ |> List.forall (function
+ | ModuleOrNamespaceContents.TMDefOpens _
+ | ModuleOrNamespaceContents.TMDefDo _
+ | ModuleOrNamespaceContents.TMDefRec(isRec = true; tycons = []; bindings = []) -> true
+ | _ -> false)
+ |> fun isEmpty -> if isEmpty then Some mspec else None
+ | _ -> None
+ | _ -> None)
+
+ if mdDefsLength = emptyModuleOrNamespaces.Length then
+ ValueSome emptyModuleOrNamespaces
+ else
+ ValueNone
+ | _ -> ValueNone
+
+[]
+module internal ExprFreeVars =
+
+ /// Detect the subset of match expressions we process in a linear way (i.e. using tailcalls, rather than
+ /// unbounded stack)
+ /// -- if then else
+ /// -- match e with pat[vs] -> e1[vs] | _ -> e2
+
+ []
+ let (|LinearMatchExpr|_|) expr =
+ match expr with
+ | Expr.Match(sp, m, dtree, [| tg1; (TTarget([], e2, _)) |], m2, ty) -> ValueSome(sp, m, dtree, tg1, e2, m2, ty)
+ | _ -> ValueNone
+
+ let rebuildLinearMatchExpr (sp, m, dtree, tg1, e2, m2, ty) =
+ primMkMatch (sp, m, dtree, [| tg1; TTarget([], e2, None) |], m2, ty)
+
+ /// Detect a subset of 'Expr.Op' expressions we process in a linear way (i.e. using tailcalls, rather than
+ /// unbounded stack). Only covers Cons(args,Cons(args,Cons(args,Cons(args,...._)))).
+ []
+ let (|LinearOpExpr|_|) expr =
+ match expr with
+ | Expr.Op(TOp.UnionCase _ as op, tinst, args, m) when not args.IsEmpty ->
+ let argsFront, argLast = List.frontAndBack args
+ ValueSome(op, tinst, argsFront, argLast, m)
+ | _ -> ValueNone
+
+ let rebuildLinearOpExpr (op, tinst, argsFront, argLast, m) =
+ Expr.Op(op, tinst, argsFront @ [ argLast ], m)
+
+ //---------------------------------------------------------------------------
+ // Free variables in terms. All binders are distinct.
+ //---------------------------------------------------------------------------
+
+ let emptyFreeVars =
+ {
+ UsesMethodLocalConstructs = false
+ UsesUnboundRethrow = false
+ FreeLocalTyconReprs = emptyFreeTycons
+ FreeLocals = emptyFreeLocals
+ FreeTyvars = emptyFreeTyvars
+ FreeRecdFields = emptyFreeRecdFields
+ FreeUnionCases = emptyFreeUnionCases
+ }
+
+ let unionFreeVars fvs1 fvs2 =
+ if fvs1 === emptyFreeVars then
+ fvs2
+ else if fvs2 === emptyFreeVars then
+ fvs1
+ else
+ {
+ FreeLocals = unionFreeLocals fvs1.FreeLocals fvs2.FreeLocals
+ FreeTyvars = unionFreeTyvars fvs1.FreeTyvars fvs2.FreeTyvars
+ UsesMethodLocalConstructs = fvs1.UsesMethodLocalConstructs || fvs2.UsesMethodLocalConstructs
+ UsesUnboundRethrow = fvs1.UsesUnboundRethrow || fvs2.UsesUnboundRethrow
+ FreeLocalTyconReprs = unionFreeTycons fvs1.FreeLocalTyconReprs fvs2.FreeLocalTyconReprs
+ FreeRecdFields = unionFreeRecdFields fvs1.FreeRecdFields fvs2.FreeRecdFields
+ FreeUnionCases = unionFreeUnionCases fvs1.FreeUnionCases fvs2.FreeUnionCases
+ }
+
+ let inline accFreeTyvars (opts: FreeVarOptions) f v acc =
+ if not opts.collectInTypes then
+ acc
+ else
+ let ftyvs = acc.FreeTyvars
+ let ftyvs' = f opts v ftyvs
+
+ if ftyvs === ftyvs' then
+ acc
+ else
+ { acc with FreeTyvars = ftyvs' }
+
+ let accFreeVarsInTy opts ty acc = accFreeTyvars opts accFreeInType ty acc
+
+ let accFreeVarsInTys opts tys acc =
+ if isNil tys then
+ acc
+ else
+ accFreeTyvars opts accFreeInTypes tys acc
+
+ let accFreevarsInTycon opts tcref acc =
+ accFreeTyvars opts accFreeTycon tcref acc
+
+ let accFreevarsInVal opts v acc = accFreeTyvars opts accFreeInVal v acc
+
+ let accFreeVarsInTraitSln opts tys acc =
+ accFreeTyvars opts accFreeInTraitSln tys acc
+
+ let accFreeVarsInTraitInfo opts tys acc =
+ accFreeTyvars opts accFreeInTrait tys acc
+
+ let boundLocalVal opts v fvs =
+ if not opts.includeLocals then
+ fvs
+ else
+ let fvs = accFreevarsInVal opts v fvs
+
+ if not (Zset.contains v fvs.FreeLocals) then
+ fvs
+ else
+ { fvs with
+ FreeLocals = Zset.remove v fvs.FreeLocals
+ }
+
+ let boundProtect fvs =
+ if fvs.UsesMethodLocalConstructs then
+ { fvs with
+ UsesMethodLocalConstructs = false
+ }
+ else
+ fvs
+
+ let accUsesFunctionLocalConstructs flg fvs =
+ if flg && not fvs.UsesMethodLocalConstructs then
+ { fvs with
+ UsesMethodLocalConstructs = true
+ }
+ else
+ fvs
+
+ let bound_rethrow fvs =
+ if fvs.UsesUnboundRethrow then
+ { fvs with UsesUnboundRethrow = false }
+ else
+ fvs
+
+ let accUsesRethrow flg fvs =
+ if flg && not fvs.UsesUnboundRethrow then
+ { fvs with UsesUnboundRethrow = true }
+ else
+ fvs
+
+ let boundLocalVals opts vs fvs =
+ List.foldBack (boundLocalVal opts) vs fvs
+
+ let bindLhs opts (bind: Binding) fvs = boundLocalVal opts bind.Var fvs
+
+ let freeVarsCacheCompute opts cache f =
+ if opts.canCache then cached cache f else f ()
+
+ let tryGetFreeVarsCacheValue opts cache =
+ if opts.canCache then tryGetCacheValue cache else ValueNone
+
+ let accFreeLocalVal opts v fvs =
+ if not opts.includeLocals then
+ fvs
+ else if Zset.contains v fvs.FreeLocals then
+ fvs
+ else
+ let fvs = accFreevarsInVal opts v fvs
+
+ { fvs with
+ FreeLocals = Zset.add v fvs.FreeLocals
+ }
+
+ let accFreeInValFlags opts flag acc =
+ let isMethLocal =
+ match flag with
+ | VSlotDirectCall
+ | CtorValUsedAsSelfInit
+ | CtorValUsedAsSuperInit -> true
+ | PossibleConstrainedCall _
+ | NormalValUse -> false
+
+ let acc = accUsesFunctionLocalConstructs isMethLocal acc
+
+ match flag with
+ | PossibleConstrainedCall ty -> accFreeTyvars opts accFreeInType ty acc
+ | _ -> acc
+
+ let accLocalTyconRepr opts b fvs =
+ if not opts.includeLocalTyconReprs then
+ fvs
+ else if Zset.contains b fvs.FreeLocalTyconReprs then
+ fvs
+ else
+ { fvs with
+ FreeLocalTyconReprs = Zset.add b fvs.FreeLocalTyconReprs
+ }
+
+ let inline accFreeExnRef _exnc fvs = fvs // Note: this exnc (TyconRef) should be collected the surround types, e.g. tinst of Expr.Op
+
+ let rec accBindRhs opts (TBind(_, repr, _)) acc = accFreeInExpr opts repr acc
+
+ and accFreeInSwitchCases opts csl dflt (acc: FreeVars) =
+ Option.foldBack (accFreeInDecisionTree opts) dflt (List.foldBack (accFreeInSwitchCase opts) csl acc)
+
+ and accFreeInSwitchCase opts (TCase(discrim, dtree)) acc =
+ accFreeInDecisionTree opts dtree (accFreeInTest opts discrim acc)
+
+ and accFreeInTest (opts: FreeVarOptions) discrim acc =
+ match discrim with
+ | DecisionTreeTest.UnionCase(ucref, tinst) -> accFreeUnionCaseRef opts ucref (accFreeVarsInTys opts tinst acc)
+ | DecisionTreeTest.ArrayLength(_, ty) -> accFreeVarsInTy opts ty acc
+ | DecisionTreeTest.Const _
+ | DecisionTreeTest.IsNull -> acc
+ | DecisionTreeTest.IsInst(srcTy, tgtTy) -> accFreeVarsInTy opts srcTy (accFreeVarsInTy opts tgtTy acc)
+ | DecisionTreeTest.ActivePatternCase(exp, tys, _, activePatIdentity, _, _) ->
+ accFreeInExpr
+ opts
+ exp
+ (accFreeVarsInTys
+ opts
+ tys
+ (Option.foldBack
+ (fun (vref, tinst) acc -> accFreeValRef opts vref (accFreeVarsInTys opts tinst acc))
+ activePatIdentity
+ acc))
+ | DecisionTreeTest.Error _ -> acc
+
+ and accFreeInDecisionTree opts x (acc: FreeVars) =
+ match x with
+ | TDSwitch(e1, csl, dflt, _) -> accFreeInExpr opts e1 (accFreeInSwitchCases opts csl dflt acc)
+ | TDSuccess(es, _) -> accFreeInFlatExprs opts es acc
+ | TDBind(bind, body) -> unionFreeVars (bindLhs opts bind (accBindRhs opts bind (freeInDecisionTree opts body))) acc
+
+ and accUsedRecdOrUnionTyconRepr opts (tc: Tycon) fvs =
+ if
+ (match tc.TypeReprInfo with
+ | TFSharpTyconRepr _ -> true
+ | _ -> false)
+ then
+ accLocalTyconRepr opts tc fvs
+ else
+ fvs
+
+ and accFreeUnionCaseRef opts ucref fvs =
+ if not opts.includeUnionCases then
+ fvs
+ else if Zset.contains ucref fvs.FreeUnionCases then
+ fvs
+ else
+ let fvs = fvs |> accUsedRecdOrUnionTyconRepr opts ucref.Tycon
+ let fvs = fvs |> accFreevarsInTycon opts ucref.TyconRef
+
+ { fvs with
+ FreeUnionCases = Zset.add ucref fvs.FreeUnionCases
+ }
+
+ and accFreeRecdFieldRef opts rfref fvs =
+ if not opts.includeRecdFields then
+ fvs
+ else if Zset.contains rfref fvs.FreeRecdFields then
+ fvs
+ else
+ let fvs = fvs |> accUsedRecdOrUnionTyconRepr opts rfref.Tycon
+ let fvs = fvs |> accFreevarsInTycon opts rfref.TyconRef
+
+ { fvs with
+ FreeRecdFields = Zset.add rfref fvs.FreeRecdFields
+ }
+
+ and accFreeValRef opts (vref: ValRef) fvs =
+ match vref.IsLocalRef with
+ | true -> accFreeLocalVal opts vref.ResolvedTarget fvs
+ // non-local values do not contain free variables
+ | _ -> fvs
+
+ and accFreeInMethod opts (TObjExprMethod(slotsig, _attribs, tps, tmvs, e, _)) acc =
+ accFreeInSlotSig
+ opts
+ slotsig
+ (unionFreeVars (accFreeTyvars opts boundTypars tps (List.foldBack (boundLocalVals opts) tmvs (freeInExpr opts e))) acc)
+
+ and accFreeInMethods opts methods acc =
+ List.foldBack (accFreeInMethod opts) methods acc
+
+ and accFreeInInterfaceImpl opts (ty, overrides) acc =
+ accFreeVarsInTy opts ty (accFreeInMethods opts overrides acc)
+
+ and accFreeInExpr (opts: FreeVarOptions) x acc =
+ match x with
+ | Expr.Let _ -> accFreeInExprLinear opts x acc id
+ | _ -> accFreeInExprNonLinear opts x acc
+
+ and accFreeInExprLinear (opts: FreeVarOptions) x acc contf =
+ // for nested let-bindings, we need to continue after the whole let-binding is processed
+ match x with
+ | Expr.Let(bind, e, _, cache) ->
+ match tryGetFreeVarsCacheValue opts cache with
+ | ValueSome free -> contf (unionFreeVars free acc)
+ | _ ->
+ accFreeInExprLinear
+ opts
+ e
+ emptyFreeVars
+ (contf
+ << (fun free ->
+ unionFreeVars (freeVarsCacheCompute opts cache (fun () -> bindLhs opts bind (accBindRhs opts bind free))) acc))
+ | _ ->
+ // No longer linear expr
+ contf (accFreeInExpr opts x acc)
+
+ and accFreeInExprNonLinear opts x acc =
+
+ match opts.stackGuard with
+ | None -> accFreeInExprNonLinearImpl opts x acc
+ | Some stackGuard -> stackGuard.Guard(fun () -> accFreeInExprNonLinearImpl opts x acc)
+
+ and accFreeInExprNonLinearImpl opts x acc =
+
+ match x with
+ // BINDING CONSTRUCTS
+ | Expr.Lambda(_, ctorThisValOpt, baseValOpt, vs, bodyExpr, _, bodyTy) ->
+ unionFreeVars
+ (Option.foldBack
+ (boundLocalVal opts)
+ ctorThisValOpt
+ (Option.foldBack
+ (boundLocalVal opts)
+ baseValOpt
+ (boundLocalVals opts vs (accFreeVarsInTy opts bodyTy (freeInExpr opts bodyExpr)))))
+ acc
+
+ | Expr.TyLambda(_, vs, bodyExpr, _, bodyTy) ->
+ unionFreeVars (accFreeTyvars opts boundTypars vs (accFreeVarsInTy opts bodyTy (freeInExpr opts bodyExpr))) acc
+
+ | Expr.TyChoose(vs, bodyExpr, _) -> unionFreeVars (accFreeTyvars opts boundTypars vs (freeInExpr opts bodyExpr)) acc
+
+ | Expr.LetRec(binds, bodyExpr, _, cache) ->
+ unionFreeVars
+ (freeVarsCacheCompute opts cache (fun () ->
+ List.foldBack (bindLhs opts) binds (List.foldBack (accBindRhs opts) binds (freeInExpr opts bodyExpr))))
+ acc
+
+ | Expr.Let _ -> failwith "unreachable - linear expr"
+
+ | Expr.Obj(_, ty, basev, basecall, overrides, iimpls, _) ->
+ unionFreeVars
+ (boundProtect (
+ Option.foldBack
+ (boundLocalVal opts)
+ basev
+ (accFreeVarsInTy
+ opts
+ ty
+ (accFreeInExpr
+ opts
+ basecall
+ (accFreeInMethods opts overrides (List.foldBack (accFreeInInterfaceImpl opts) iimpls emptyFreeVars))))
+ ))
+ acc
+
+ // NON-BINDING CONSTRUCTS
+ | Expr.Const _ -> acc
+
+ | Expr.Val(lvr, flags, _) -> accFreeInValFlags opts flags (accFreeValRef opts lvr acc)
+
+ | Expr.Quote(ast, dataCell, _, _, ty) ->
+ match dataCell.Value with
+ | Some(_, (_, argTypes, argExprs, _data)) ->
+ accFreeInExpr opts ast (accFreeInExprs opts argExprs (accFreeVarsInTys opts argTypes (accFreeVarsInTy opts ty acc)))
+
+ | None -> accFreeInExpr opts ast (accFreeVarsInTy opts ty acc)
+
+ | Expr.App(f0, f0ty, tyargs, args, _) ->
+ accFreeVarsInTy opts f0ty (accFreeInExpr opts f0 (accFreeVarsInTys opts tyargs (accFreeInExprs opts args acc)))
+
+ | Expr.Link eref -> accFreeInExpr opts eref.Value acc
+
+ | Expr.Sequential(expr1, expr2, _, _) ->
+ let acc = accFreeInExpr opts expr1 acc
+ // tail-call - linear expression
+ accFreeInExpr opts expr2 acc
+
+ | Expr.StaticOptimization(_, expr2, expr3, _) -> accFreeInExpr opts expr2 (accFreeInExpr opts expr3 acc)
+
+ | Expr.Match(_, _, dtree, targets, _, _) ->
+ match x with
+ // Handle if-then-else
+ | LinearMatchExpr(_, _, dtree, target, bodyExpr, _, _) ->
+ let acc = accFreeInDecisionTree opts dtree acc
+ let acc = accFreeInTarget opts target acc
+ accFreeInExpr opts bodyExpr acc // tailcall
+
+ | _ ->
+ let acc = accFreeInDecisionTree opts dtree acc
+ accFreeInTargets opts targets acc
+
+ | Expr.Op(TOp.TryWith _, tinst, [ expr1; expr2; expr3 ], _) ->
+ unionFreeVars
+ (accFreeVarsInTys opts tinst (accFreeInExprs opts [ expr1; expr2 ] acc))
+ (bound_rethrow (accFreeInExpr opts expr3 emptyFreeVars))
+
+ | Expr.Op(op, tinst, args, _) ->
+ let acc = accFreeInOp opts op acc
+ let acc = accFreeVarsInTys opts tinst acc
+ accFreeInExprs opts args acc
+
+ | Expr.WitnessArg(traitInfo, _) -> accFreeVarsInTraitInfo opts traitInfo acc
+
+ | Expr.DebugPoint(_, innerExpr) -> accFreeInExpr opts innerExpr acc
+
+ and accFreeInOp opts op acc =
+ match op with
+
+ // Things containing no references
+ | TOp.Bytes _
+ | TOp.UInt16s _
+ | TOp.TryWith _
+ | TOp.TryFinally _
+ | TOp.IntegerForLoop _
+ | TOp.Coerce
+ | TOp.RefAddrGet _
+ | TOp.Array
+ | TOp.While _
+ | TOp.Goto _
+ | TOp.Label _
+ | TOp.Return
+ | TOp.TupleFieldGet _ -> acc
+
+ | TOp.Tuple tupInfo -> accFreeTyvars opts accFreeInTupInfo tupInfo acc
+
+ | TOp.AnonRecd anonInfo
+ | TOp.AnonRecdGet(anonInfo, _) -> accFreeTyvars opts accFreeInTupInfo anonInfo.TupInfo acc
+
+ | TOp.UnionCaseTagGet tcref -> accUsedRecdOrUnionTyconRepr opts tcref.Deref acc
+
+ // Things containing just a union case reference
+ | TOp.UnionCaseProof ucref
+ | TOp.UnionCase ucref
+ | TOp.UnionCaseFieldGetAddr(ucref, _, _)
+ | TOp.UnionCaseFieldGet(ucref, _)
+ | TOp.UnionCaseFieldSet(ucref, _) -> accFreeUnionCaseRef opts ucref acc
+
+ // Things containing just an exception reference
+ | TOp.ExnConstr ecref
+ | TOp.ExnFieldGet(ecref, _)
+ | TOp.ExnFieldSet(ecref, _) -> accFreeExnRef ecref acc
+
+ | TOp.ValFieldGet fref
+ | TOp.ValFieldGetAddr(fref, _)
+ | TOp.ValFieldSet fref -> accFreeRecdFieldRef opts fref acc
+
+ | TOp.Recd(kind, tcref) ->
+ let acc = accUsesFunctionLocalConstructs (kind = RecdExprIsObjInit) acc
+ (accUsedRecdOrUnionTyconRepr opts tcref.Deref (accFreeTyvars opts accFreeTycon tcref acc))
+
+ | TOp.ILAsm(_, retTypes) -> accFreeVarsInTys opts retTypes acc
+
+ | TOp.Reraise -> accUsesRethrow true acc
+
+ | TOp.TraitCall(TTrait(tys, _, _, argTys, retTy, _, sln)) ->
+ Option.foldBack
+ (accFreeVarsInTraitSln opts)
+ sln.Value
+ (accFreeVarsInTys opts tys (accFreeVarsInTys opts argTys (Option.foldBack (accFreeVarsInTy opts) retTy acc)))
+
+ | TOp.LValueOp(_, vref) -> accFreeValRef opts vref acc
+
+ | TOp.ILCall(_, isProtected, _, _, valUseFlag, _, _, _, enclTypeInst, methInst, retTypes) ->
+ accFreeVarsInTys
+ opts
+ enclTypeInst
+ (accFreeVarsInTys
+ opts
+ methInst
+ (accFreeInValFlags opts valUseFlag (accFreeVarsInTys opts retTypes (accUsesFunctionLocalConstructs isProtected acc))))
+
+ and accFreeInTargets opts targets acc =
+ Array.foldBack (accFreeInTarget opts) targets acc
+
+ and accFreeInTarget opts (TTarget(vs, expr, flags)) acc =
+ match flags with
+ | None -> List.foldBack (boundLocalVal opts) vs (accFreeInExpr opts expr acc)
+ | Some xs ->
+ List.foldBack2
+ (fun v isStateVar acc -> if isStateVar then acc else boundLocalVal opts v acc)
+ vs
+ xs
+ (accFreeInExpr opts expr acc)
+
+ and accFreeInFlatExprs opts (exprs: Exprs) acc =
+ List.foldBack (accFreeInExpr opts) exprs acc
+
+ and accFreeInExprs opts (exprs: Exprs) acc =
+ match exprs with
+ | [] -> acc
+ | [ h ] ->
+ // tailcall - e.g. Cons(x, Cons(x2, .......Cons(x1000000, Nil))) and [| x1; .... ; x1000000 |]
+ accFreeInExpr opts h acc
+ | h :: t ->
+ let acc = accFreeInExpr opts h acc
+ accFreeInExprs opts t acc
+
+ and accFreeInSlotSig opts (TSlotSig(_, ty, _, _, _, _)) acc = accFreeVarsInTy opts ty acc
+
+ and freeInDecisionTree opts dtree =
+ accFreeInDecisionTree opts dtree emptyFreeVars
+
+ and freeInExpr opts expr = accFreeInExpr opts expr emptyFreeVars
+
+ // Note: these are only an approximation - they are currently used only by the optimizer
+ let rec accFreeInModuleOrNamespace opts mexpr acc =
+ match mexpr with
+ | TMDefRec(_, _, _, mbinds, _) -> List.foldBack (accFreeInModuleOrNamespaceBind opts) mbinds acc
+ | TMDefLet(bind, _) -> accBindRhs opts bind acc
+ | TMDefDo(e, _) -> accFreeInExpr opts e acc
+ | TMDefOpens _ -> acc
+ | TMDefs defs -> accFreeInModuleOrNamespaces opts defs acc
+
+ and accFreeInModuleOrNamespaceBind opts mbind acc =
+ match mbind with
+ | ModuleOrNamespaceBinding.Binding bind -> accBindRhs opts bind acc
+ | ModuleOrNamespaceBinding.Module(_, def) -> accFreeInModuleOrNamespace opts def acc
+
+ and accFreeInModuleOrNamespaces opts mexprs acc =
+ List.foldBack (accFreeInModuleOrNamespace opts) mexprs acc
+
+ let freeInBindingRhs opts bind = accBindRhs opts bind emptyFreeVars
+
+ let freeInModuleOrNamespace opts mdef =
+ accFreeInModuleOrNamespace opts mdef emptyFreeVars
+
+[]
+module internal ExprRemapping =
+
+ //---------------------------------------------------------------------------
+ // Destruct - rarely needed
+ //---------------------------------------------------------------------------
+
+ let rec stripLambda (expr, ty) =
+ match expr with
+ | Expr.Lambda(_, ctorThisValOpt, baseValOpt, v, bodyExpr, _, bodyTy) ->
+ if Option.isSome ctorThisValOpt then
+ errorR (InternalError("skipping ctorThisValOpt", expr.Range))
+
+ if Option.isSome baseValOpt then
+ errorR (InternalError("skipping baseValOpt", expr.Range))
+
+ let vs', bodyExpr', bodyTy' = stripLambda (bodyExpr, bodyTy)
+ (v :: vs', bodyExpr', bodyTy')
+ | _ -> ([], expr, ty)
+
+ let rec stripLambdaN n expr =
+ assert (n >= 0)
+
+ match expr with
+ | Expr.Lambda(_, ctorThisValOpt, baseValOpt, v, bodyExpr, _, _) when n > 0 ->
+ if Option.isSome ctorThisValOpt then
+ errorR (InternalError("skipping ctorThisValOpt", expr.Range))
+
+ if Option.isSome baseValOpt then
+ errorR (InternalError("skipping baseValOpt", expr.Range))
+
+ let vs, bodyExpr', remaining = stripLambdaN (n - 1) bodyExpr
+ (v :: vs, bodyExpr', remaining)
+ | _ -> ([], expr, n)
+
+ let tryStripLambdaN n expr =
+ match expr with
+ | Expr.Lambda(_, None, None, _, _, _, _) ->
+ let argvsl, bodyExpr, remaining = stripLambdaN n expr
+ if remaining = 0 then Some(argvsl, bodyExpr) else None
+ | _ -> None
+
+ let stripTopLambda (expr, exprTy) =
+ let tps, taue, tauty =
+ match expr with
+ | Expr.TyLambda(_, tps, body, _, bodyTy) -> tps, body, bodyTy
+ | _ -> [], expr, exprTy
+
+ let vs, body, bodyTy = stripLambda (taue, tauty)
+ tps, vs, body, bodyTy
+
+ []
+ type AllowTypeDirectedDetupling =
+ | Yes
+ | No
+
+ // This is used to infer arities of expressions
+ // i.e. base the chosen arity on the syntactic expression shape and type of arguments
+ let InferValReprInfoOfExpr g allowTypeDirectedDetupling ty partialArgAttribsL retAttribs expr =
+ let rec stripLambda_notypes e =
+ match stripDebugPoints e with
+ | Expr.Lambda(_, _, _, vs, b, _, _) ->
+ let vs', b' = stripLambda_notypes b
+ (vs :: vs', b')
+ | Expr.TyChoose(_, b, _) -> stripLambda_notypes b
+ | _ -> ([], e)
+
+ let stripTopLambdaNoTypes e =
+ let tps, taue =
+ match stripDebugPoints e with
+ | Expr.TyLambda(_, tps, b, _, _) -> tps, b
+ | _ -> [], e
+
+ let vs, body = stripLambda_notypes taue
+ tps, vs, body
+
+ let tps, vsl, _ = stripTopLambdaNoTypes expr
+ let fun_arity = vsl.Length
+ let dtys, _ = stripFunTyN g fun_arity (snd (tryDestForallTy g ty))
+ let partialArgAttribsL = Array.ofList partialArgAttribsL
+ assert (List.length vsl = List.length dtys)
+
+ let curriedArgInfos =
+ (vsl, dtys)
+ ||> List.mapi2 (fun i vs ty ->
+ let partialAttribs =
+ if i < partialArgAttribsL.Length then
+ partialArgAttribsL[i]
+ else
+ []
+
+ let tys =
+ match allowTypeDirectedDetupling with
+ | AllowTypeDirectedDetupling.No -> [ ty ]
+ | AllowTypeDirectedDetupling.Yes ->
+ if (i = 0 && isUnitTy g ty) then
+ []
+ else
+ tryDestRefTupleTy g ty
+
+ let ids =
+ if vs.Length = tys.Length then
+ vs |> List.map (fun v -> Some v.Id)
+ else
+ tys |> List.map (fun _ -> None)
+
+ let attribs =
+ if partialAttribs.Length = tys.Length then
+ partialAttribs
+ else
+ tys |> List.map (fun _ -> [])
+
+ (ids, attribs)
+ ||> List.map2 (fun id attribs ->
+ {
+ Name = id
+ Attribs = WellKnownValAttribs.Create(attribs)
+ OtherRange = None
+ }
+ : ArgReprInfo))
+
+ let retInfo: ArgReprInfo =
+ {
+ Attribs = WellKnownValAttribs.Create(retAttribs)
+ Name = None
+ OtherRange = None
+ }
+
+ let info = ValReprInfo(ValReprInfo.InferTyparInfo tps, curriedArgInfos, retInfo)
+
+ if ValReprInfo.IsEmpty info then
+ ValReprInfo.emptyValData
+ else
+ info
+
+ let InferValReprInfoOfBinding g allowTypeDirectedDetupling (v: Val) expr =
+ match v.ValReprInfo with
+ | Some info -> info
+ | None -> InferValReprInfoOfExpr g allowTypeDirectedDetupling v.Type [] [] expr
+
+ //-------------------------------------------------------------------------
+ // Check if constraints are satisfied that allow us to use more optimized
+ // implementations
+ //-------------------------------------------------------------------------
+
+ //--------------------------------------------------------------------------
+ // Resolve static optimization constraints
+ //--------------------------------------------------------------------------
+
+ type StaticOptimizationAnswer =
+ | Yes = 1y
+ | No = -1y
+ | Unknown = 0y
+
+ // Most static optimization conditionals in FSharp.Core are
+ // ^T : tycon
+ //
+ // These decide positively if ^T is nominal and identical to tycon.
+ // These decide negatively if ^T is nominal and different to tycon.
+ //
+ // The "special" static optimization conditionals
+ // ^T : ^T
+ // 'T : 'T
+ // are used as hacks in FSharp.Core as follows:
+ // ^T : ^T --> used in (+), (-) etc. to guard witness-invoking implementations added in F# 5
+ // 'T : 'T --> used in FastGenericEqualityComparer, FastGenericComparer to guard struct/tuple implementations
+ //
+ // For performance and compatibility reasons, 'T when 'T is an enum is handled with its own special hack.
+ // Unlike for other 'T : tycon constraints, 'T can be any enum; it need not (and indeed must not) be identical to System.Enum itself.
+ // 'T : Enum
+ //
+ // In order to add this hack in a backwards-compatible way, we must hide this capability behind a marker type
+ // which we use solely as an indicator of whether the compiler understands `when 'T : Enum`.
+ // 'T : SupportsWhenTEnum
+ //
+ // canDecideTyparEqn is set to true in IlxGen when the witness-invoking implementation can be used.
+ let decideStaticOptimizationConstraint g c canDecideTyparEqn =
+ match c with
+ | TTyconEqualsTycon(a, b) when canDecideTyparEqn && typeEquiv g a b && isTyparTy g a -> StaticOptimizationAnswer.Yes
+ | TTyconEqualsTycon(_, b) when tryTcrefOfAppTy g b |> ValueOption.exists (tyconRefEq g g.SupportsWhenTEnum_tcr) ->
+ StaticOptimizationAnswer.Yes
+ | TTyconEqualsTycon(a, b) when
+ isEnumTy g a
+ && not (typeEquiv g a g.system_Enum_ty)
+ && typeEquiv g b g.system_Enum_ty
+ ->
+ StaticOptimizationAnswer.Yes
+ | TTyconEqualsTycon(a, b) ->
+ // Both types must be nominal for a definite result
+ let rec checkTypes a b =
+ let a = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g a)
+
+ match a with
+ | AppTy g (tcref1, _) ->
+ let b = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g b)
+
+ match b with
+ | AppTy g (tcref2, _) ->
+ if tyconRefEq g tcref1 tcref2 && not (typeEquiv g a g.system_Enum_ty) then
+ StaticOptimizationAnswer.Yes
+ else
+ StaticOptimizationAnswer.No
+ | RefTupleTy g _
+ | FunTy g _ -> StaticOptimizationAnswer.No
+ | _ -> StaticOptimizationAnswer.Unknown
+
+ | FunTy g _ ->
+ let b = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g b)
+
+ match b with
+ | FunTy g _ -> StaticOptimizationAnswer.Yes
+ | AppTy g _
+ | RefTupleTy g _ -> StaticOptimizationAnswer.No
+ | _ -> StaticOptimizationAnswer.Unknown
+ | RefTupleTy g ts1 ->
+ let b = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g b)
+
+ match b with
+ | RefTupleTy g ts2 ->
+ if ts1.Length = ts2.Length then
+ StaticOptimizationAnswer.Yes
+ else
+ StaticOptimizationAnswer.No
+ | AppTy g _
+ | FunTy g _ -> StaticOptimizationAnswer.No
+ | _ -> StaticOptimizationAnswer.Unknown
+ | _ -> StaticOptimizationAnswer.Unknown
+
+ checkTypes a b
+ | TTyconIsStruct a ->
+ let a = normalizeEnumTy g (stripTyEqnsAndMeasureEqns g a)
+
+ match tryTcrefOfAppTy g a with
+ | ValueSome tcref1 ->
+ if tcref1.IsStructOrEnumTycon then
+ StaticOptimizationAnswer.Yes
+ else
+ StaticOptimizationAnswer.No
+ | ValueNone -> StaticOptimizationAnswer.Unknown
+
+ let rec DecideStaticOptimizations g cs canDecideTyparEqn =
+ match cs with
+ | [] -> StaticOptimizationAnswer.Yes
+ | h :: t ->
+ let d = decideStaticOptimizationConstraint g h canDecideTyparEqn
+
+ if d = StaticOptimizationAnswer.No then
+ StaticOptimizationAnswer.No
+ elif d = StaticOptimizationAnswer.Yes then
+ DecideStaticOptimizations g t canDecideTyparEqn
+ else
+ StaticOptimizationAnswer.Unknown
+
+ let mkStaticOptimizationExpr g (cs, e1, e2, m) =
+ let d = DecideStaticOptimizations g cs false
+
+ if d = StaticOptimizationAnswer.No then e2
+ elif d = StaticOptimizationAnswer.Yes then e1
+ else Expr.StaticOptimization(cs, e1, e2, m)
+
+ //--------------------------------------------------------------------------
+ // Copy expressions, including new names for locally bound values.
+ // Used to inline expressions.
+ //--------------------------------------------------------------------------
+
+ type ValCopyFlag =
+ | CloneAll
+ | CloneAllAndMarkExprValsAsCompilerGenerated
+ | OnlyCloneExprVals
+
+ // for quotations we do no want to avoid marking values as compiler generated since this may affect the shape of quotation (compiler generated values can be inlined)
+ let fixValCopyFlagForQuotations =
+ function
+ | CloneAllAndMarkExprValsAsCompilerGenerated -> CloneAll
+ | x -> x
+
+ let markAsCompGen compgen d =
+ let compgen =
+ match compgen with
+ | CloneAllAndMarkExprValsAsCompilerGenerated -> true
+ | _ -> false
+
+ { d with
+ val_flags = d.val_flags.WithIsCompilerGenerated(d.val_flags.IsCompilerGenerated || compgen)
+ }
+
+ let bindLocalVal (v: Val) (v': Val) tmenv =
+ { tmenv with
+ valRemap = tmenv.valRemap.Add v (mkLocalValRef v')
+ }
+
+ let bindLocalVals vs vs' tmenv =
+ { tmenv with
+ valRemap =
+ (vs, vs', tmenv.valRemap)
+ |||> List.foldBack2 (fun v v' acc -> acc.Add v (mkLocalValRef v'))
+ }
+
+ let bindTycons tcs tcs' tyenv =
+ { tyenv with
+ tyconRefRemap =
+ (tcs, tcs', tyenv.tyconRefRemap)
+ |||> List.foldBack2 (fun tc tc' acc -> acc.Add (mkLocalTyconRef tc) (mkLocalTyconRef tc'))
+ }
+
+ let remapAttribKind tmenv k =
+ match k with
+ | ILAttrib _ as x -> x
+ | FSAttrib vref -> FSAttrib(remapValRef tmenv vref)
+
+ let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps =
+ let tps', tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tmenv tps
+ let tmenvinner = tyenvinner
+ tps', tmenvinner
+
+ type RemapContext =
+ { g: TcGlobals; stackGuard: StackGuard }
+
+ let mkRemapContext g stackGuard = { g = g; stackGuard = stackGuard }
+
+ let rec remapAttribImpl ctxt tmenv (Attrib(tcref, kind, args, props, isGetOrSetAttr, targets, m)) =
+ Attrib(
+ remapTyconRef tmenv.tyconRefRemap tcref,
+ remapAttribKind tmenv kind,
+ args |> List.map (remapAttribExpr ctxt tmenv),
+ props
+ |> List.map (fun (AttribNamedArg(nm, ty, flg, expr)) ->
+ AttribNamedArg(nm, remapType tmenv ty, flg, remapAttribExpr ctxt tmenv expr)),
+ isGetOrSetAttr,
+ targets,
+ m
+ )
+
+ and remapAttribExpr ctxt tmenv (AttribExpr(e1, e2)) =
+ AttribExpr(remapExprImpl ctxt CloneAll tmenv e1, remapExprImpl ctxt CloneAll tmenv e2)
+
+ and remapAttribs ctxt tmenv xs =
+ List.map (remapAttribImpl ctxt tmenv) xs
+
+ and remapPossibleForallTyImpl ctxt tmenv ty =
+ remapTypeFull (remapAttribs ctxt tmenv) tmenv ty
+
+ and remapArgData ctxt tmenv (argInfo: ArgReprInfo) : ArgReprInfo =
+ {
+ Attribs = WellKnownValAttribs.Create(remapAttribs ctxt tmenv (argInfo.Attribs.AsList()))
+ Name = argInfo.Name
+ OtherRange = argInfo.OtherRange
+ }
+
+ and remapValReprInfo ctxt tmenv (ValReprInfo(tpNames, arginfosl, retInfo)) =
+ ValReprInfo(tpNames, List.mapSquared (remapArgData ctxt tmenv) arginfosl, remapArgData ctxt tmenv retInfo)
+
+ and remapValData ctxt tmenv (d: ValData) =
+ let ty = d.val_type
+ let valReprInfo = d.ValReprInfo
+ let tyR = ty |> remapPossibleForallTyImpl ctxt tmenv
+ let declaringEntityR = d.TryDeclaringEntity |> remapParentRef tmenv
+ let reprInfoR = d.ValReprInfo |> Option.map (remapValReprInfo ctxt tmenv)
+
+ let memberInfoR =
+ d.MemberInfo
+ |> Option.map (remapMemberInfo ctxt d.val_range valReprInfo ty tyR tmenv)
+
+ let attribsR = d.Attribs |> remapAttribs ctxt tmenv
+
+ { d with
+ val_type = tyR
+ val_opt_data =
+ match d.val_opt_data with
+ | Some dd ->
+ Some
+ { dd with
+ val_declaring_entity = declaringEntityR
+ val_repr_info = reprInfoR
+ val_member_info = memberInfoR
+ val_attribs = WellKnownValAttribs.Create(attribsR)
+ }
+ | None -> None
+ }
+
+ and remapParentRef tyenv p =
+ match p with
+ | ParentNone -> ParentNone
+ | Parent x -> Parent(x |> remapTyconRef tyenv.tyconRefRemap)
+
+ and mapImmediateValsAndTycons ft fv (x: ModuleOrNamespaceType) =
+ let vals = x.AllValsAndMembers |> QueueList.map fv
+ let tycons = x.AllEntities |> QueueList.map ft
+ ModuleOrNamespaceType(x.ModuleOrNamespaceKind, vals, tycons)
+
+ and copyVal compgen (v: Val) =
+ match compgen with
+ | OnlyCloneExprVals when v.IsMemberOrModuleBinding -> v
+ | _ -> v |> Construct.NewModifiedVal id
+
+ and fixupValData ctxt compgen tmenv (v2: Val) =
+ // only fixup if we copy the value
+ match compgen with
+ | OnlyCloneExprVals when v2.IsMemberOrModuleBinding -> ()
+ | _ ->
+ let newData = remapValData ctxt tmenv v2 |> markAsCompGen compgen
+ // uses the same stamp
+ v2.SetData newData
+
+ and copyAndRemapAndBindVals ctxt compgen tmenv vs =
+ let vs2 = vs |> List.map (copyVal compgen)
+ let tmenvinner = bindLocalVals vs vs2 tmenv
+ vs2 |> List.iter (fixupValData ctxt compgen tmenvinner)
+ vs2, tmenvinner
+
+ and copyAndRemapAndBindVal ctxt compgen tmenv v =
+ let v2 = v |> copyVal compgen
+ let tmenvinner = bindLocalVal v v2 tmenv
+ fixupValData ctxt compgen tmenvinner v2
+ v2, tmenvinner
+
+ and remapExprImpl (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) expr =
+
+ // Guard against stack overflow, moving to a whole new stack if necessary
+ ctxt.stackGuard.Guard
+ <| fun () ->
+
+ match expr with
+
+ // Handle the linear cases for arbitrary-sized inputs
+ | LinearOpExpr _
+ | LinearMatchExpr _
+ | Expr.Sequential _
+ | Expr.Let _
+ | Expr.DebugPoint _ -> remapLinearExpr ctxt compgen tmenv expr id
+
+ // Binding constructs - see also dtrees below
+ | Expr.Lambda(_, ctorThisValOpt, baseValOpt, vs, b, m, bodyTy) ->
+ remapLambaExpr ctxt compgen tmenv (ctorThisValOpt, baseValOpt, vs, b, m, bodyTy)
+
+ | Expr.TyLambda(_, tps, b, m, bodyTy) ->
+ let tps', tmenvinner =
+ tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv tps
+
+ mkTypeLambda m tps' (remapExprImpl ctxt compgen tmenvinner b, remapType tmenvinner bodyTy)
+
+ | Expr.TyChoose(tps, b, m) ->
+ let tps', tmenvinner =
+ tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv tps
+
+ Expr.TyChoose(tps', remapExprImpl ctxt compgen tmenvinner b, m)
+
+ | Expr.LetRec(binds, e, m, _) ->
+ let binds', tmenvinner = copyAndRemapAndBindBindings ctxt compgen tmenv binds
+ Expr.LetRec(binds', remapExprImpl ctxt compgen tmenvinner e, m, Construct.NewFreeVarsCache())
+
+ | Expr.Match(spBind, mExpr, pt, targets, m, ty) ->
+ primMkMatch (
+ spBind,
+ mExpr,
+ remapDecisionTree ctxt compgen tmenv pt,
+ targets |> Array.map (remapTarget ctxt compgen tmenv),
+ m,
+ remapType tmenv ty
+ )
+
+ | Expr.Val(vr, vf, m) ->
+ let vr' = remapValRef tmenv vr
+ let vf' = remapValFlags tmenv vf
+
+ if vr === vr' && vf === vf' then
+ expr
+ else
+ Expr.Val(vr', vf', m)
+
+ | Expr.Quote(a, dataCell, isFromQueryExpression, m, ty) ->
+ remapQuoteExpr ctxt compgen tmenv (a, dataCell, isFromQueryExpression, m, ty)
+
+ | Expr.Obj(_, ty, basev, basecall, overrides, iimpls, m) ->
+ let basev', tmenvinner =
+ Option.mapFold (copyAndRemapAndBindVal ctxt compgen) tmenv basev
+
+ mkObjExpr (
+ remapType tmenv ty,
+ basev',
+ remapExprImpl ctxt compgen tmenv basecall,
+ List.map (remapMethod ctxt compgen tmenvinner) overrides,
+ List.map (remapInterfaceImpl ctxt compgen tmenvinner) iimpls,
+ m
+ )
+
+ // Addresses of immutable field may "leak" across assembly boundaries - see CanTakeAddressOfRecdFieldRef below.
+ // This is "ok", in the sense that it is always valid to fix these up to be uses
+ // of a temporary local, e.g.
+ // &(E.RF) --> let mutable v = E.RF in &v
+
+ | Expr.Op(TOp.ValFieldGetAddr(rfref, readonly), tinst, [ arg ], m) when
+ not rfref.RecdField.IsMutable
+ && not (entityRefInThisAssembly ctxt.g.compilingFSharpCore rfref.TyconRef)
+ ->
+
+ let tinst = remapTypes tmenv tinst
+ let arg = remapExprImpl ctxt compgen tmenv arg
+
+ let tmp, _ =
+ mkMutableCompGenLocal m WellKnownNames.CopyOfStruct (actualTyOfRecdFieldRef rfref tinst)
+
+ mkCompGenLet m tmp (mkRecdFieldGetViaExprAddr (arg, rfref, tinst, m)) (mkValAddr m readonly (mkLocalValRef tmp))
+
+ | Expr.Op(TOp.UnionCaseFieldGetAddr(uref, cidx, readonly), tinst, [ arg ], m) when
+ not (uref.FieldByIndex(cidx).IsMutable)
+ && not (entityRefInThisAssembly ctxt.g.compilingFSharpCore uref.TyconRef)
+ ->
+
+ let tinst = remapTypes tmenv tinst
+ let arg = remapExprImpl ctxt compgen tmenv arg
+
+ let tmp, _ =
+ mkMutableCompGenLocal m WellKnownNames.CopyOfStruct (actualTyOfUnionFieldRef uref cidx tinst)
+
+ mkCompGenLet
+ m
+ tmp
+ (mkUnionCaseFieldGetProvenViaExprAddr (arg, uref, tinst, cidx, m))
+ (mkValAddr m readonly (mkLocalValRef tmp))
+
+ | Expr.Op(op, tinst, args, m) -> remapOpExpr ctxt compgen tmenv (op, tinst, args, m) expr
+
+ | Expr.App(e1, e1ty, tyargs, args, m) -> remapAppExpr ctxt compgen tmenv (e1, e1ty, tyargs, args, m) expr
+
+ | Expr.Link eref -> remapExprImpl ctxt compgen tmenv eref.Value
+
+ | Expr.StaticOptimization(cs, e2, e3, m) ->
+ // note that type instantiation typically resolve the static constraints here
+ mkStaticOptimizationExpr
+ ctxt.g
+ (List.map (remapConstraint tmenv) cs, remapExprImpl ctxt compgen tmenv e2, remapExprImpl ctxt compgen tmenv e3, m)
+
+ | Expr.Const(c, m, ty) ->
+ let ty' = remapType tmenv ty
+ if ty === ty' then expr else Expr.Const(c, m, ty')
+
+ | Expr.WitnessArg(traitInfo, m) ->
+ let traitInfoR = remapTraitInfo tmenv traitInfo
+ Expr.WitnessArg(traitInfoR, m)
+
+ and remapLambaExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (ctorThisValOpt, baseValOpt, vs, body, m, bodyTy) =
+ let ctorThisValOptR, tmenv =
+ Option.mapFold (copyAndRemapAndBindVal ctxt compgen) tmenv ctorThisValOpt
+
+ let baseValOptR, tmenv =
+ Option.mapFold (copyAndRemapAndBindVal ctxt compgen) tmenv baseValOpt
+
+ let vsR, tmenv = copyAndRemapAndBindVals ctxt compgen tmenv vs
+ let bodyR = remapExprImpl ctxt compgen tmenv body
+ let bodyTyR = remapType tmenv bodyTy
+ Expr.Lambda(newUnique (), ctorThisValOptR, baseValOptR, vsR, bodyR, m, bodyTyR)
+
+ and remapQuoteExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (a, dataCell, isFromQueryExpression, m, ty) =
+ let doData (typeDefs, argTypes, argExprs, res) =
+ (typeDefs, remapTypesAux tmenv argTypes, remapExprs ctxt compgen tmenv argExprs, res)
+
+ let data' =
+ match dataCell.Value with
+ | None -> None
+ | Some(data1, data2) -> Some(doData data1, doData data2)
+ // fix value of compgen for both original expression and pickled AST
+ let compgen = fixValCopyFlagForQuotations compgen
+ Expr.Quote(remapExprImpl ctxt compgen tmenv a, ref data', isFromQueryExpression, m, remapType tmenv ty)
+
+ and remapOpExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (op, tinst, args, m) origExpr =
+ let opR = remapOp tmenv op
+ let tinstR = remapTypes tmenv tinst
+ let argsR = remapExprs ctxt compgen tmenv args
+
+ if op === opR && tinst === tinstR && args === argsR then
+ origExpr
+ else
+ Expr.Op(opR, tinstR, argsR, m)
+
+ and remapAppExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (e1, e1ty, tyargs, args, m) origExpr =
+ let e1R = remapExprImpl ctxt compgen tmenv e1
+ let e1tyR = remapPossibleForallTyImpl ctxt tmenv e1ty
+ let tyargsR = remapTypes tmenv tyargs
+ let argsR = remapExprs ctxt compgen tmenv args
+
+ if e1 === e1R && e1ty === e1tyR && tyargs === tyargsR && args === argsR then
+ origExpr
+ else
+ Expr.App(e1R, e1tyR, tyargsR, argsR, m)
+
+ and remapTarget ctxt compgen tmenv (TTarget(vs, e, flags)) =
+ let vsR, tmenvinner = copyAndRemapAndBindVals ctxt compgen tmenv vs
+ TTarget(vsR, remapExprImpl ctxt compgen tmenvinner e, flags)
+
+ and remapLinearExpr ctxt compgen tmenv expr contf =
+
+ match expr with
+
+ | Expr.Let(bind, bodyExpr, m, _) ->
+ let bindR, tmenvinner = copyAndRemapAndBindBinding ctxt compgen tmenv bind
+ // tailcall for the linear position
+ remapLinearExpr ctxt compgen tmenvinner bodyExpr (contf << mkLetBind m bindR)
+
+ | Expr.Sequential(expr1, expr2, dir, m) ->
+ let expr1R = remapExprImpl ctxt compgen tmenv expr1
+ // tailcall for the linear position
+ remapLinearExpr
+ ctxt
+ compgen
+ tmenv
+ expr2
+ (contf
+ << (fun expr2R ->
+ if expr1 === expr1R && expr2 === expr2R then
+ expr
+ else
+ Expr.Sequential(expr1R, expr2R, dir, m)))
+
+ | LinearMatchExpr(spBind, mExpr, dtree, tg1, expr2, m2, ty) ->
+ let dtreeR = remapDecisionTree ctxt compgen tmenv dtree
+ let tg1R = remapTarget ctxt compgen tmenv tg1
+ let tyR = remapType tmenv ty
+ // tailcall for the linear position
+ remapLinearExpr
+ ctxt
+ compgen
+ tmenv
+ expr2
+ (contf
+ << (fun expr2R -> rebuildLinearMatchExpr (spBind, mExpr, dtreeR, tg1R, expr2R, m2, tyR)))
+
+ | LinearOpExpr(op, tyargs, argsFront, argLast, m) ->
+ let opR = remapOp tmenv op
+ let tinstR = remapTypes tmenv tyargs
+ let argsFrontR = remapExprs ctxt compgen tmenv argsFront
+ // tailcall for the linear position
+ remapLinearExpr
+ ctxt
+ compgen
+ tmenv
+ argLast
+ (contf
+ << (fun argLastR ->
+ if
+ op === opR
+ && tyargs === tinstR
+ && argsFront === argsFrontR
+ && argLast === argLastR
+ then
+ expr
+ else
+ rebuildLinearOpExpr (opR, tinstR, argsFrontR, argLastR, m)))
+
+ | Expr.DebugPoint(dpm, innerExpr) ->
+ remapLinearExpr ctxt compgen tmenv innerExpr (contf << (fun innerExprR -> Expr.DebugPoint(dpm, innerExprR)))
+
+ | _ -> contf (remapExprImpl ctxt compgen tmenv expr)
+
+ and remapConstraint tyenv c =
+ match c with
+ | TTyconEqualsTycon(ty1, ty2) -> TTyconEqualsTycon(remapType tyenv ty1, remapType tyenv ty2)
+ | TTyconIsStruct ty1 -> TTyconIsStruct(remapType tyenv ty1)
+
+ and remapOp tmenv op =
+ match op with
+ | TOp.Recd(ctor, tcref) -> TOp.Recd(ctor, remapTyconRef tmenv.tyconRefRemap tcref)
+ | TOp.UnionCaseTagGet tcref -> TOp.UnionCaseTagGet(remapTyconRef tmenv.tyconRefRemap tcref)
+ | TOp.UnionCase ucref -> TOp.UnionCase(remapUnionCaseRef tmenv.tyconRefRemap ucref)
+ | TOp.UnionCaseProof ucref -> TOp.UnionCaseProof(remapUnionCaseRef tmenv.tyconRefRemap ucref)
+ | TOp.ExnConstr ec -> TOp.ExnConstr(remapTyconRef tmenv.tyconRefRemap ec)
+ | TOp.ExnFieldGet(ec, n) -> TOp.ExnFieldGet(remapTyconRef tmenv.tyconRefRemap ec, n)
+ | TOp.ExnFieldSet(ec, n) -> TOp.ExnFieldSet(remapTyconRef tmenv.tyconRefRemap ec, n)
+ | TOp.ValFieldSet rfref -> TOp.ValFieldSet(remapRecdFieldRef tmenv.tyconRefRemap rfref)
+ | TOp.ValFieldGet rfref -> TOp.ValFieldGet(remapRecdFieldRef tmenv.tyconRefRemap rfref)
+ | TOp.ValFieldGetAddr(rfref, readonly) -> TOp.ValFieldGetAddr(remapRecdFieldRef tmenv.tyconRefRemap rfref, readonly)
+ | TOp.UnionCaseFieldGet(ucref, n) -> TOp.UnionCaseFieldGet(remapUnionCaseRef tmenv.tyconRefRemap ucref, n)
+ | TOp.UnionCaseFieldGetAddr(ucref, n, readonly) ->
+ TOp.UnionCaseFieldGetAddr(remapUnionCaseRef tmenv.tyconRefRemap ucref, n, readonly)
+ | TOp.UnionCaseFieldSet(ucref, n) -> TOp.UnionCaseFieldSet(remapUnionCaseRef tmenv.tyconRefRemap ucref, n)
+ | TOp.ILAsm(instrs, retTypes) ->
+ let retTypes2 = remapTypes tmenv retTypes
+
+ if retTypes === retTypes2 then
+ op
+ else
+ TOp.ILAsm(instrs, retTypes2)
+ | TOp.TraitCall traitInfo -> TOp.TraitCall(remapTraitInfo tmenv traitInfo)
+ | TOp.LValueOp(kind, lvr) -> TOp.LValueOp(kind, remapValRef tmenv lvr)
+ | TOp.ILCall(isVirtual,
+ isProtected,
+ isStruct,
+ isCtor,
+ valUseFlag,
+ isProperty,
+ noTailCall,
+ ilMethRef,
+ enclTypeInst,
+ methInst,
+ retTypes) ->
+ TOp.ILCall(
+ isVirtual,
+ isProtected,
+ isStruct,
+ isCtor,
+ remapValFlags tmenv valUseFlag,
+ isProperty,
+ noTailCall,
+ ilMethRef,
+ remapTypes tmenv enclTypeInst,
+ remapTypes tmenv methInst,
+ remapTypes tmenv retTypes
+ )
+ | _ -> op
+
+ and remapValFlags tmenv x =
+ match x with
+ | PossibleConstrainedCall ty -> PossibleConstrainedCall(remapType tmenv ty)
+ | _ -> x
+
+ and remapExprs ctxt compgen tmenv es =
+ List.mapq (remapExprImpl ctxt compgen tmenv) es
+
+ and remapFlatExprs ctxt compgen tmenv es =
+ List.mapq (remapExprImpl ctxt compgen tmenv) es
+
+ and remapDecisionTree ctxt compgen tmenv x =
+ match x with
+ | TDSwitch(e1, cases, dflt, m) ->
+ let e1R = remapExprImpl ctxt compgen tmenv e1
+
+ let casesR =
+ cases
+ |> List.map (fun (TCase(test, subTree)) ->
+ let testR =
+ match test with
+ | DecisionTreeTest.UnionCase(uc, tinst) ->
+ DecisionTreeTest.UnionCase(remapUnionCaseRef tmenv.tyconRefRemap uc, remapTypes tmenv tinst)
+ | DecisionTreeTest.ArrayLength(n, ty) -> DecisionTreeTest.ArrayLength(n, remapType tmenv ty)
+ | DecisionTreeTest.Const _ -> test
+ | DecisionTreeTest.IsInst(srcTy, tgtTy) -> DecisionTreeTest.IsInst(remapType tmenv srcTy, remapType tmenv tgtTy)
+ | DecisionTreeTest.IsNull -> DecisionTreeTest.IsNull
+ | DecisionTreeTest.ActivePatternCase _ ->
+ failwith "DecisionTreeTest.ActivePatternCase should only be used during pattern match compilation"
+ | DecisionTreeTest.Error(m) -> DecisionTreeTest.Error(m)
+
+ let subTreeR = remapDecisionTree ctxt compgen tmenv subTree
+ TCase(testR, subTreeR))
+
+ let dfltR = Option.map (remapDecisionTree ctxt compgen tmenv) dflt
+ TDSwitch(e1R, casesR, dfltR, m)
+
+ | TDSuccess(es, n) -> TDSuccess(remapFlatExprs ctxt compgen tmenv es, n)
+
+ | TDBind(bind, rest) ->
+ let bindR, tmenvinner = copyAndRemapAndBindBinding ctxt compgen tmenv bind
+ TDBind(bindR, remapDecisionTree ctxt compgen tmenvinner rest)
+
+ and copyAndRemapAndBindBinding ctxt compgen tmenv (bind: Binding) =
+ let v = bind.Var
+ let vR, tmenv = copyAndRemapAndBindVal ctxt compgen tmenv v
+ remapAndRenameBind ctxt compgen tmenv bind vR, tmenv
+
+ and copyAndRemapAndBindBindings ctxt compgen tmenv binds =
+ let vsR, tmenvinner = copyAndRemapAndBindVals ctxt compgen tmenv (valsOfBinds binds)
+ remapAndRenameBinds ctxt compgen tmenvinner binds vsR, tmenvinner
+
+ and remapAndRenameBinds ctxt compgen tmenvinner binds vsR =
+ List.map2 (remapAndRenameBind ctxt compgen tmenvinner) binds vsR
+
+ and remapAndRenameBind ctxt compgen tmenvinner (TBind(_, repr, letSeqPtOpt)) vR =
+ TBind(vR, remapExprImpl ctxt compgen tmenvinner repr, letSeqPtOpt)
+
+ and remapMethod ctxt compgen tmenv (TObjExprMethod(slotsig, attribs, tps, vs, e, m)) =
+ let attribs2 = attribs |> remapAttribs ctxt tmenv
+ let slotsig2 = remapSlotSig (remapAttribs ctxt tmenv) tmenv slotsig
+
+ let tps2, tmenvinner =
+ tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv tps
+
+ let vs2, tmenvinner2 =
+ List.mapFold (copyAndRemapAndBindVals ctxt compgen) tmenvinner vs
+
+ let e2 = remapExprImpl ctxt compgen tmenvinner2 e
+ TObjExprMethod(slotsig2, attribs2, tps2, vs2, e2, m)
+
+ and remapInterfaceImpl ctxt compgen tmenv (ty, overrides) =
+ (remapType tmenv ty, List.map (remapMethod ctxt compgen tmenv) overrides)
+
+ and remapRecdField ctxt tmenv x =
+ { x with
+ rfield_type = x.rfield_type |> remapPossibleForallTyImpl ctxt tmenv
+ rfield_pattribs = x.rfield_pattribs |> remapAttribs ctxt tmenv
+ rfield_fattribs = x.rfield_fattribs |> remapAttribs ctxt tmenv
+ }
+
+ and remapRecdFields ctxt tmenv (x: TyconRecdFields) =
+ x.AllFieldsAsList
+ |> List.map (remapRecdField ctxt tmenv)
+ |> Construct.MakeRecdFieldsTable
+
+ and remapUnionCase ctxt tmenv (x: UnionCase) =
+ { x with
+ FieldTable = x.FieldTable |> remapRecdFields ctxt tmenv
+ ReturnType = x.ReturnType |> remapType tmenv
+ Attribs = x.Attribs |> remapAttribs ctxt tmenv
+ }
+
+ and remapUnionCases ctxt tmenv (x: TyconUnionData) =
+ x.UnionCasesAsList
+ |> List.map (remapUnionCase ctxt tmenv)
+ |> Construct.MakeUnionCases
+
+ and remapFsObjData ctxt tmenv x =
+ {
+ fsobjmodel_cases = remapUnionCases ctxt tmenv x.fsobjmodel_cases
+ fsobjmodel_kind =
+ (match x.fsobjmodel_kind with
+ | TFSharpDelegate slotsig -> TFSharpDelegate(remapSlotSig (remapAttribs ctxt tmenv) tmenv slotsig)
+ | _ -> x.fsobjmodel_kind)
+ fsobjmodel_vslots = x.fsobjmodel_vslots |> List.map (remapValRef tmenv)
+ fsobjmodel_rfields = x.fsobjmodel_rfields |> remapRecdFields ctxt tmenv
+ }
+
+ and remapTyconRepr ctxt tmenv repr =
+ match repr with
+ | TFSharpTyconRepr x -> TFSharpTyconRepr(remapFsObjData ctxt tmenv x)
+ | TILObjectRepr _ -> failwith "cannot remap IL type definitions"
+#if !NO_TYPEPROVIDERS
+ | TProvidedNamespaceRepr _ -> repr
+ | TProvidedTypeRepr info ->
+ TProvidedTypeRepr
+ { info with
+ LazyBaseType =
+ info.LazyBaseType.Force(range0, ctxt.g.obj_ty_withNulls)
+ |> remapType tmenv
+ |> LazyWithContext.NotLazy
+ // The load context for the provided type contains TyconRef objects. We must remap these.
+ // This is actually done on-demand (see the implementation of ProvidedTypeContext)
+ ProvidedType =
+ info.ProvidedType.PApplyNoFailure(fun st ->
+ let ctxt =
+ st.Context.RemapTyconRefs(unbox >> remapTyconRef tmenv.tyconRefRemap >> box >> (!!))
+
+ ProvidedType.ApplyContext(st, ctxt))
+ }
+#endif
+ | TNoRepr -> repr
+ | TAsmRepr _ -> repr
+ | TMeasureableRepr x -> TMeasureableRepr(remapType tmenv x)
+
+ and remapTyconAug tmenv (x: TyconAugmentation) =
+ { x with
+ tcaug_equals = x.tcaug_equals |> Option.map (mapPair (remapValRef tmenv, remapValRef tmenv))
+ tcaug_compare = x.tcaug_compare |> Option.map (mapPair (remapValRef tmenv, remapValRef tmenv))
+ tcaug_compare_withc = x.tcaug_compare_withc |> Option.map (remapValRef tmenv)
+ tcaug_hash_and_equals_withc =
+ x.tcaug_hash_and_equals_withc
+ |> Option.map (mapQuadruple (remapValRef tmenv, remapValRef tmenv, remapValRef tmenv, Option.map (remapValRef tmenv)))
+ tcaug_adhoc = x.tcaug_adhoc |> NameMap.map (List.map (remapValRef tmenv))
+ tcaug_adhoc_list =
+ x.tcaug_adhoc_list
+ |> ResizeArray.map (fun (flag, vref) -> (flag, remapValRef tmenv vref))
+ tcaug_super = x.tcaug_super |> Option.map (remapType tmenv)
+ tcaug_interfaces = x.tcaug_interfaces |> List.map (map1Of3 (remapType tmenv))
+ }
+
+ and remapTyconExnInfo ctxt tmenv inp =
+ match inp with
+ | TExnAbbrevRepr x -> TExnAbbrevRepr(remapTyconRef tmenv.tyconRefRemap x)
+ | TExnFresh x -> TExnFresh(remapRecdFields ctxt tmenv x)
+ | TExnAsmRepr _
+ | TExnNone -> inp
+
+ and remapMemberInfo ctxt m valReprInfo ty tyR tmenv x =
+ // The slotsig in the ImplementedSlotSigs is w.r.t. the type variables in the value's type.
+ // REVIEW: this is a bit gross. It would be nice if the slotsig was standalone
+ assert (Option.isSome valReprInfo)
+
+ let tpsorig, _, _, _ =
+ GetMemberTypeInFSharpForm ctxt.g x.MemberFlags (Option.get valReprInfo) ty m
+
+ let tps, _, _, _ =
+ GetMemberTypeInFSharpForm ctxt.g x.MemberFlags (Option.get valReprInfo) tyR m
+
+ let renaming, _ = mkTyparToTyparRenaming tpsorig tps
+
+ let tmenv =
+ { tmenv with
+ tpinst = tmenv.tpinst @ renaming
+ }
+
+ { x with
+ ApparentEnclosingEntity = x.ApparentEnclosingEntity |> remapTyconRef tmenv.tyconRefRemap
+ ImplementedSlotSigs = x.ImplementedSlotSigs |> List.map (remapSlotSig (remapAttribs ctxt tmenv) tmenv)
+ }
+
+ and copyAndRemapAndBindModTy ctxt compgen tmenv mty =
+ let tycons = allEntitiesOfModuleOrNamespaceTy mty
+ let vs = allValsOfModuleOrNamespaceTy mty
+ let _, _, tmenvinner = copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs
+ (mapImmediateValsAndTycons (renameTycon tmenvinner) (renameVal tmenvinner) mty), tmenvinner
+
+ and renameTycon tyenv x =
+ let tcref =
+ try
+ let res = tyenv.tyconRefRemap[mkLocalTyconRef x]
+ res
+ with :? KeyNotFoundException ->
+ errorR (InternalError("couldn't remap internal tycon " + showL (DebugPrint.tyconL x), x.Range))
+ mkLocalTyconRef x
+
+ tcref.Deref
+
+ and renameVal tmenv x =
+ match tmenv.valRemap.TryFind x with
+ | Some v -> v.Deref
+ | None -> x
+
+ and copyTycon compgen (tycon: Tycon) =
+ match compgen with
+ | OnlyCloneExprVals -> tycon
+ | _ -> Construct.NewClonedTycon tycon
+
+ /// This operates over a whole nested collection of tycons and vals simultaneously *)
+ and copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs =
+ let tyconsR = tycons |> List.map (copyTycon compgen)
+
+ let tmenvinner = bindTycons tycons tyconsR tmenv
+
+ // Values need to be copied and renamed.
+ let vsR, tmenvinner = copyAndRemapAndBindVals ctxt compgen tmenvinner vs
+
+ // "if a type constructor is hidden then all its inner values and inner type constructors must also be hidden"
+ // Hence we can just lookup the inner tycon/value mappings in the tables.
+
+ let lookupVal (v: Val) =
+ let vref =
+ try
+ let res = tmenvinner.valRemap[v]
+ res
+ with :? KeyNotFoundException ->
+ errorR (InternalError(sprintf "couldn't remap internal value '%s'" v.LogicalName, v.Range))
+ mkLocalValRef v
+
+ vref.Deref
+
+ let lookupTycon tycon =
+ let tcref =
+ try
+ let res = tmenvinner.tyconRefRemap[mkLocalTyconRef tycon]
+ res
+ with :? KeyNotFoundException ->
+ errorR (InternalError("couldn't remap internal tycon " + showL (DebugPrint.tyconL tycon), tycon.Range))
+ mkLocalTyconRef tycon
+
+ tcref.Deref
+
+ (tycons, tyconsR)
+ ||> List.iter2 (fun tcd tcdR ->
+ let lookupTycon tycon = lookupTycon tycon
+
+ let tpsR, tmenvinner2 =
+ tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenvinner) tmenvinner (tcd.entity_typars.Force(tcd.entity_range))
+
+ tcdR.entity_typars <- LazyWithContext.NotLazy tpsR
+ tcdR.entity_attribs <- WellKnownEntityAttribs.Create(tcd.entity_attribs.AsList() |> remapAttribs ctxt tmenvinner2)
+ tcdR.entity_tycon_repr <- tcd.entity_tycon_repr |> remapTyconRepr ctxt tmenvinner2
+ let typeAbbrevR = tcd.TypeAbbrev |> Option.map (remapType tmenvinner2)
+ tcdR.entity_tycon_tcaug <- tcd.entity_tycon_tcaug |> remapTyconAug tmenvinner2
+ tcdR.entity_modul_type <- MaybeLazy.Strict(tcd.entity_modul_type.Value |> mapImmediateValsAndTycons lookupTycon lookupVal)
+ let exnInfoR = tcd.ExceptionInfo |> remapTyconExnInfo ctxt tmenvinner2
+
+ match tcdR.entity_opt_data with
+ | Some optData ->
+ tcdR.entity_opt_data <-
+ Some
+ { optData with
+ entity_tycon_abbrev = typeAbbrevR
+ entity_exn_info = exnInfoR
+ }
+ | _ ->
+ tcdR.SetTypeAbbrev typeAbbrevR
+ tcdR.SetExceptionInfo exnInfoR)
+
+ tyconsR, vsR, tmenvinner
+
+ and allTyconsOfTycon (tycon: Tycon) =
+ seq {
+ yield tycon
+
+ for nestedTycon in tycon.ModuleOrNamespaceType.AllEntities do
+ yield! allTyconsOfTycon nestedTycon
+ }
+
+ and allEntitiesOfModDef mdef =
+ seq {
+ match mdef with
+ | TMDefRec(_, _, tycons, mbinds, _) ->
+ for tycon in tycons do
+ yield! allTyconsOfTycon tycon
+
+ for mbind in mbinds do
+ match mbind with
+ | ModuleOrNamespaceBinding.Binding _ -> ()
+ | ModuleOrNamespaceBinding.Module(mspec, def) ->
+ yield mspec
+ yield! allEntitiesOfModDef def
+ | TMDefLet _ -> ()
+ | TMDefDo _ -> ()
+ | TMDefOpens _ -> ()
+ | TMDefs defs ->
+ for def in defs do
+ yield! allEntitiesOfModDef def
+ }
+
+ and allValsOfModDefWithOption processNested mdef =
+ seq {
+ match mdef with
+ | TMDefRec(_, _, tycons, mbinds, _) ->
+ yield! abstractSlotValsOfTycons tycons
+
+ for mbind in mbinds do
+ match mbind with
+ | ModuleOrNamespaceBinding.Binding bind -> yield bind.Var
+ | ModuleOrNamespaceBinding.Module(_, def) ->
+ if processNested then
+ yield! allValsOfModDefWithOption processNested def
+ | TMDefLet(bind, _) -> yield bind.Var
+ | TMDefDo _ -> ()
+ | TMDefOpens _ -> ()
+ | TMDefs defs ->
+ for def in defs do
+ yield! allValsOfModDefWithOption processNested def
+ }
+
+ and allValsOfModDef mdef = allValsOfModDefWithOption true mdef
+
+ and allTopLevelValsOfModDef mdef = allValsOfModDefWithOption false mdef
+
+ and copyAndRemapModDef ctxt compgen tmenv mdef =
+ let tycons = allEntitiesOfModDef mdef |> List.ofSeq
+ let vs = allValsOfModDef mdef |> List.ofSeq
+ let _, _, tmenvinner = copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs
+ remapAndRenameModDef ctxt compgen tmenvinner mdef
+
+ and remapAndRenameModDefs ctxt compgen tmenv x =
+ List.map (remapAndRenameModDef ctxt compgen tmenv) x
+
+ and remapOpenDeclarations tmenv opens =
+ opens
+ |> List.map (fun od ->
+ { od with
+ Modules = od.Modules |> List.map (remapTyconRef tmenv.tyconRefRemap)
+ Types = od.Types |> List.map (remapType tmenv)
+ })
+
+ and remapAndRenameModDef ctxt compgen tmenv mdef =
+ match mdef with
+ | TMDefRec(isRec, opens, tycons, mbinds, m) ->
+ // Abstract (virtual) vslots in the tycons at TMDefRec nodes are binders. They also need to be copied and renamed.
+ let opensR = remapOpenDeclarations tmenv opens
+ let tyconsR = tycons |> List.map (renameTycon tmenv)
+ let mbindsR = mbinds |> List.map (remapAndRenameModBind ctxt compgen tmenv)
+ TMDefRec(isRec, opensR, tyconsR, mbindsR, m)
+ | TMDefLet(bind, m) ->
+ let v = bind.Var
+ let bind = remapAndRenameBind ctxt compgen tmenv bind (renameVal tmenv v)
+ TMDefLet(bind, m)
+ | TMDefDo(e, m) ->
+ let e = remapExprImpl ctxt compgen tmenv e
+ TMDefDo(e, m)
+ | TMDefOpens opens ->
+ let opens = remapOpenDeclarations tmenv opens
+ TMDefOpens opens
+ | TMDefs defs ->
+ let defs = remapAndRenameModDefs ctxt compgen tmenv defs
+ TMDefs defs
+
+ and remapAndRenameModBind ctxt compgen tmenv x =
+ match x with
+ | ModuleOrNamespaceBinding.Binding bind ->
+ let v2 = bind |> valOfBind |> renameVal tmenv
+ let bind2 = remapAndRenameBind ctxt compgen tmenv bind v2
+ ModuleOrNamespaceBinding.Binding bind2
+ | ModuleOrNamespaceBinding.Module(mspec, def) ->
+ let mspec = renameTycon tmenv mspec
+ let def = remapAndRenameModDef ctxt compgen tmenv def
+ ModuleOrNamespaceBinding.Module(mspec, def)
+
+ and remapImplFile ctxt compgen tmenv implFile =
+ let (CheckedImplFile(fragName, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) =
+ implFile
+
+ let contentsR = copyAndRemapModDef ctxt compgen tmenv contents
+ let signatureR, tmenv = copyAndRemapAndBindModTy ctxt compgen tmenv signature
+
+ let implFileR =
+ CheckedImplFile(fragName, signatureR, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)
+
+ implFileR, tmenv
+
+ // Entry points
+
+ let remapAttrib g tmenv attrib =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ remapAttribImpl ctxt tmenv attrib
+
+ let remapExpr g (compgen: ValCopyFlag) (tmenv: Remap) expr =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ remapExprImpl ctxt compgen tmenv expr
+
+ let remapPossibleForallTy g tmenv ty =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ remapPossibleForallTyImpl ctxt tmenv ty
+
+ let copyModuleOrNamespaceType g compgen mtyp =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ copyAndRemapAndBindModTy ctxt compgen Remap.Empty mtyp |> fst
+
+ let copyExpr g compgen e =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ remapExprImpl ctxt compgen Remap.Empty e
+
+ let copyImplFile g compgen e =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ remapImplFile ctxt compgen Remap.Empty e |> fst
+
+ let instExpr g tpinst e =
+ let ctxt =
+ {
+ g = g
+ stackGuard = StackGuard("RemapExprStackGuardDepth")
+ }
+
+ remapExprImpl ctxt CloneAll (mkInstRemap tpinst) e
+
+[]
+module internal ExprAnalysis =
+
+ //--------------------------------------------------------------------------
+ // Replace Marks - adjust debugging marks when a lambda gets
+ // eliminated (i.e. an expression gets inlined)
+ //--------------------------------------------------------------------------
+
+ let rec remarkExpr (m: range) x =
+ match x with
+ | Expr.Lambda(uniq, ctorThisValOpt, baseValOpt, vs, b, _, bodyTy) ->
+ Expr.Lambda(uniq, ctorThisValOpt, baseValOpt, vs, remarkExpr m b, m, bodyTy)
+
+ | Expr.TyLambda(uniq, tps, b, _, bodyTy) -> Expr.TyLambda(uniq, tps, remarkExpr m b, m, bodyTy)
+
+ | Expr.TyChoose(tps, b, _) -> Expr.TyChoose(tps, remarkExpr m b, m)
+
+ | Expr.LetRec(binds, e, _, fvs) -> Expr.LetRec(remarkBinds m binds, remarkExpr m e, m, fvs)
+
+ | Expr.Let(bind, e, _, fvs) -> Expr.Let(remarkBind m bind, remarkExpr m e, m, fvs)
+
+ | Expr.Match(_, _, pt, targets, _, ty) ->
+ let targetsR =
+ targets
+ |> Array.map (fun (TTarget(vs, e, flags)) -> TTarget(vs, remarkExpr m e, flags))
+
+ primMkMatch (DebugPointAtBinding.NoneAtInvisible, m, remarkDecisionTree m pt, targetsR, m, ty)
+
+ | Expr.Val(x, valUseFlags, _) -> Expr.Val(x, valUseFlags, m)
+
+ | Expr.Quote(a, conv, isFromQueryExpression, _, ty) -> Expr.Quote(remarkExpr m a, conv, isFromQueryExpression, m, ty)
+
+ | Expr.Obj(n, ty, basev, basecall, overrides, iimpls, _) ->
+ Expr.Obj(
+ n,
+ ty,
+ basev,
+ remarkExpr m basecall,
+ List.map (remarkObjExprMethod m) overrides,
+ List.map (remarkInterfaceImpl m) iimpls,
+ m
+ )
+
+ | Expr.Op(op, tinst, args, _) ->
+
+ // This code allows a feature where if a 'while'/'for' etc in a computation expression is
+ // implemented using code inlining and is ultimately implemented by a corresponding construct somewhere
+ // in the remark'd code then at least one debug point is recovered, based on the noted debug point for the original construct.
+ //
+ // However it is imperfect, since only one debug point is recovered
+ let op =
+ match op with
+ | TOp.IntegerForLoop(_, _, style) -> TOp.IntegerForLoop(DebugPointAtFor.No, DebugPointAtInOrTo.No, style)
+ | TOp.While(_, marker) -> TOp.While(DebugPointAtWhile.No, marker)
+ | TOp.TryFinally _ -> TOp.TryFinally(DebugPointAtTry.No, DebugPointAtFinally.No)
+ | TOp.TryWith _ -> TOp.TryWith(DebugPointAtTry.No, DebugPointAtWith.No)
+ | _ -> op
+
+ Expr.Op(op, tinst, remarkExprs m args, m)
+
+ | Expr.Link eref ->
+ // Preserve identity of fixup nodes during remarkExpr
+ eref.Value <- remarkExpr m eref.Value
+ x
+
+ | Expr.App(e1, e1ty, tyargs, args, _) -> Expr.App(remarkExpr m e1, e1ty, tyargs, remarkExprs m args, m)
+
+ | Expr.Sequential(e1, e2, dir, _) ->
+ let e1R = remarkExpr m e1
+ let e2R = remarkExpr m e2
+ Expr.Sequential(e1R, e2R, dir, m)
+
+ | Expr.StaticOptimization(eqns, e2, e3, _) -> Expr.StaticOptimization(eqns, remarkExpr m e2, remarkExpr m e3, m)
+
+ | Expr.Const(c, _, ty) -> Expr.Const(c, m, ty)
+
+ | Expr.WitnessArg(witnessInfo, _) -> Expr.WitnessArg(witnessInfo, m)
+
+ | Expr.DebugPoint(_, innerExpr) -> remarkExpr m innerExpr
+
+ and remarkObjExprMethod m (TObjExprMethod(slotsig, attribs, tps, vs, e, _)) =
+ TObjExprMethod(slotsig, attribs, tps, vs, remarkExpr m e, m)
+
+ and remarkInterfaceImpl m (ty, overrides) =
+ (ty, List.map (remarkObjExprMethod m) overrides)
+
+ and remarkExprs m es = es |> List.map (remarkExpr m)
+
+ and remarkDecisionTree m x =
+ match x with
+ | TDSwitch(e1, cases, dflt, _) ->
+ let e1R = remarkExpr m e1
+
+ let casesR =
+ cases |> List.map (fun (TCase(test, y)) -> TCase(test, remarkDecisionTree m y))
+
+ let dfltR = Option.map (remarkDecisionTree m) dflt
+ TDSwitch(e1R, casesR, dfltR, m)
+ | TDSuccess(es, n) -> TDSuccess(remarkExprs m es, n)
+ | TDBind(bind, rest) -> TDBind(remarkBind m bind, remarkDecisionTree m rest)
+
+ and remarkBinds m binds = List.map (remarkBind m) binds
+
+ // This very deliberately drops the sequence points since this is used when adjusting the marks for inlined expressions
+ and remarkBind m (TBind(v, repr, _)) =
+ TBind(v, remarkExpr m repr, DebugPointAtBinding.NoneAtSticky)
+
+ //--------------------------------------------------------------------------
+ // Mutability analysis
+ //--------------------------------------------------------------------------
+
+ let isRecdOrStructFieldDefinitelyMutable (f: RecdField) = not f.IsStatic && f.IsMutable
+
+ let isUnionCaseDefinitelyMutable (uc: UnionCase) =
+ uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldDefinitelyMutable
+
+ let isUnionCaseRefDefinitelyMutable (uc: UnionCaseRef) =
+ uc.UnionCase |> isUnionCaseDefinitelyMutable
+
+ /// This is an incomplete check for .NET struct types. Returning 'false' doesn't mean the thing is immutable.
+ let isRecdOrUnionOrStructTyconRefDefinitelyMutable (tcref: TyconRef) =
+ let tycon = tcref.Deref
+
+ if tycon.IsUnionTycon then
+ tycon.UnionCasesArray |> Array.exists isUnionCaseDefinitelyMutable
+ elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then
+ // Note: This only looks at the F# fields, causing oddities.
+ // See https://github.com/dotnet/fsharp/pull/4576
+ tycon.AllFieldsArray |> Array.exists isRecdOrStructFieldDefinitelyMutable
+ else
+ false
+
+ // Although from the pure F# perspective exception values cannot be changed, the .NET
+ // implementation of exception objects attaches a whole bunch of stack information to
+ // each raised object. Hence we treat exception objects as if they have identity
+ let isExnDefinitelyMutable (_ecref: TyconRef) = true
+
+ // Some of the implementations of library functions on lists use mutation on the tail
+ // of the cons cell. These cells are always private, i.e. not accessible by any other
+ // code until the construction of the entire return list has been completed.
+ // However, within the implementation code reads of the tail cell must in theory be treated
+ // with caution. Hence we are conservative and within FSharp.Core we don't treat list
+ // reads as if they were pure.
+ let isUnionCaseFieldMutable (g: TcGlobals) (ucref: UnionCaseRef) n =
+ (g.compilingFSharpCore && tyconRefEq g ucref.TyconRef g.list_tcr_canon && n = 1)
+ || (ucref.FieldByIndex n).IsMutable
+
+ let isExnFieldMutable ecref n =
+ if n < 0 || n >= List.length (recdFieldsOfExnDefRef ecref) then
+ errorR (InternalError(sprintf "isExnFieldMutable, exnc = %s, n = %d" ecref.LogicalName n, ecref.Range))
+
+ (recdFieldOfExnDefRefByIdx ecref n).IsMutable
+
+ //---------------------------------------------------------------------------
+ // Witnesses
+ //---------------------------------------------------------------------------
+
+ let GenWitnessArgTys (g: TcGlobals) (traitInfo: TraitWitnessInfo) =
+ let (TraitWitnessInfo(_tys, _nm, _memFlags, argTys, _rty)) = traitInfo
+ let argTys = if argTys.IsEmpty then [ g.unit_ty ] else argTys
+ let argTysl = List.map List.singleton argTys
+ argTysl
+
+ let GenWitnessTy (g: TcGlobals) (traitInfo: TraitWitnessInfo) =
+ let retTy =
+ match traitInfo.ReturnType with
+ | None -> g.unit_ty
+ | Some ty -> ty
+
+ let argTysl = GenWitnessArgTys g traitInfo
+ mkMethodTy g argTysl retTy
+
+ let GenWitnessTys (g: TcGlobals) (cxs: TraitWitnessInfos) =
+ if g.generateWitnesses then
+ cxs |> List.map (GenWitnessTy g)
+ else
+ []
+
+ //--------------------------------------------------------------------------
+ // tyOfExpr
+ //--------------------------------------------------------------------------
+
+ let rec tyOfExpr g expr =
+ match expr with
+ | Expr.App(_, fty, tyargs, args, _) -> applyTys g fty (tyargs, args)
+ | Expr.Obj(_, ty, _, _, _, _, _)
+ | Expr.Match(_, _, _, _, _, ty)
+ | Expr.Quote(_, _, _, _, ty)
+ | Expr.Const(_, _, ty) -> ty
+ | Expr.Val(vref, _, _) -> vref.Type
+ | Expr.Sequential(a, b, k, _) ->
+ tyOfExpr
+ g
+ (match k with
+ | NormalSeq -> b
+ | ThenDoSeq -> a)
+ | Expr.Lambda(_, _, _, vs, _, _, bodyTy) -> mkFunTy g (mkRefTupledVarsTy g vs) bodyTy
+ | Expr.TyLambda(_, tyvs, _, _, bodyTy) -> (tyvs +-> bodyTy)
+ | Expr.Let(_, e, _, _)
+ | Expr.TyChoose(_, e, _)
+ | Expr.Link { contents = e }
+ | Expr.DebugPoint(_, e)
+ | Expr.StaticOptimization(_, _, e, _)
+ | Expr.LetRec(_, e, _, _) -> tyOfExpr g e
+ | Expr.Op(op, tinst, _, _) ->
+ match op with
+ | TOp.Coerce ->
+ (match tinst with
+ | [ toTy; _fromTy ] -> toTy
+ | _ -> failwith "bad TOp.Coerce node")
+ | TOp.ILCall(_, _, _, _, _, _, _, _, _, _, retTypes)
+ | TOp.ILAsm(_, retTypes) ->
+ (match retTypes with
+ | [ h ] -> h
+ | _ -> g.unit_ty)
+ | TOp.UnionCase uc -> actualResultTyOfUnionCase tinst uc
+ | TOp.UnionCaseProof uc -> mkProvenUnionCaseTy uc tinst
+ | TOp.Recd(_, tcref) -> mkWoNullAppTy tcref tinst
+ | TOp.ExnConstr _ -> g.exn_ty
+ | TOp.Bytes _ -> mkByteArrayTy g
+ | TOp.UInt16s _ -> mkArrayType g g.uint16_ty
+ | TOp.AnonRecdGet(_, i) -> List.item i tinst
+ | TOp.TupleFieldGet(_, i) -> List.item i tinst
+ | TOp.Tuple tupInfo -> mkAnyTupledTy g tupInfo tinst
+ | TOp.AnonRecd anonInfo -> mkAnyAnonRecdTy g anonInfo tinst
+ | TOp.IntegerForLoop _
+ | TOp.While _ -> g.unit_ty
+ | TOp.Array ->
+ (match tinst with
+ | [ ty ] -> mkArrayType g ty
+ | _ -> failwith "bad TOp.Array node")
+ | TOp.TryWith _
+ | TOp.TryFinally _ ->
+ (match tinst with
+ | [ ty ] -> ty
+ | _ -> failwith "bad TOp_try node")
+ | TOp.ValFieldGetAddr(fref, readonly) -> mkByrefTyWithFlag g readonly (actualTyOfRecdFieldRef fref tinst)
+ | TOp.ValFieldGet fref -> actualTyOfRecdFieldRef fref tinst
+ | TOp.ValFieldSet _
+ | TOp.UnionCaseFieldSet _
+ | TOp.ExnFieldSet _
+ | TOp.LValueOp((LSet | LByrefSet), _) -> g.unit_ty
+ | TOp.UnionCaseTagGet _ -> g.int_ty
+ | TOp.UnionCaseFieldGetAddr(cref, j, readonly) ->
+ mkByrefTyWithFlag g readonly (actualTyOfRecdField (mkTyconRefInst cref.TyconRef tinst) (cref.FieldByIndex j))
+ | TOp.UnionCaseFieldGet(cref, j) -> actualTyOfRecdField (mkTyconRefInst cref.TyconRef tinst) (cref.FieldByIndex j)
+ | TOp.ExnFieldGet(ecref, j) -> recdFieldTyOfExnDefRefByIdx ecref j
+ | TOp.LValueOp(LByrefGet, v) -> destByrefTy g v.Type
+ | TOp.LValueOp(LAddrOf readonly, v) -> mkByrefTyWithFlag g readonly v.Type
+ | TOp.RefAddrGet readonly ->
+ (match tinst with
+ | [ ty ] -> mkByrefTyWithFlag g readonly ty
+ | _ -> failwith "bad TOp.RefAddrGet node")
+ | TOp.TraitCall traitInfo -> traitInfo.GetReturnType(g)
+ | TOp.Reraise ->
+ (match tinst with
+ | [ rtn_ty ] -> rtn_ty
+ | _ -> failwith "bad TOp.Reraise node")
+ | TOp.Goto _
+ | TOp.Label _
+ | TOp.Return ->
+ //assert false
+ //errorR(InternalError("unexpected goto/label/return in tyOfExpr", m))
+ // It doesn't matter what type we return here. This is only used in free variable analysis in the code generator
+ g.unit_ty
+ | Expr.WitnessArg(traitInfo, _m) ->
+ let witnessInfo = traitInfo.GetWitnessInfo()
+ GenWitnessTy g witnessInfo
+
+ //--------------------------------------------------------------------------
+ // Decision tree reduction
+ //--------------------------------------------------------------------------
+
+ let rec accTargetsOfDecisionTree tree acc =
+ match tree with
+ | TDSwitch(_, cases, dflt, _) ->
+ List.foldBack
+ (fun (c: DecisionTreeCase) -> accTargetsOfDecisionTree c.CaseTree)
+ cases
+ (Option.foldBack accTargetsOfDecisionTree dflt acc)
+ | TDSuccess(_, i) -> i :: acc
+ | TDBind(_, rest) -> accTargetsOfDecisionTree rest acc
+
+ let rec mapTargetsOfDecisionTree f tree =
+ match tree with
+ | TDSwitch(e, cases, dflt, m) ->
+ let casesR = cases |> List.map (mapTargetsOfDecisionTreeCase f)
+ let dfltR = Option.map (mapTargetsOfDecisionTree f) dflt
+ TDSwitch(e, casesR, dfltR, m)
+ | TDSuccess(es, i) -> TDSuccess(es, f i)
+ | TDBind(bind, rest) -> TDBind(bind, mapTargetsOfDecisionTree f rest)
+
+ and mapTargetsOfDecisionTreeCase f (TCase(x, t)) = TCase(x, mapTargetsOfDecisionTree f t)
+
+ // Dead target elimination
+ let eliminateDeadTargetsFromMatch tree (targets: _[]) =
+ let used = accTargetsOfDecisionTree tree [] |> ListSet.setify (=) |> Array.ofList
+
+ if used.Length < targets.Length then
+ Array.sortInPlace used
+ let ntargets = targets.Length
+
+ let treeR =
+ let remap = Array.create ntargets -1
+ Array.iteri (fun i tgn -> remap[tgn] <- i) used
+
+ tree
+ |> mapTargetsOfDecisionTree (fun tgn ->
+ if remap[tgn] = -1 then
+ failwith "eliminateDeadTargetsFromMatch: failure while eliminating unused targets"
+
+ remap[tgn])
+
+ let targetsR = Array.map (Array.get targets) used
+ treeR, targetsR
+ else
+ tree, targets
+
+ let rec targetOfSuccessDecisionTree tree =
+ match tree with
+ | TDSwitch _ -> None
+ | TDSuccess(_, i) -> Some i
+ | TDBind(_, t) -> targetOfSuccessDecisionTree t
+
+ /// Check a decision tree only has bindings that immediately cover a 'Success'
+ let rec decisionTreeHasNonTrivialBindings tree =
+ match tree with
+ | TDSwitch(_, cases, dflt, _) ->
+ cases |> List.exists (fun c -> decisionTreeHasNonTrivialBindings c.CaseTree)
+ || dflt |> Option.exists decisionTreeHasNonTrivialBindings
+ | TDSuccess _ -> false
+ | TDBind(_, t) -> Option.isNone (targetOfSuccessDecisionTree t)
+
+ // If a target has assignments and can only be reached through one
+ // branch (i.e. is "linear"), then transfer the assignments to the r.h.s. to be a "let".
+ let foldLinearBindingTargetsOfMatch tree (targets: _[]) =
+
+ // Don't do this when there are any bindings in the tree except where those bindings immediately cover a success node
+ // since the variables would be extruded from their scope.
+ if decisionTreeHasNonTrivialBindings tree then
+ tree, targets
+
+ else
+ let branchesToTargets = Array.create targets.Length []
+ // Build a map showing how each target might be reached
+ let rec accumulateTipsOfDecisionTree accBinds tree =
+ match tree with
+ | TDSwitch(_, cases, dflt, _) ->
+ assert (isNil accBinds) // No switches under bindings
+
+ for edge in cases do
+ accumulateTipsOfDecisionTree accBinds edge.CaseTree
+
+ match dflt with
+ | None -> ()
+ | Some tree -> accumulateTipsOfDecisionTree accBinds tree
+ | TDSuccess(es, i) -> branchesToTargets[i] <- (List.rev accBinds, es) :: branchesToTargets[i]
+ | TDBind(bind, rest) -> accumulateTipsOfDecisionTree (bind :: accBinds) rest
+
+ // Compute the targets that can only be reached one way
+ accumulateTipsOfDecisionTree [] tree
+
+ let isLinearTarget bs =
+ match bs with
+ | [ _ ] -> true
+ | _ -> false
+
+ let isLinearTgtIdx i = isLinearTarget branchesToTargets[i]
+ let getLinearTgtIdx i = branchesToTargets[i].Head
+ let hasLinearTgtIdx = branchesToTargets |> Array.exists isLinearTarget
+
+ if not hasLinearTgtIdx then
+
+ tree, targets
+
+ else
+
+ /// rebuild the decision tree, replacing 'bind-then-success' decision trees by TDSuccess nodes that just go to the target
+ let rec rebuildDecisionTree tree =
+
+ // Check if this is a bind-then-success tree
+ match targetOfSuccessDecisionTree tree with
+ | Some i when isLinearTgtIdx i -> TDSuccess([], i)
+ | _ ->
+ match tree with
+ | TDSwitch(e, cases, dflt, m) ->
+ let casesR = List.map rebuildDecisionTreeEdge cases
+ let dfltR = Option.map rebuildDecisionTree dflt
+ TDSwitch(e, casesR, dfltR, m)
+ | TDSuccess _ -> tree
+ | TDBind _ -> tree
+
+ and rebuildDecisionTreeEdge (TCase(x, t)) = TCase(x, rebuildDecisionTree t)
+
+ let treeR = rebuildDecisionTree tree
+
+ /// rebuild the targets, replacing linear targets by ones that include all the 'let' bindings from the source
+ let targetsR =
+ targets
+ |> Array.mapi (fun i (TTarget(vs, exprTarget, _) as tg) ->
+ if isLinearTgtIdx i then
+ let binds, es = getLinearTgtIdx i
+ // The value bindings are moved to become part of the target.
+ // Hence the expressions in the value bindings can be remarked with the range of the target.
+ let mTarget = exprTarget.Range
+ let es = es |> List.map (remarkExpr mTarget)
+ // These are non-sticky - any sequence point for 'exprTarget' goes on 'exprTarget' _after_ the bindings have been evaluated
+ TTarget(List.empty, mkLetsBind mTarget binds (mkInvisibleLetsFromBindings mTarget vs es exprTarget), None)
+ else
+ tg)
+
+ treeR, targetsR
+
+ // Simplify a little as we go, including dead target elimination
+ let simplifyTrivialMatch spBind mExpr mMatch ty tree (targets: _[]) =
+ match tree with
+ | TDSuccess(es, n) ->
+ if n >= targets.Length then
+ failwith "simplifyTrivialMatch: target out of range"
+
+ let (TTarget(vs, rhs, _)) = targets[n]
+
+ if vs.Length <> es.Length then
+ failwith (
+ "simplifyTrivialMatch: invalid argument, n = "
+ + string n
+ + ", #targets = "
+ + string targets.Length
+ )
+
+ // These are non-sticky - any sequence point for 'rhs' goes on 'rhs' _after_ the bindings have been made
+ let res = mkInvisibleLetsFromBindings rhs.Range vs es rhs
+
+ // Incorporate spBind as a note if present
+ let res =
+ match spBind with
+ | DebugPointAtBinding.Yes dp -> Expr.DebugPoint(DebugPointAtLeafExpr.Yes dp, res)
+ | _ -> res
+
+ res
+ | _ -> primMkMatch (spBind, mExpr, tree, targets, mMatch, ty)
+
+ // Simplify a little as we go, including dead target elimination
+ let mkAndSimplifyMatch spBind mExpr mMatch ty tree targets =
+ let targets = Array.ofList targets
+
+ match tree with
+ | TDSuccess _ -> simplifyTrivialMatch spBind mExpr mMatch ty tree targets
+ | _ ->
+ let tree, targets = eliminateDeadTargetsFromMatch tree targets
+ let tree, targets = foldLinearBindingTargetsOfMatch tree targets
+ simplifyTrivialMatch spBind mExpr mMatch ty tree targets
+
+ []
+ let (|WhileExpr|_|) expr =
+ match expr with
+ | Expr.Op(TOp.While(sp1, sp2),
+ _,
+ [ Expr.Lambda(_, _, _, [ _gv ], guardExpr, _, _); Expr.Lambda(_, _, _, [ _bv ], bodyExpr, _, _) ],
+ m) -> ValueSome(sp1, sp2, guardExpr, bodyExpr, m)
+ | _ -> ValueNone
+
+ []
+ let (|TryFinallyExpr|_|) expr =
+ match expr with
+ | Expr.Op(TOp.TryFinally(sp1, sp2), [ ty ], [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ], m) ->
+ ValueSome(sp1, sp2, ty, e1, e2, m)
+ | _ -> ValueNone
+
+ []
+ let (|IntegerForLoopExpr|_|) expr =
+ match expr with
+ | Expr.Op(TOp.IntegerForLoop(sp1, sp2, style),
+ _,
+ [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _); Expr.Lambda(_, _, _, [ v ], e3, _, _) ],
+ m) -> ValueSome(sp1, sp2, style, e1, e2, v, e3, m)
+ | _ -> ValueNone
+
+ []
+ let (|TryWithExpr|_|) expr =
+ match expr with
+ | Expr.Op(TOp.TryWith(spTry, spWith),
+ [ resTy ],
+ [ Expr.Lambda(_, _, _, [ _ ], bodyExpr, _, _)
+ Expr.Lambda(_, _, _, [ filterVar ], filterExpr, _, _)
+ Expr.Lambda(_, _, _, [ handlerVar ], handlerExpr, _, _) ],
+ m) -> ValueSome(spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m)
+ | _ -> ValueNone
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi
new file mode 100644
index 0000000000..5372d2a251
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi
@@ -0,0 +1,310 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// TypedTreeOps.Remapping: signature operations, expression free variables, expression remapping, and expression shape queries.
+namespace FSharp.Compiler.TypedTreeOps
+
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+
+[]
+module internal SignatureOps =
+
+ /// Wrap one module or namespace definition in a 'module M = ..' outer wrapper
+ val wrapModuleOrNamespaceType: Ident -> CompilationPath -> ModuleOrNamespaceType -> ModuleOrNamespace
+
+ /// Wrap one module or namespace definition in a 'namespace N' outer wrapper
+ val wrapModuleOrNamespaceTypeInNamespace:
+ Ident -> CompilationPath -> ModuleOrNamespaceType -> ModuleOrNamespaceType * ModuleOrNamespace
+
+ /// Wrap one module or namespace implementation in a 'namespace N' outer wrapper
+ val wrapModuleOrNamespaceContentsInNamespace:
+ isModule: bool ->
+ id: Ident ->
+ cpath: CompilationPath ->
+ mexpr: ModuleOrNamespaceContents ->
+ ModuleOrNamespaceContents
+
+ /// The remapping that corresponds to a module meeting its signature
+ /// and also report the set of tycons, tycon representations and values hidden in the process.
+ type SignatureRepackageInfo =
+ {
+ /// The list of corresponding values
+ RepackagedVals: (ValRef * ValRef) list
+
+ /// The list of corresponding modules, namespaces and type definitions
+ RepackagedEntities: (TyconRef * TyconRef) list
+ }
+
+ /// The empty table
+ static member Empty: SignatureRepackageInfo
+
+ /// A set of tables summarizing the items hidden by a signature
+ type SignatureHidingInfo =
+ { HiddenTycons: Zset
+ HiddenTyconReprs: Zset
+ HiddenVals: Zset
+ HiddenRecdFields: Zset
+ HiddenUnionCases: Zset }
+
+ /// The empty table representing no hiding
+ static member Empty: SignatureHidingInfo
+
+ /// Compute the remapping information implied by a signature being inferred for a particular implementation
+ val ComputeRemappingFromImplementationToSignature:
+ TcGlobals -> ModuleOrNamespaceContents -> ModuleOrNamespaceType -> SignatureRepackageInfo * SignatureHidingInfo
+
+ /// Compute the remapping information implied by an explicit signature being given for an inferred signature
+ val ComputeRemappingFromInferredSignatureToExplicitSignature:
+ TcGlobals -> ModuleOrNamespaceType -> ModuleOrNamespaceType -> SignatureRepackageInfo * SignatureHidingInfo
+
+ /// Compute the hiding information that corresponds to the hiding applied at an assembly boundary
+ val ComputeSignatureHidingInfoAtAssemblyBoundary:
+ ModuleOrNamespaceType -> SignatureHidingInfo -> SignatureHidingInfo
+
+ /// Compute the hiding information that corresponds to the hiding applied at an assembly boundary
+ val ComputeImplementationHidingInfoAtAssemblyBoundary:
+ ModuleOrNamespaceContents -> SignatureHidingInfo -> SignatureHidingInfo
+
+ val mkRepackageRemapping: SignatureRepackageInfo -> Remap
+
+ val addValRemap: Val -> Val -> Remap -> Remap
+
+ val valLinkageAEquiv: TcGlobals -> TypeEquivEnv -> Val -> Val -> bool
+
+ val abstractSlotValsOfTycons: Tycon list -> Val list
+
+ /// Get the value including fsi remapping
+ val DoRemapTycon: (Remap * SignatureHidingInfo) list -> Tycon -> Tycon
+
+ /// Get the value including fsi remapping
+ val DoRemapVal: (Remap * SignatureHidingInfo) list -> Val -> Val
+
+ /// Determine if a type definition is hidden by a signature
+ val IsHiddenTycon: (Remap * SignatureHidingInfo) list -> Tycon -> bool
+
+ /// Determine if the representation of a type definition is hidden by a signature
+ val IsHiddenTyconRepr: (Remap * SignatureHidingInfo) list -> Tycon -> bool
+
+ /// Determine if a member, function or value is hidden by a signature
+ val IsHiddenVal: (Remap * SignatureHidingInfo) list -> Val -> bool
+
+ /// Determine if a record field is hidden by a signature
+ val IsHiddenRecdField: (Remap * SignatureHidingInfo) list -> RecdFieldRef -> bool
+
+ /// Fold over all the value and member definitions in a module or namespace type
+ val foldModuleOrNamespaceTy: (Entity -> 'T -> 'T) -> (Val -> 'T -> 'T) -> ModuleOrNamespaceType -> 'T -> 'T
+
+ /// Collect all the values and member definitions in a module or namespace type
+ val allValsOfModuleOrNamespaceTy: ModuleOrNamespaceType -> Val list
+
+ /// Collect all the entities in a module or namespace type
+ val allEntitiesOfModuleOrNamespaceTy: ModuleOrNamespaceType -> Entity list
+
+ /// Check if a set of free type variables are all public
+ val freeTyvarsAllPublic: FreeTyvars -> bool
+
+ /// Check if a set of free variables are all public
+ val freeVarsAllPublic: FreeVars -> bool
+
+ val CombineCcuContentFragments: ModuleOrNamespaceType list -> ModuleOrNamespaceType
+
+ val MakeExportRemapping: CcuThunk -> ModuleOrNamespace -> Remap
+
+ /// Updates the IsPrefixDisplay to false for the Microsoft.FSharp.Collections.seq`1 entity
+ val updateSeqTypeIsPrefix: fsharpCoreMSpec: ModuleOrNamespace -> unit
+
+ /// Matches a ModuleOrNamespaceContents that is empty from a signature printing point of view.
+ /// Signatures printed via the typed tree in NicePrint don't print TMDefOpens or TMDefDo.
+ /// This will match anything that does not have any types or bindings.
+ []
+ val (|EmptyModuleOrNamespaces|_|):
+ moduleOrNamespaceContents: ModuleOrNamespaceContents -> ModuleOrNamespace list voption
+
+[]
+module internal ExprFreeVars =
+
+ []
+ val (|LinearMatchExpr|_|):
+ Expr -> (DebugPointAtBinding * range * DecisionTree * DecisionTreeTarget * Expr * range * TType) voption
+
+ val rebuildLinearMatchExpr:
+ DebugPointAtBinding * range * DecisionTree * DecisionTreeTarget * Expr * range * TType -> Expr
+
+ []
+ val (|LinearOpExpr|_|): Expr -> (TOp * TypeInst * Expr list * Expr * range) voption
+
+ val rebuildLinearOpExpr: TOp * TypeInst * Expr list * Expr * range -> Expr
+
+ val emptyFreeVars: FreeVars
+
+ val unionFreeVars: FreeVars -> FreeVars -> FreeVars
+
+ val accFreeInTargets: FreeVarOptions -> DecisionTreeTarget array -> FreeVars -> FreeVars
+
+ val accFreeInExprs: FreeVarOptions -> Exprs -> FreeVars -> FreeVars
+
+ val accFreeInSwitchCases: FreeVarOptions -> DecisionTreeCase list -> DecisionTree option -> FreeVars -> FreeVars
+
+ val accFreeInDecisionTree: FreeVarOptions -> DecisionTree -> FreeVars -> FreeVars
+
+ /// Get the free variables in a module definition.
+ val freeInModuleOrNamespace: FreeVarOptions -> ModuleOrNamespaceContents -> FreeVars
+
+ /// Get the free variables in an expression with accumulator
+ val accFreeInExpr: FreeVarOptions -> Expr -> FreeVars -> FreeVars
+
+ /// Get the free variables in an expression.
+ val freeInExpr: FreeVarOptions -> Expr -> FreeVars
+
+ /// Get the free variables in the right hand side of a binding.
+ val freeInBindingRhs: FreeVarOptions -> Binding -> FreeVars
+
+[]
+module internal ExprRemapping =
+
+ /// Given a (curried) lambda expression, pull off its arguments
+ val stripTopLambda: Expr * TType -> Typars * Val list list * Expr * TType
+
+ /// A flag to govern whether ValReprInfo inference should be type-directed or syntax-directed when
+ /// inferring from a lambda expression.
+ []
+ type AllowTypeDirectedDetupling =
+ | Yes
+ | No
+
+ /// Given a lambda expression, extract the ValReprInfo for its arguments and other details
+ val InferValReprInfoOfExpr:
+ TcGlobals -> AllowTypeDirectedDetupling -> TType -> Attribs list list -> Attribs -> Expr -> ValReprInfo
+
+ /// Given a lambda binding, extract the ValReprInfo for its arguments and other details
+ val InferValReprInfoOfBinding: TcGlobals -> AllowTypeDirectedDetupling -> Val -> Expr -> ValReprInfo
+
+ //---------------------------------------------------------------------------
+ // Resolve static optimizations
+ //-------------------------------------------------------------------------
+
+ type StaticOptimizationAnswer =
+ | Yes = 1y
+ | No = -1y
+ | Unknown = 0y
+
+ val DecideStaticOptimizations:
+ TcGlobals -> StaticOptimization list -> canDecideTyparEqn: bool -> StaticOptimizationAnswer
+
+ /// Indicate what should happen to value definitions when copying expressions
+ type ValCopyFlag =
+ | CloneAll
+ | CloneAllAndMarkExprValsAsCompilerGenerated
+
+ /// OnlyCloneExprVals is a nasty setting to reuse the cloning logic in a mode where all
+ /// Tycon and "module/member" Val objects keep their identity, but the Val objects for all Expr bindings
+ /// are cloned. This is used to 'fixup' the TAST created by tlr.fs
+ ///
+ /// This is a fragile mode of use. It's not really clear why TLR needs to create a "bad" expression tree that
+ /// reuses Val objects as multiple value bindings, and its been the cause of several subtle bugs.
+ | OnlyCloneExprVals
+
+ /// Remap an expression using the given remapping substitution
+ val remapExpr: TcGlobals -> ValCopyFlag -> Remap -> Expr -> Expr
+
+ /// Remap an attribute using the given remapping substitution
+ val remapAttrib: TcGlobals -> Remap -> Attrib -> Attrib
+
+ /// Remap a (possible generic) type using the given remapping substitution
+ val remapPossibleForallTy: TcGlobals -> Remap -> TType -> TType
+
+ /// Copy an entire module or namespace type using the given copying flags
+ val copyModuleOrNamespaceType: TcGlobals -> ValCopyFlag -> ModuleOrNamespaceType -> ModuleOrNamespaceType
+
+ /// Copy an entire expression using the given copying flags
+ val copyExpr: TcGlobals -> ValCopyFlag -> Expr -> Expr
+
+ /// Copy an entire implementation file using the given copying flags
+ val copyImplFile: TcGlobals -> ValCopyFlag -> CheckedImplFile -> CheckedImplFile
+
+ /// Instantiate the generic type parameters in an expression, building a new one
+ val instExpr: TcGlobals -> TyparInstantiation -> Expr -> Expr
+
+ val allValsOfModDef: ModuleOrNamespaceContents -> seq
+
+ val allTopLevelValsOfModDef: ModuleOrNamespaceContents -> seq
+
+ type RemapContext
+
+ val mkRemapContext: TcGlobals -> StackGuard -> RemapContext
+
+ val tryStripLambdaN: int -> Expr -> (Val list list * Expr) option
+
+ val tmenvCopyRemapAndBindTypars: (Attribs -> Attribs) -> Remap -> Typars -> Typars * Remap
+
+ val remapAttribs: RemapContext -> Remap -> Attribs -> Attribs
+
+ val remapValData: RemapContext -> Remap -> ValData -> ValData
+
+ val mapImmediateValsAndTycons: (Entity -> Entity) -> (Val -> Val) -> ModuleOrNamespaceType -> ModuleOrNamespaceType
+
+ val remapTyconRepr: RemapContext -> Remap -> TyconRepresentation -> TyconRepresentation
+
+ val remapTyconAug: Remap -> TyconAugmentation -> TyconAugmentation
+
+ val remapTyconExnInfo: RemapContext -> Remap -> ExceptionInfo -> ExceptionInfo
+
+[]
+module internal ExprAnalysis =
+
+ /// Adjust marks in expressions, replacing all marks by the given mark.
+ /// Used when inlining.
+ val remarkExpr: range -> Expr -> Expr
+
+ val isRecdOrUnionOrStructTyconRefDefinitelyMutable: TyconRef -> bool
+
+ val isUnionCaseRefDefinitelyMutable: UnionCaseRef -> bool
+
+ val isExnDefinitelyMutable: TyconRef -> bool
+
+ val isUnionCaseFieldMutable: TcGlobals -> UnionCaseRef -> int -> bool
+
+ val isExnFieldMutable: TyconRef -> int -> bool
+
+ val GenWitnessArgTys: TcGlobals -> TraitWitnessInfo -> TType list list
+
+ val GenWitnessTys: TcGlobals -> TraitWitnessInfos -> TType list
+
+ val GenWitnessTy: TcGlobals -> TraitWitnessInfo -> TType
+
+ /// Compute the type of an expression from the expression itself
+ val tyOfExpr: TcGlobals -> Expr -> TType
+
+ /// Accumulate the targets actually used in a decision graph (for reporting warnings)
+ val accTargetsOfDecisionTree: DecisionTree -> int list -> int list
+
+ /// Make a 'match' expression applying some peep-hole optimizations along the way, e.g to
+ /// pre-decide the branch taken at compile-time.
+ val mkAndSimplifyMatch:
+ DebugPointAtBinding -> range -> range -> TType -> DecisionTree -> DecisionTreeTarget list -> Expr
+
+ /// Recognise a while expression
+ []
+ val (|WhileExpr|_|): Expr -> (DebugPointAtWhile * SpecialWhileLoopMarker * Expr * Expr * range) voption
+
+ /// Recognise an integer for-loop expression
+ []
+ val (|IntegerForLoopExpr|_|):
+ Expr -> (DebugPointAtFor * DebugPointAtInOrTo * ForLoopStyle * Expr * Expr * Val * Expr * range) voption
+
+ /// Recognise a try-with expression
+ []
+ val (|TryWithExpr|_|):
+ Expr -> (DebugPointAtTry * DebugPointAtWith * TType * Expr * Val * Expr * Val * Expr * range) voption
+
+ /// Recognise a try-finally expression
+ []
+ val (|TryFinallyExpr|_|): Expr -> (DebugPointAtTry * DebugPointAtFinally * TType * Expr * Expr * range) voption
diff --git a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs
new file mode 100644
index 0000000000..d950380002
--- /dev/null
+++ b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs
@@ -0,0 +1,3017 @@
+// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
+
+/// Defines derived expression manipulation and construction functions.
+namespace FSharp.Compiler.TypedTreeOps
+
+open System
+open System.CodeDom.Compiler
+open System.Collections.Generic
+open System.Collections.Immutable
+open Internal.Utilities
+open Internal.Utilities.Collections
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
+open Internal.Utilities.Rational
+
+open FSharp.Compiler
+open FSharp.Compiler.IO
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.CompilerGlobalState
+open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Features
+open FSharp.Compiler.Syntax
+open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.SyntaxTreeOps
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.Text
+open FSharp.Compiler.Text.Range
+open FSharp.Compiler.Text.Layout
+open FSharp.Compiler.Text.LayoutRender
+open FSharp.Compiler.Text.TaggedText
+open FSharp.Compiler.Xml
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeBasics
+#if !NO_TYPEPROVIDERS
+open FSharp.Compiler.TypeProviders
+#endif
+
+[]
+module internal XmlDocSignatures =
+
+ let commaEncs strs = String.concat "," strs
+ let angleEnc str = "{" + str + "}"
+
+ let ticksAndArgCountTextOfTyconRef (tcref: TyconRef) =
+ let path = Array.toList (fullMangledPathToTyconRef tcref) @ [ tcref.CompiledName ]
+ textOfPath path
+
+ let typarEnc (_g: TcGlobals) (gtpsType, gtpsMethod) typar =
+ match List.tryFindIndex (typarEq typar) gtpsType with
+ | Some idx -> "`" + string idx
+ | None ->
+ match List.tryFindIndex (typarEq typar) gtpsMethod with
+ | Some idx -> "``" + string idx
+ | None ->
+ warning (InternalError("Typar not found during XmlDoc generation", typar.Range))
+ "``0"
+
+ let rec typeEnc g (gtpsType, gtpsMethod) ty =
+ let stripped = stripTyEqnsAndMeasureEqns g ty
+
+ match stripped with
+ | TType_forall _ -> "Microsoft.FSharp.Core.FSharpTypeFunc"
+
+ | _ when isByrefTy g ty ->
+ let ety = destByrefTy g ty
+ typeEnc g (gtpsType, gtpsMethod) ety + "@"
+
+ | _ when isNativePtrTy g ty ->
+ let ety = destNativePtrTy g ty
+ typeEnc g (gtpsType, gtpsMethod) ety + "*"
+
+ | TType_app(_, _, _nullness) when isArrayTy g ty ->
+ let tcref, tinst = destAppTy g ty
+ let rank = rankOfArrayTyconRef g tcref
+ let arraySuffix = "[" + String.concat ", " (List.replicate (rank - 1) "0:") + "]"
+ typeEnc g (gtpsType, gtpsMethod) (List.head tinst) + arraySuffix
+
+ | TType_ucase(_, tinst)
+ | TType_app(_, tinst, _) ->
+ let tyName =
+ let ty = stripTyEqnsAndMeasureEqns g ty
+
+ match ty with
+ | TType_app(tcref, _tinst, _nullness) ->
+ // Generic type names are (name + "`" + digits) where name does not contain "`".
+ // In XML doc, when used in type instances, these do not use the ticks.
+ let path = Array.toList (fullMangledPathToTyconRef tcref) @ [ tcref.CompiledName ]
+ textOfPath (List.map DemangleGenericTypeName path)
+ | _ ->
+ assert false
+ failwith "impossible"
+
+ tyName + tyargsEnc g (gtpsType, gtpsMethod) tinst
+
+ | TType_anon(anonInfo, tinst) -> sprintf "%s%s" anonInfo.ILTypeRef.FullName (tyargsEnc g (gtpsType, gtpsMethod) tinst)
+
+ | TType_tuple(tupInfo, tys) ->
+ if evalTupInfoIsStruct tupInfo then
+ sprintf "System.ValueTuple%s" (tyargsEnc g (gtpsType, gtpsMethod) tys)
+ else
+ sprintf "System.Tuple%s" (tyargsEnc g (gtpsType, gtpsMethod) tys)
+
+ | TType_fun(domainTy, rangeTy, _nullness) ->
+ "Microsoft.FSharp.Core.FSharpFunc"
+ + tyargsEnc g (gtpsType, gtpsMethod) [ domainTy; rangeTy ]
+
+ | TType_var(typar, _nullness) -> typarEnc g (gtpsType, gtpsMethod) typar
+
+ | TType_measure _ -> "?"
+
+ and tyargsEnc g (gtpsType, gtpsMethod) args =
+ match args with
+ | [] -> ""
+ | [ a ] when
+ (match (stripTyEqns g a) with
+ | TType_measure _ -> true
+ | _ -> false)
+ ->
+ "" // float should appear as just "float" in the generated .XML xmldoc file
+ | _ -> angleEnc (commaEncs (List.map (typeEnc g (gtpsType, gtpsMethod)) args))
+
+ let XmlDocArgsEnc g (gtpsType, gtpsMethod) argTys =
+ if isNil argTys then
+ ""
+ else
+ "("
+ + String.concat "," (List.map (typeEnc g (gtpsType, gtpsMethod)) argTys)
+ + ")"
+
+ let buildAccessPath (cp: CompilationPath option) =
+ match cp with
+ | Some cp ->
+ let ap = cp.AccessPath |> List.map fst |> List.toArray
+ String.Join(".", ap)
+ | None -> "Extension Type"
+
+ let prependPath path name =
+ if String.IsNullOrEmpty(path) then
+ name
+ else
+ !!path + "." + name
+
+ let XmlDocSigOfVal g full path (v: Val) =
+ let parentTypars, methTypars, cxs, argInfos, retTy, prefix, path, name =
+
+ // CLEANUP: this is one of several code paths that treat module values and members
+ // separately when really it would be cleaner to make sure GetValReprTypeInFSharpForm, GetMemberTypeInFSharpForm etc.
+ // were lined up so code paths like this could be uniform
+
+ match v.MemberInfo with
+ | Some membInfo when not v.IsExtensionMember ->
+
+ // Methods, Properties etc.
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+
+ let tps, witnessInfos, argInfos, retTy, _ =
+ GetMemberTypeInMemberForm g membInfo.MemberFlags (Option.get v.ValReprInfo) numEnclosingTypars v.Type v.Range
+
+ let prefix, name =
+ match membInfo.MemberFlags.MemberKind with
+ | SynMemberKind.ClassConstructor
+ | SynMemberKind.Constructor -> "M:", "#ctor"
+ | SynMemberKind.Member -> "M:", v.CompiledName g.CompilerGlobalState
+ | SynMemberKind.PropertyGetSet
+ | SynMemberKind.PropertySet
+ | SynMemberKind.PropertyGet ->
+ let prefix =
+ if attribsHaveValFlag g WellKnownValAttributes.CLIEventAttribute v.Attribs then
+ "E:"
+ else
+ "P:"
+
+ prefix, v.PropertyName
+
+ let path =
+ if v.HasDeclaringEntity then
+ prependPath path v.DeclaringEntity.CompiledName
+ else
+ path
+
+ let parentTypars, methTypars =
+ match PartitionValTypars g v with
+ | Some(_, memberParentTypars, memberMethodTypars, _, _) -> memberParentTypars, memberMethodTypars
+ | None -> [], tps
+
+ parentTypars, methTypars, witnessInfos, argInfos, retTy, prefix, path, name
+
+ | _ ->
+ // Regular F# values and extension members
+ let w = arityOfVal v
+ let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
+
+ let tps, witnessInfos, argInfos, retTy, _ =
+ GetValReprTypeInCompiledForm g w numEnclosingTypars v.Type v.Range
+
+ let name = v.CompiledName g.CompilerGlobalState
+ let prefix = if w.NumCurriedArgs = 0 && isNil tps then "P:" else "M:"
+ [], tps, witnessInfos, argInfos, retTy, prefix, path, name
+
+ let witnessArgTys = GenWitnessTys g cxs
+ let argTys = argInfos |> List.concat |> List.map fst
+
+ let argTys =
+ witnessArgTys
+ @ argTys
+ @ (match retTy with
+ | Some t when full -> [ t ]
+ | _ -> [])
+
+ let args = XmlDocArgsEnc g (parentTypars, methTypars) argTys
+ let arity = List.length methTypars
+ let genArity = if arity = 0 then "" else sprintf "``%d" arity
+ prefix + prependPath path name + genArity + args
+
+ let BuildXmlDocSig prefix path = prefix + List.fold prependPath "" path
+
+ // Would like to use "U:", but ParseMemberSignature only accepts C# signatures
+ let XmlDocSigOfUnionCase path = BuildXmlDocSig "T:" path
+
+ let XmlDocSigOfField path = BuildXmlDocSig "F:" path
+
+ let XmlDocSigOfProperty path = BuildXmlDocSig "P:" path
+
+ let XmlDocSigOfTycon path = BuildXmlDocSig "T:" path
+
+ let XmlDocSigOfSubModul path = BuildXmlDocSig "T:" path
+
+ let XmlDocSigOfEntity (eref: EntityRef) =
+ XmlDocSigOfTycon [ (buildAccessPath eref.CompilationPathOpt); eref.Deref.CompiledName ]
+
+ //---------------------------------------------------------------------------
+ // Active pattern name helpers
+ //---------------------------------------------------------------------------
+
+ let TryGetActivePatternInfo (vref: ValRef) =
+ // First is an optimization to prevent calls to string routines
+ let logicalName = vref.LogicalName
+
+ if logicalName.Length = 0 || logicalName[0] <> '|' then
+ None
+ else
+ ActivePatternInfoOfValName vref.DisplayNameCoreMangled vref.Range
+
+ type ActivePatternElemRef with
+ member x.LogicalName =
+ let (APElemRef(_, vref, n, _)) = x
+
+ match TryGetActivePatternInfo vref with
+ | None -> error (InternalError("not an active pattern name", vref.Range))
+ | Some apinfo ->
+ let nms = apinfo.ActiveTags
+
+ if n < 0 || n >= List.length nms then
+ error (InternalError("name_of_apref: index out of range for active pattern reference", vref.Range))
+
+ List.item n nms
+
+ member x.DisplayNameCore = x.LogicalName
+
+ member x.DisplayName = x.LogicalName |> ConvertLogicalNameToDisplayName
+
+ let mkChoiceTyconRef (g: TcGlobals) m n =
+ match n with
+ | 0
+ | 1 -> error (InternalError("mkChoiceTyconRef", m))
+ | 2 -> g.choice2_tcr
+ | 3 -> g.choice3_tcr
+ | 4 -> g.choice4_tcr
+ | 5 -> g.choice5_tcr
+ | 6 -> g.choice6_tcr
+ | 7 -> g.choice7_tcr
+ | _ -> error (Error(FSComp.SR.tastActivePatternsLimitedToSeven (), m))
+
+ let mkChoiceTy (g: TcGlobals) m tinst =
+ match List.length tinst with
+ | 0 -> g.unit_ty
+ | 1 -> List.head tinst
+ | length -> mkWoNullAppTy (mkChoiceTyconRef g m length) tinst
+
+ let mkChoiceCaseRef g m n i =
+ mkUnionCaseRef (mkChoiceTyconRef g m n) ("Choice" + string (i + 1) + "Of" + string n)
+
+ type ActivePatternInfo with
+
+ member x.DisplayNameCoreByIdx idx = x.ActiveTags[idx]
+
+ member x.DisplayNameByIdx idx =
+ x.ActiveTags[idx] |> ConvertLogicalNameToDisplayName
+
+ member apinfo.ResultType g m retTys retKind =
+ let choicety = mkChoiceTy g m retTys
+
+ if apinfo.IsTotal then
+ choicety
+ else
+ match retKind with
+ | ActivePatternReturnKind.RefTypeWrapper -> mkOptionTy g choicety
+ | ActivePatternReturnKind.StructTypeWrapper -> mkValueOptionTy g choicety
+ | ActivePatternReturnKind.Boolean -> g.bool_ty
+
+ member apinfo.OverallType g m argTy retTys retKind =
+ mkFunTy g argTy (apinfo.ResultType g m retTys retKind)
+
+ //---------------------------------------------------------------------------
+ // Active pattern validation
+ //---------------------------------------------------------------------------
+
+ // check if an active pattern takes type parameters only bound by the return types,
+ // not by their argument types.
+ let doesActivePatternHaveFreeTypars g (v: ValRef) =
+ let vty = v.TauType
+ let vtps = v.Typars |> Zset.ofList typarOrder
+
+ if not (isFunTy g v.TauType) then
+ errorR (Error(FSComp.SR.activePatternIdentIsNotFunctionTyped (v.LogicalName), v.Range))
+
+ let argTys, resty = stripFunTy g vty
+
+ let argtps, restps =
+ (freeInTypes CollectTypars argTys).FreeTypars, (freeInType CollectTypars resty).FreeTypars
+ // Error if an active pattern is generic in type variables that only occur in the result Choice<_, ...>.
+ // Note: The test restricts to v.Typars since typars from the closure are considered fixed.
+ not (Zset.isEmpty (Zset.inter (Zset.diff restps argtps) vtps))
+
+[]
+module internal NullnessAnalysis =
+
+ let inline HasConstraint ([] predicate) (tp: Typar) = tp.Constraints |> List.exists predicate
+
+ let inline tryGetTyparTyWithConstraint g ([] predicate) ty =
+ match tryDestTyparTy g ty with
+ | ValueSome tp as x when HasConstraint predicate tp -> x
+ | _ -> ValueNone
+
+ let inline IsTyparTyWithConstraint g ([] predicate) ty =
+ match tryDestTyparTy g ty with
+ | ValueSome tp -> HasConstraint predicate tp
+ | ValueNone -> false
+
+ // Note, isStructTy does not include type parameters with the ': struct' constraint
+ // This predicate is used to detect those type parameters.
+ let IsNonNullableStructTyparTy g ty =
+ ty |> IsTyparTyWithConstraint g _.IsIsNonNullableStruct
+
+ // Note, isRefTy does not include type parameters with the ': not struct' or ': null' constraints
+ // This predicate is used to detect those type parameters.
+ let IsReferenceTyparTy g ty =
+ ty
+ |> IsTyparTyWithConstraint g (fun tc -> tc.IsIsReferenceType || tc.IsSupportsNull)
+
+ let GetTyparTyIfSupportsNull g ty =
+ ty |> tryGetTyparTyWithConstraint g _.IsSupportsNull
+
+ let TypeNullNever g ty =
+ let underlyingTy = stripTyEqnsAndMeasureEqns g ty
+
+ isStructTy g underlyingTy
+ || isByrefTy g underlyingTy
+ || IsNonNullableStructTyparTy g ty
+
+ /// The pre-nullness logic about whether a type admits the use of 'null' as a value.
+ let TypeNullIsExtraValue g (_m: range) ty =
+ if isILReferenceTy g ty || isDelegateTy g ty then
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref ->
+ // Putting AllowNullLiteralAttribute(false) on an IL or provided
+ // type means 'null' can't be used with that type, otherwise it can
+ TyconRefAllowsNull g tcref <> Some false
+ | _ ->
+ // In pre-nullness, other IL reference types (e.g. arrays) always support null
+ true
+ elif TypeNullNever g ty then
+ false
+ else
+ // In F# 4.x, putting AllowNullLiteralAttribute(true) on an F# type means 'null' can be used with that type
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> TyconRefAllowsNull g tcref = Some true
+ | ValueNone ->
+
+ // Consider type parameters
+ (GetTyparTyIfSupportsNull g ty).IsSome
+
+ // Any mention of a type with AllowNullLiteral(true) is considered to be with-null
+ let intrinsicNullnessOfTyconRef g (tcref: TyconRef) =
+ match TyconRefAllowsNull g tcref with
+ | Some true -> g.knownWithNull
+ | _ -> g.knownWithoutNull
+
+ let nullnessOfTy g ty =
+ ty
+ |> stripTyEqns g
+ |> function
+ | TType_app(tcref, _, nullness) ->
+ let nullness2 = intrinsicNullnessOfTyconRef g tcref
+
+ if nullness2 === g.knownWithoutNull then
+ nullness
+ else
+ combineNullness nullness nullness2
+ | TType_fun(_, _, nullness)
+ | TType_var(_, nullness) -> nullness
+ | _ -> g.knownWithoutNull
+
+ let changeWithNullReqTyToVariable g reqTy =
+ let sty = stripTyEqns g reqTy
+
+ match isTyparTy g sty with
+ | false ->
+ match nullnessOfTy g sty with
+ | Nullness.Known NullnessInfo.AmbivalentToNull
+ | Nullness.Known NullnessInfo.WithNull when g.checkNullness -> reqTy |> replaceNullnessOfTy (NewNullnessVar())
+ | _ -> reqTy
+ | true -> reqTy
+
+ /// When calling a null-allowing API, we prefer to infer a without null argument for idiomatic F# code.
+ /// That is, unless caller explicitly marks a value (e.g. coming from a function parameter) as WithNull, it should not be inferred as such.
+ let reqTyForArgumentNullnessInference g actualTy reqTy =
+ // Only change reqd nullness if actualTy is an inference variable
+ match tryDestTyparTy g actualTy with
+ | ValueSome t when t.IsCompilerGenerated && not (t |> HasConstraint _.IsSupportsNull) -> changeWithNullReqTyToVariable g reqTy
+ | _ -> reqTy
+
+ let GetDisallowedNullness (g: TcGlobals) (ty: TType) =
+ if g.checkNullness then
+ let rec hasWithNullAnyWhere ty alreadyWrappedInOuterWithNull =
+ match ty with
+ | TType_var(tp, n) ->
+ let withNull =
+ alreadyWrappedInOuterWithNull
+ || n.TryEvaluate() = (ValueSome NullnessInfo.WithNull)
+
+ match tp.Solution with
+ | None -> []
+ | Some t -> hasWithNullAnyWhere t withNull
+
+ | TType_app(tcr, tinst, _) ->
+ let tyArgs = tinst |> List.collect (fun t -> hasWithNullAnyWhere t false)
+
+ match alreadyWrappedInOuterWithNull, tcr.TypeAbbrev with
+ | true, _ when isStructTyconRef tcr -> ty :: tyArgs
+ | true, _ when tcr.IsMeasureableReprTycon ->
+ match tcr.TypeReprInfo with
+ | TMeasureableRepr realType ->
+ if hasWithNullAnyWhere realType true |> List.isEmpty then
+ []
+ else
+ [ ty ]
+ | _ -> []
+ | true, Some tAbbrev -> (hasWithNullAnyWhere tAbbrev true) @ tyArgs
+ | _ -> tyArgs
+
+ | TType_tuple(_, tupTypes) ->
+ let inner = tupTypes |> List.collect (fun t -> hasWithNullAnyWhere t false)
+ if alreadyWrappedInOuterWithNull then ty :: inner else inner
+
+ | TType_anon(tys = tys) ->
+ let inner = tys |> List.collect (fun t -> hasWithNullAnyWhere t false)
+ if alreadyWrappedInOuterWithNull then ty :: inner else inner
+ | TType_fun(d, r, _) -> (hasWithNullAnyWhere d false) @ (hasWithNullAnyWhere r false)
+
+ | TType_forall _ -> []
+ | TType_ucase _ -> []
+ | TType_measure m ->
+ if alreadyWrappedInOuterWithNull then
+ let measuresInside =
+ ListMeasureVarOccs m
+ |> List.choose (fun x -> x.Solution)
+ |> List.collect (fun x -> hasWithNullAnyWhere x true)
+
+ ty :: measuresInside
+ else
+ []
+
+ hasWithNullAnyWhere ty false
+ else
+ []
+
+ let TypeHasAllowNull (tcref: TyconRef) g m =
+ not tcref.IsStructOrEnumTycon
+ && not (isByrefLikeTyconRef g m tcref)
+ && (TyconRefAllowsNull g tcref = Some true)
+
+ /// The new logic about whether a type admits the use of 'null' as a value.
+ let TypeNullIsExtraValueNew g m ty =
+ let sty = stripTyparEqns ty
+
+ (match tryTcrefOfAppTy g sty with
+ | ValueSome tcref -> TypeHasAllowNull tcref g m
+ | _ -> false)
+ || (match (nullnessOfTy g sty).Evaluate() with
+ | NullnessInfo.AmbivalentToNull -> false
+ | NullnessInfo.WithoutNull -> false
+ | NullnessInfo.WithNull -> true)
+ || (GetTyparTyIfSupportsNull g ty).IsSome
+
+ /// The pre-nullness logic about whether a type uses 'null' as a true representation value
+ let TypeNullIsTrueValue g ty =
+ (match tryTcrefOfAppTy g ty with
+ | ValueSome tcref -> IsUnionTypeWithNullAsTrueValue g tcref.Deref
+ | _ -> false)
+ || isUnitTy g ty
+
+ /// Indicates if unbox(null) is actively rejected at runtime. See nullability RFC. This applies to types that don't have null
+ /// as a valid runtime representation under old compatibility rules.
+ let TypeNullNotLiked g m ty =
+ not (TypeNullIsExtraValue g m ty)
+ && not (TypeNullIsTrueValue g ty)
+ && not (TypeNullNever g ty)
+
+ let rec TypeHasDefaultValueAux isNew g m ty =
+ let ty = stripTyEqnsAndMeasureEqns g ty
+
+ (if isNew then
+ TypeNullIsExtraValueNew g m ty
+ else
+ TypeNullIsExtraValue g m ty)
+ || (isStructTy g ty
+ &&
+ // Is it an F# struct type?
+ (if isFSharpStructTy g ty then
+ let tcref, tinst = destAppTy g ty
+
+ let flds =
+ // Note this includes fields implied by the use of the implicit class construction syntax
+ tcref.AllInstanceFieldsAsList
+ // We can ignore fields with the DefaultValue(false) attribute
+ |> List.filter (fun fld ->
+ not (attribsHaveValFlag g WellKnownValAttributes.DefaultValueAttribute_False fld.FieldAttribs))
+
+ flds
+ |> List.forall (
+ actualTyOfRecdField (mkTyconRefInst tcref tinst)
+ >> TypeHasDefaultValueAux isNew g m
+ )
+
+ // Struct tuple types have a DefaultValue if all their element types have a default value
+ elif isStructTupleTy g ty then
+ destStructTupleTy g ty |> List.forall (TypeHasDefaultValueAux isNew g m)
+
+ // Struct anonymous record types have a DefaultValue if all their element types have a default value
+ elif isStructAnonRecdTy g ty then
+ match tryDestAnonRecdTy g ty with
+ | ValueNone -> true
+ | ValueSome(_, ptys) -> ptys |> List.forall (TypeHasDefaultValueAux isNew g m)
+ else
+ // All nominal struct types defined in other .NET languages have a DefaultValue regardless of their instantiation
+ true))
+ ||
+ // Check for type variables with the ":struct" and "(new : unit -> 'T)" constraints
+ (match ty |> tryGetTyparTyWithConstraint g _.IsIsNonNullableStruct with
+ | ValueSome tp -> tp |> HasConstraint _.IsRequiresDefaultConstructor
+ | ValueNone -> false)
+
+ let TypeHasDefaultValue (g: TcGlobals) m ty = TypeHasDefaultValueAux false g m ty
+
+ let TypeHasDefaultValueNew g m ty = TypeHasDefaultValueAux true g m ty
+
+ let (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|) (ty, g) =
+ let sty = ty |> stripTyEqns g
+
+ if isTyparTy g sty then
+ if (nullnessOfTy g sty).TryEvaluate() = ValueSome NullnessInfo.WithNull then
+ NullableTypar
+ else
+ TyparTy
+ elif isStructTy g sty then
+ StructTy
+ elif TypeNullIsTrueValue g sty then
+ NullTrueValue
+ else
+ match (nullnessOfTy g sty).TryEvaluate() with
+ | ValueSome NullnessInfo.WithNull -> NullableRefType
+ | ValueSome NullnessInfo.WithoutNull -> WithoutNullRefType
+ | _ -> UnresolvedRefType
+
+[]
+module internal TypeTestsAndPatterns =
+
+ /// Determines types that are potentially known to satisfy the 'comparable' constraint and returns
+ /// a set of residual types that must also satisfy the constraint
+ []
+ let (|SpecialComparableHeadType|_|) g ty =
+ if isAnyTupleTy g ty then
+ let _tupInfo, elemTys = destAnyTupleTy g ty
+ ValueSome elemTys
+ elif isAnonRecdTy g ty then
+ match tryDestAnonRecdTy g ty with
+ | ValueNone -> ValueSome []
+ | ValueSome(_anonInfo, elemTys) -> ValueSome elemTys
+ else
+ match tryAppTy g ty with
+ | ValueSome(tcref, tinst) ->
+ if
+ isArrayTyconRef g tcref
+ || tyconRefEq g tcref g.system_UIntPtr_tcref
+ || tyconRefEq g tcref g.system_IntPtr_tcref
+ then
+ ValueSome tinst
+ else
+ ValueNone
+ | _ -> ValueNone
+
+ []
+ let (|SpecialEquatableHeadType|_|) g ty = (|SpecialComparableHeadType|_|) g ty
+
+ []
+ let (|SpecialNotEquatableHeadType|_|) g ty =
+ if isFunTy g ty then ValueSome() else ValueNone
+
+ // Can we use the fast helper for the 'LanguagePrimitives.IntrinsicFunctions.TypeTestGeneric'?
+ let canUseTypeTestFast g ty =
+ not (isTyparTy g ty) && not (TypeNullIsTrueValue g ty)
+
+ // Can we use the fast helper for the 'LanguagePrimitives.IntrinsicFunctions.UnboxGeneric'?
+ let canUseUnboxFast (g: TcGlobals) m ty =
+ if g.checkNullness then
+ match (ty, g) with
+ | TyparTy
+ | WithoutNullRefType
+ | UnresolvedRefType -> false
+ | StructTy
+ | NullTrueValue
+ | NullableRefType
+ | NullableTypar -> true
+ else
+ not (isTyparTy g ty) && not (TypeNullNotLiked g m ty)
+
+ //--------------------------------------------------------------------------
+ // Nullness tests and pokes
+ //--------------------------------------------------------------------------
+
+ // Generates the logical equivalent of
+ // match inp with :? ty as v -> e2[v] | _ -> e3
+ //
+ // No sequence point is generated for this expression form as this function is only
+ // used for compiler-generated code.
+ let mkIsInstConditional g m tgtTy vinputExpr v e2 e3 =
+
+ if canUseTypeTestFast g tgtTy && isRefTy g tgtTy then
+
+ let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m)
+ let tg2 = mbuilder.AddResultTarget(e2)
+ let tg3 = mbuilder.AddResultTarget(e3)
+
+ let dtree =
+ TDSwitch(exprForVal m v, [ TCase(DecisionTreeTest.IsNull, tg3) ], Some tg2, m)
+
+ let expr = mbuilder.Close(dtree, m, tyOfExpr g e2)
+ mkCompGenLet m v (mkIsInst tgtTy vinputExpr m) expr
+
+ else
+ let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m)
+
+ let tg2 =
+ TDSuccess([ mkCallUnbox g m tgtTy vinputExpr ], mbuilder.AddTarget(TTarget([ v ], e2, None)))
+
+ let tg3 = mbuilder.AddResultTarget(e3)
+
+ let dtree =
+ TDSwitch(vinputExpr, [ TCase(DecisionTreeTest.IsInst(tyOfExpr g vinputExpr, tgtTy), tg2) ], Some tg3, m)
+
+ let expr = mbuilder.Close(dtree, m, tyOfExpr g e2)
+ expr
+
+ let isComInteropTy g ty =
+ let tcref = tcrefOfAppTy g ty
+ EntityHasWellKnownAttribute g WellKnownEntityAttributes.ComImportAttribute_True tcref.Deref
+
+ //---------------------------------------------------------------------------
+ // Crack information about an F# object model call
+ //---------------------------------------------------------------------------
+
+ let GetMemberCallInfo g (vref: ValRef, vFlags) =
+ match vref.MemberInfo with
+ | Some membInfo when not vref.IsExtensionMember ->
+ let numEnclTypeArgs = vref.MemberApparentEntity.TyparsNoRange.Length
+
+ let virtualCall =
+ (membInfo.MemberFlags.IsOverrideOrExplicitImpl
+ || membInfo.MemberFlags.IsDispatchSlot)
+ && not membInfo.MemberFlags.IsFinal
+ && (match vFlags with
+ | VSlotDirectCall -> false
+ | _ -> true)
+
+ let isNewObj =
+ (membInfo.MemberFlags.MemberKind = SynMemberKind.Constructor)
+ && (match vFlags with
+ | NormalValUse -> true
+ | _ -> false)
+
+ let isSuperInit =
+ (membInfo.MemberFlags.MemberKind = SynMemberKind.Constructor)
+ && (match vFlags with
+ | CtorValUsedAsSuperInit -> true
+ | _ -> false)
+
+ let isSelfInit =
+ (membInfo.MemberFlags.MemberKind = SynMemberKind.Constructor)
+ && (match vFlags with
+ | CtorValUsedAsSelfInit -> true
+ | _ -> false)
+
+ let isCompiledAsInstance = ValRefIsCompiledAsInstanceMember g vref
+ let takesInstanceArg = isCompiledAsInstance && not isNewObj
+
+ let isPropGet =
+ (membInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGet)
+ && (membInfo.MemberFlags.IsInstance = isCompiledAsInstance)
+
+ let isPropSet =
+ (membInfo.MemberFlags.MemberKind = SynMemberKind.PropertySet)
+ && (membInfo.MemberFlags.IsInstance = isCompiledAsInstance)
+
+ numEnclTypeArgs, virtualCall, isNewObj, isSuperInit, isSelfInit, takesInstanceArg, isPropGet, isPropSet
+ | _ -> 0, false, false, false, false, false, false, false
+
+[]
+module internal Rewriting =
+
+ //---------------------------------------------------------------------------
+ // RewriteExpr: rewrite bottom up with interceptors
+ //---------------------------------------------------------------------------
+
+ [