diff --git a/.fantomasignore b/.fantomasignore index c2677d44fa4..c1eac39b4c5 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -15,10 +15,6 @@ artifacts/ .git/ # Explicitly unformatted implementation -src/Compiler/Checking/AccessibilityLogic.fs -src/Compiler/Checking/AttributeChecking.fs -src/Compiler/Checking/AugmentWithHashCompare.fs -src/Compiler/Checking/CheckBasics.fs src/Compiler/Checking/CheckDeclarations.fs src/Compiler/Checking/Expressions/CheckExpressions.fs src/Compiler/Checking/CheckFormatStrings.fs @@ -40,32 +36,7 @@ src/Compiler/Checking/SignatureConformance.fs src/Compiler/Checking/TypeHierarchy.fs src/Compiler/Checking/TypeRelations.fs -# The following files were formatted, but the "format, --check" loop is not stable. -# Fantomas formats them, but still thinks they need formatting -src/Compiler/Optimize/DetupleArgs.fs -src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs -src/Compiler/Optimize/LowerCalls.fs -src/Compiler/Optimize/LowerComputedCollections.fs -src/Compiler/Optimize/LowerLocalMutables.fs -src/Compiler/Optimize/LowerSequences.fs -src/Compiler/Optimize/LowerStateMachines.fs -src/Compiler/Optimize/Optimizer.fs -src/Compiler/Symbols/Exprs.fs -src/Compiler/Symbols/FSharpDiagnostic.fs -src/Compiler/Symbols/SymbolHelpers.fs -src/Compiler/Symbols/SymbolPatterns.fs -src/Compiler/Symbols/Symbols.fs - -src/Compiler/TypedTree/CompilerGlobalState.fs -src/Compiler/TypedTree/QuotationPickler.fs -src/Compiler/TypedTree/tainted.fs -src/Compiler/TypedTree/TcGlobals.fs -src/Compiler/TypedTree/TypedTree.fs -src/Compiler/TypedTree/TypedTreeBasics.fs -src/Compiler/TypedTree/TypedTreeOps.fs -src/Compiler/TypedTree/TypedTreePickle.fs -src/Compiler/TypedTree/TypeProviders.fs # Explicitly unformatted file that needs more care to get it to format well src/Compiler/SyntaxTree/LexFilter.fs diff --git a/src/Compiler/Checking/AccessibilityLogic.fs b/src/Compiler/Checking/AccessibilityLogic.fs index 6aba2edcb4b..4ba2d70ed1b 100644 --- a/src/Compiler/Checking/AccessibilityLogic.fs +++ b/src/Compiler/Checking/AccessibilityLogic.fs @@ -4,8 +4,8 @@ module internal FSharp.Compiler.AccessibilityLogic open Internal.Utilities.Library -open FSharp.Compiler -open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler +open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Infos open FSharp.Compiler.TcGlobals @@ -20,237 +20,253 @@ open FSharp.Compiler.TypeProviders /// Represents the 'keys' a particular piece of code can use to access other constructs?. [] -type AccessorDomain = - /// cpaths: indicates we have the keys to access any members private to the given paths - /// tyconRefOpt: indicates we have the keys to access any protected members of the super types of 'TyconRef' - | AccessibleFrom of cpaths: CompilationPath list * tyconRefOpt: TyconRef option +type AccessorDomain = + /// cpaths: indicates we have the keys to access any members private to the given paths + /// tyconRefOpt: indicates we have the keys to access any protected members of the super types of 'TyconRef' + | AccessibleFrom of cpaths: CompilationPath list * tyconRefOpt: TyconRef option /// An AccessorDomain which returns public items | AccessibleFromEverywhere /// An AccessorDomain which returns everything but .NET private/internal items. - /// This is used - /// - when solving member trait constraints, which are solved independently of accessibility + /// This is used + /// - when solving member trait constraints, which are solved independently of accessibility /// - for failure paths in error reporting, e.g. to produce an error that an F# item is not accessible /// - an adhoc use in service.fs to look up a delegate signature - | AccessibleFromSomeFSharpCode + | AccessibleFromSomeFSharpCode /// An AccessorDomain which returns all items - | AccessibleFromSomewhere + | AccessibleFromSomewhere // Hashing and comparison is used for the memoization tables keyed by an accessor domain. // It is dependent on a TcGlobals because of the TyconRef in the data structure - static member CustomGetHashCode(ad:AccessorDomain) = - match ad with + static member CustomGetHashCode(ad: AccessorDomain) = + match ad with | AccessibleFrom _ -> 1 | AccessibleFromEverywhere -> 2 - | AccessibleFromSomeFSharpCode -> 3 - | AccessibleFromSomewhere -> 4 - - static member CustomEquals(g:TcGlobals, ad1:AccessorDomain, ad2:AccessorDomain) = - match ad1, ad2 with - | AccessibleFrom(cs1, tc1), AccessibleFrom(cs2, tc2) -> (cs1 = cs2) && (match tc1, tc2 with None, None -> true | Some tc1, Some tc2 -> tyconRefEq g tc1 tc2 | _ -> false) + | AccessibleFromSomeFSharpCode -> 3 + | AccessibleFromSomewhere -> 4 + + static member CustomEquals(g: TcGlobals, ad1: AccessorDomain, ad2: AccessorDomain) = + match ad1, ad2 with + | AccessibleFrom(cs1, tc1), AccessibleFrom(cs2, tc2) -> + (cs1 = cs2) + && (match tc1, tc2 with + | None, None -> true + | Some tc1, Some tc2 -> tyconRefEq g tc1 tc2 + | _ -> false) | AccessibleFromEverywhere, AccessibleFromEverywhere -> true - | AccessibleFromSomeFSharpCode, AccessibleFromSomeFSharpCode -> true - | AccessibleFromSomewhere, AccessibleFromSomewhere -> true + | AccessibleFromSomeFSharpCode, AccessibleFromSomeFSharpCode -> true + | AccessibleFromSomewhere, AccessibleFromSomewhere -> true | _ -> false -/// Indicates if an F# item is accessible -let IsAccessible ad taccess = - match ad with +/// Indicates if an F# item is accessible +let IsAccessible ad taccess = + match ad with | AccessibleFromEverywhere -> canAccessFromEverywhere taccess | AccessibleFromSomeFSharpCode -> canAccessFromSomewhere taccess | AccessibleFromSomewhere -> true - | AccessibleFrom (cpaths, _tcrefViewedFromOption) -> - List.exists (canAccessFrom taccess) cpaths + | AccessibleFrom(cpaths, _tcrefViewedFromOption) -> List.exists (canAccessFrom taccess) cpaths /// Indicates if an IL member is accessible (ignoring its enclosing type) -let private IsILMemberAccessible g amap m (tcrefOfViewedItem : TyconRef) ad access = - match ad with - | AccessibleFromEverywhere -> - access = ILMemberAccess.Public - - | AccessibleFromSomeFSharpCode -> - (access = ILMemberAccess.Public || - access = ILMemberAccess.Family || - access = ILMemberAccess.FamilyOrAssembly) - - | AccessibleFrom (cpaths, tcrefViewedFromOption) -> - - let accessibleByFamily = - ((access = ILMemberAccess.Family || - access = ILMemberAccess.FamilyOrAssembly) && - match tcrefViewedFromOption with - | None -> false - | Some tcrefViewedFrom -> - ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef g tcrefViewedFrom) tcrefOfViewedItem) +let private IsILMemberAccessible g amap m (tcrefOfViewedItem: TyconRef) ad access = + match ad with + | AccessibleFromEverywhere -> access = ILMemberAccess.Public + + | AccessibleFromSomeFSharpCode -> + (access = ILMemberAccess.Public + || access = ILMemberAccess.Family + || access = ILMemberAccess.FamilyOrAssembly) - let accessibleByInternalsVisibleTo = - (access = ILMemberAccess.Assembly || access = ILMemberAccess.FamilyOrAssembly) && - canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath + | AccessibleFrom(cpaths, tcrefViewedFromOption) -> - let accessibleByFamilyAndAssembly = - access = ILMemberAccess.FamilyAndAssembly && - canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath && - match tcrefViewedFromOption with + let accessibleByFamily = + ((access = ILMemberAccess.Family || access = ILMemberAccess.FamilyOrAssembly) + && match tcrefViewedFromOption with | None -> false - | Some tcrefViewedFrom -> - ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef g tcrefViewedFrom) tcrefOfViewedItem + | Some tcrefViewedFrom -> ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef g tcrefViewedFrom) tcrefOfViewedItem) - (access = ILMemberAccess.Public) || accessibleByFamily || accessibleByInternalsVisibleTo || accessibleByFamilyAndAssembly + let accessibleByInternalsVisibleTo = + (access = ILMemberAccess.Assembly || access = ILMemberAccess.FamilyOrAssembly) + && canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath + + let accessibleByFamilyAndAssembly = + access = ILMemberAccess.FamilyAndAssembly + && canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath + && match tcrefViewedFromOption with + | None -> false + | Some tcrefViewedFrom -> ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef g tcrefViewedFrom) tcrefOfViewedItem + + (access = ILMemberAccess.Public) + || accessibleByFamily + || accessibleByInternalsVisibleTo + || accessibleByFamilyAndAssembly + + | AccessibleFromSomewhere -> true - | AccessibleFromSomewhere -> - true - /// Indicates if tdef is accessible. If tdef.Access = ILTypeDefAccess.Nested then encTyconRefOpt s TyconRef of enclosing type /// and visibility of tdef is obtained using member access rules -let private IsILTypeDefAccessible (amap : Import.ImportMap) m ad encTyconRefOpt (tdef: ILTypeDef) = +let private IsILTypeDefAccessible (amap: Import.ImportMap) m ad encTyconRefOpt (tdef: ILTypeDef) = match tdef.Access with | ILTypeDefAccess.Nested nestedAccess -> match encTyconRefOpt with - | None -> assert false; true + | None -> + assert false + true | Some encTyconRef -> IsILMemberAccessible amap.g amap m encTyconRef ad nestedAccess | _ -> - match ad with + match ad with | AccessibleFromSomewhere -> true - | AccessibleFromEverywhere - | AccessibleFromSomeFSharpCode + | AccessibleFromEverywhere + | AccessibleFromSomeFSharpCode | AccessibleFrom _ -> tdef.Access = ILTypeDefAccess.Public /// Indicates if a TyconRef is visible through the AccessibleFrom(cpaths, _). /// Note that InternalsVisibleTo extends those cpaths. -let private IsTyconAccessibleViaVisibleTo ad (tcrefOfViewedItem:TyconRef) = - match ad with - | AccessibleFromEverywhere - | AccessibleFromSomewhere +let private IsTyconAccessibleViaVisibleTo ad (tcrefOfViewedItem: TyconRef) = + match ad with + | AccessibleFromEverywhere + | AccessibleFromSomewhere | AccessibleFromSomeFSharpCode -> false - | AccessibleFrom (cpaths, _tcrefViewedFromOption) -> - canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath - -/// Indicates if given IL based TyconRef is accessible. If TyconRef is nested then we'll -/// walk though the list of enclosing types and test if all of them are accessible -let private IsILTypeInfoAccessible amap m ad (tcrefOfViewedItem : TyconRef) = + | AccessibleFrom(cpaths, _tcrefViewedFromOption) -> canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath + +/// Indicates if given IL based TyconRef is accessible. If TyconRef is nested then we'll +/// walk though the list of enclosing types and test if all of them are accessible +let private IsILTypeInfoAccessible amap m ad (tcrefOfViewedItem: TyconRef) = let (TILObjectReprData(scoref, enc, tdef)) = tcrefOfViewedItem.ILTyconInfo + let rec check parentTycon path = let ilTypeDefAccessible = match parentTycon with - | None -> + | None -> match path with - | [] -> assert false; true // in this case path should have at least one element - | [x] -> IsILTypeDefAccessible amap m ad None x // shortcut for non-nested types - | x :: xs -> + | [] -> + assert false + true // in this case path should have at least one element + | [ x ] -> IsILTypeDefAccessible amap m ad None x // shortcut for non-nested types + | x :: xs -> // check if enclosing type x is accessible. // if yes - create parent tycon for type 'x' and continue with the rest of the path - IsILTypeDefAccessible amap m ad None x && - ( - let parentILTyRef = mkRefForNestedILTypeDef scoref ([], x) + IsILTypeDefAccessible amap m ad None x + && (let parentILTyRef = mkRefForNestedILTypeDef scoref ([], x) let parentTycon = Import.ImportILTypeRef amap m parentILTyRef - check (Some (parentTycon, [x])) xs - ) - | Some (parentTycon, parentPath) -> + check (Some(parentTycon, [ x ])) xs) + | Some(parentTycon, parentPath) -> match path with | [] -> true // end of path is reached - success - | x :: xs -> + | x :: xs -> // check if x is accessible from the parent tycon // if yes - create parent tycon for type 'x' and continue with the rest of the path - IsILTypeDefAccessible amap m ad (Some parentTycon) x && - ( - let parentILTyRef = mkRefForNestedILTypeDef scoref (parentPath, x) + IsILTypeDefAccessible amap m ad (Some parentTycon) x + && (let parentILTyRef = mkRefForNestedILTypeDef scoref (parentPath, x) let parentTycon = Import.ImportILTypeRef amap m parentILTyRef - check (Some (parentTycon, parentPath @ [x])) xs - ) + check (Some(parentTycon, parentPath @ [ x ])) xs) + ilTypeDefAccessible || IsTyconAccessibleViaVisibleTo ad tcrefOfViewedItem - - check None (enc @ [tdef]) - + + check None (enc @ [ tdef ]) + /// Indicates if an IL member associated with the given ILType is accessible -let private IsILTypeAndMemberAccessible g amap m adType ad (ty: ILTypeInfo) access = - IsILTypeInfoAccessible amap m adType ty.TyconRefOfRawMetadata && IsILMemberAccessible g amap m ty.TyconRefOfRawMetadata ad access +let private IsILTypeAndMemberAccessible g amap m adType ad (ty: ILTypeInfo) access = + IsILTypeInfoAccessible amap m adType ty.TyconRefOfRawMetadata + && IsILMemberAccessible g amap m ty.TyconRefOfRawMetadata ad access /// Indicates if an entity is accessible -let IsEntityAccessible amap m ad (tcref:TyconRef) = - if tcref.IsILTycon then +let IsEntityAccessible amap m ad (tcref: TyconRef) = + if tcref.IsILTycon then IsILTypeInfoAccessible amap m ad tcref - else + else tcref.Accessibility |> IsAccessible ad /// Check that an entity is accessible let CheckTyconAccessible amap m ad tcref = let res = IsEntityAccessible amap m ad tcref - if not res then - errorR(Error(FSComp.SR.typeIsNotAccessible tcref.DisplayName, m)) + + if not res then + errorR (Error(FSComp.SR.typeIsNotAccessible tcref.DisplayName, m)) + res /// Indicates if a type definition and its representation contents are accessible let IsTyconReprAccessible amap m ad tcref = - IsEntityAccessible amap m ad tcref && - IsAccessible ad tcref.TypeReprAccessibility - + IsEntityAccessible amap m ad tcref + && IsAccessible ad tcref.TypeReprAccessibility + /// Check that a type definition and its representation contents are accessible let CheckTyconReprAccessible amap m ad tcref = - CheckTyconAccessible amap m ad tcref && - (let res = IsAccessible ad tcref.TypeReprAccessibility - if not res then - errorR (Error (FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName, m)) - res) - + CheckTyconAccessible amap m ad tcref + && (let res = IsAccessible ad tcref.TypeReprAccessibility + + if not res then + errorR (Error(FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName, m)) + + res) + /// Indicates if a type is accessible (both definition and instantiation) -let rec IsTypeAccessible g amap m ad ty = +let rec IsTypeAccessible g amap m ad ty = match tryAppTy g ty with | ValueNone -> true - | ValueSome(tcref, tinst) -> - IsEntityAccessible amap m ad tcref && IsTypeInstAccessible g amap m ad tinst + | ValueSome(tcref, tinst) -> IsEntityAccessible amap m ad tcref && IsTypeInstAccessible g amap m ad tinst -and IsTypeInstAccessible g amap m ad tinst = - match tinst with - | [] -> true +and IsTypeInstAccessible g amap m ad tinst = + match tinst with + | [] -> true | _ -> List.forall (IsTypeAccessible g amap m ad) tinst /// Indicate if a provided member is accessible -let IsProvidedMemberAccessible (amap:Import.ImportMap) m ad ty access = +let IsProvidedMemberAccessible (amap: Import.ImportMap) m ad ty access = let g = amap.g - if IsTypeAccessible g amap m ad ty then + + if IsTypeAccessible g amap m ad ty then match tryTcrefOfAppTy g ty with | ValueNone -> true - | ValueSome tcrefOfViewedItem -> - IsILMemberAccessible g amap m tcrefOfViewedItem ad access + | ValueSome tcrefOfViewedItem -> IsILMemberAccessible g amap m tcrefOfViewedItem ad access else false /// Compute the accessibility of a provided member let ComputeILAccess isPublic isFamily isFamilyOrAssembly isFamilyAndAssembly = - if isPublic then ILMemberAccess.Public - elif isFamily then ILMemberAccess.Family - elif isFamilyOrAssembly then ILMemberAccess.FamilyOrAssembly - elif isFamilyAndAssembly then ILMemberAccess.FamilyAndAssembly - else ILMemberAccess.Private - -let IsILFieldInfoAccessible g amap m ad x = - match x with - | ILFieldInfo (tinfo, fd) -> IsILTypeAndMemberAccessible g amap m ad ad tinfo fd.Access + if isPublic then + ILMemberAccess.Public + elif isFamily then + ILMemberAccess.Family + elif isFamilyOrAssembly then + ILMemberAccess.FamilyOrAssembly + elif isFamilyAndAssembly then + ILMemberAccess.FamilyAndAssembly + else + ILMemberAccess.Private + +let IsILFieldInfoAccessible g amap m ad x = + match x with + | ILFieldInfo(tinfo, fd) -> IsILTypeAndMemberAccessible g amap m ad ad tinfo fd.Access #if !NO_TYPEPROVIDERS - | ProvidedField (amap, tpfi, m) -> - let access = tpfi.PUntaint((fun fi -> ComputeILAccess fi.IsPublic fi.IsFamily fi.IsFamilyOrAssembly fi.IsFamilyAndAssembly), m) + | ProvidedField(amap, tpfi, m) -> + let access = + tpfi.PUntaint((fun fi -> ComputeILAccess fi.IsPublic fi.IsFamily fi.IsFamilyOrAssembly fi.IsFamilyAndAssembly), m) + IsProvidedMemberAccessible amap m ad x.ApparentEnclosingType access #endif -let GetILAccessOfILEventInfo (ILEventInfo (tinfo, edef)) = - (resolveILMethodRef tinfo.RawMetadata edef.AddMethod).Access +let GetILAccessOfILEventInfo (ILEventInfo(tinfo, edef)) = + (resolveILMethodRef tinfo.RawMetadata edef.AddMethod).Access let IsILEventInfoAccessible g amap m ad einfo = let access = GetILAccessOfILEventInfo einfo IsILTypeAndMemberAccessible g amap m ad ad einfo.ILTypeInfo access -let private IsILMethInfoAccessible g amap m adType ad ilminfo = - match ilminfo with - | ILMethInfo (_, IlType ty, mdef, _) -> IsILTypeAndMemberAccessible g amap m adType ad ty mdef.Access - | ILMethInfo (_, CSharpStyleExtension(declaring=declaringTyconRef), mdef, _) -> IsILMemberAccessible g amap m declaringTyconRef ad mdef.Access +let private IsILMethInfoAccessible g amap m adType ad ilminfo = + match ilminfo with + | ILMethInfo(_, IlType ty, mdef, _) -> IsILTypeAndMemberAccessible g amap m adType ad ty mdef.Access + | ILMethInfo(_, CSharpStyleExtension(declaring = declaringTyconRef), mdef, _) -> + IsILMemberAccessible g amap m declaringTyconRef ad mdef.Access let GetILAccessOfILPropInfo (ILPropInfo(tinfo, pdef)) = let tdef = tinfo.RawMetadata + let ilAccess = - match pdef.GetMethod, pdef.SetMethod with - | Some mref, None + match pdef.GetMethod, pdef.SetMethod with + | Some mref, None | None, Some mref -> (resolveILMethodRef tdef mref).Access | Some mrefGet, Some mrefSet -> @@ -266,7 +282,7 @@ let GetILAccessOfILPropInfo (ILPropInfo(tinfo, pdef)) = // ILMemberAccess.FamilyAndAssembly // ILMemberAccess.Private // ILMemberAccess.CompilerControlled - // + // let getA = (resolveILMethodRef tdef mrefGet).Access let setA = (resolveILMethodRef tdef mrefSet).Access @@ -302,42 +318,45 @@ let IsILPropInfoAccessible g amap m ad pinfo = let ilAccess = GetILAccessOfILPropInfo pinfo IsILTypeAndMemberAccessible g amap m ad ad pinfo.ILTypeInfo ilAccess -let IsValAccessible ad (vref:ValRef) = - vref.Accessibility |> IsAccessible ad - -let CheckValAccessible m ad (vref:ValRef) = - if not (IsValAccessible ad vref) then - errorR (Error (FSComp.SR.valueIsNotAccessible vref.DisplayName, m)) - -let IsUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = - IsTyconReprAccessible amap m ad ucref.TyconRef && - IsAccessible ad ucref.UnionCase.Accessibility - -let CheckUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = - CheckTyconReprAccessible amap m ad ucref.TyconRef && - (let res = IsAccessible ad ucref.UnionCase.Accessibility - if not res then - errorR (Error (FSComp.SR.unionCaseIsNotAccessible ucref.CaseName, m)) - res) - -let IsRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = - IsTyconReprAccessible amap m ad rfref.TyconRef && - IsAccessible ad rfref.RecdField.Accessibility +let IsValAccessible ad (vref: ValRef) = vref.Accessibility |> IsAccessible ad + +let CheckValAccessible m ad (vref: ValRef) = + if not (IsValAccessible ad vref) then + errorR (Error(FSComp.SR.valueIsNotAccessible vref.DisplayName, m)) + +let IsUnionCaseAccessible amap m ad (ucref: UnionCaseRef) = + IsTyconReprAccessible amap m ad ucref.TyconRef + && IsAccessible ad ucref.UnionCase.Accessibility -let CheckRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = - CheckTyconReprAccessible amap m ad rfref.TyconRef && - (let res = IsAccessible ad rfref.RecdField.Accessibility - if not res then - errorR (Error (FSComp.SR.fieldIsNotAccessible rfref.FieldName, m)) - res) +let CheckUnionCaseAccessible amap m ad (ucref: UnionCaseRef) = + CheckTyconReprAccessible amap m ad ucref.TyconRef + && (let res = IsAccessible ad ucref.UnionCase.Accessibility -let CheckRecdFieldInfoAccessible amap m ad (rfinfo:RecdFieldInfo) = + if not res then + errorR (Error(FSComp.SR.unionCaseIsNotAccessible ucref.CaseName, m)) + + res) + +let IsRecdFieldAccessible amap m ad (rfref: RecdFieldRef) = + IsTyconReprAccessible amap m ad rfref.TyconRef + && IsAccessible ad rfref.RecdField.Accessibility + +let CheckRecdFieldAccessible amap m ad (rfref: RecdFieldRef) = + CheckTyconReprAccessible amap m ad rfref.TyconRef + && (let res = IsAccessible ad rfref.RecdField.Accessibility + + if not res then + errorR (Error(FSComp.SR.fieldIsNotAccessible rfref.FieldName, m)) + + res) + +let CheckRecdFieldInfoAccessible amap m ad (rfinfo: RecdFieldInfo) = CheckRecdFieldAccessible amap m ad rfinfo.RecdFieldRef |> ignore let CheckILFieldInfoAccessible g amap m ad finfo = - if not (IsILFieldInfoAccessible g amap m ad finfo) then - errorR (Error (FSComp.SR.structOrClassFieldIsNotAccessible finfo.FieldName, m)) - + if not (IsILFieldInfoAccessible g amap m ad finfo) then + errorR (Error(FSComp.SR.structOrClassFieldIsNotAccessible finfo.FieldName, m)) + /// Uses a separate accessibility domains for containing type and method itself /// This makes sense cases like /// type A() = @@ -348,45 +367,55 @@ let CheckILFieldInfoAccessible g amap m ad finfo = /// inherit A() /// let x = A.B() /// do x.Public() -/// when calling x.SomeMethod() we need to use 'adTyp' do verify that type of x is accessible from C +/// when calling x.SomeMethod() we need to use 'adTyp' do verify that type of x is accessible from C /// and 'ad' to determine accessibility of SomeMethod. -/// I.e when calling x.Public() and x.Protected() -in both cases first check should succeed and second - should fail in the latter one. -let rec IsTypeAndMethInfoAccessible amap m accessDomainTy ad = function - | ILMeth (g, x, _) -> IsILMethInfoAccessible g amap m accessDomainTy ad x - | FSMeth (_, _, vref, _) -> IsValAccessible ad vref - | MethInfoWithModifiedReturnType(mi,_) -> IsTypeAndMethInfoAccessible amap m accessDomainTy ad mi +/// I.e when calling x.Public() and x.Protected() -in both cases first check should succeed and second - should fail in the latter one. +let rec IsTypeAndMethInfoAccessible amap m accessDomainTy ad = + function + | ILMeth(g, x, _) -> IsILMethInfoAccessible g amap m accessDomainTy ad x + | FSMeth(_, _, vref, _) -> IsValAccessible ad vref + | MethInfoWithModifiedReturnType(mi, _) -> IsTypeAndMethInfoAccessible amap m accessDomainTy ad mi | DefaultStructCtor(g, ty) -> IsTypeAccessible g amap m ad ty #if !NO_TYPEPROVIDERS - | ProvidedMeth(amap, tpmb, _, m) as etmi -> - let access = tpmb.PUntaint((fun mi -> ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly), m) + | ProvidedMeth(amap, tpmb, _, m) as etmi -> + let access = + tpmb.PUntaint((fun mi -> ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly), m) + IsProvidedMemberAccessible amap m ad etmi.ApparentEnclosingType access #endif -let IsMethInfoAccessible amap m ad minfo = IsTypeAndMethInfoAccessible amap m ad ad minfo +let IsMethInfoAccessible amap m ad minfo = + IsTypeAndMethInfoAccessible amap m ad ad minfo -let IsPropInfoAccessible g amap m ad = function +let IsPropInfoAccessible g amap m ad = + function | ILProp ilpinfo -> IsILPropInfoAccessible g amap m ad ilpinfo - | FSProp (_, _, Some vref, None) - | FSProp (_, _, None, Some vref) -> IsValAccessible ad vref - | FSProp (_, _, Some vrefGet, Some vrefSet) -> + | FSProp(_, _, Some vref, None) + | FSProp(_, _, None, Some vref) -> IsValAccessible ad vref + | FSProp(_, _, Some vrefGet, Some vrefSet) -> // pick most accessible IsValAccessible ad vrefGet || IsValAccessible ad vrefSet #if !NO_TYPEPROVIDERS - | ProvidedProp (amap, tppi, m) as pp-> - let access = - let a = tppi.PUntaint((fun ppi -> - let tryGetILAccessForProvidedMethodBase (mi : ProvidedMethodInfo MaybeNull) = - match mi with - | Null -> None - | NonNull mi -> - Some(ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly) - - match tryGetILAccessForProvidedMethodBase(ppi.GetGetMethod()) with - | None -> tryGetILAccessForProvidedMethodBase(ppi.GetSetMethod()) - | x -> x), m) + | ProvidedProp(amap, tppi, m) as pp -> + let access = + let a = + tppi.PUntaint( + (fun ppi -> + let tryGetILAccessForProvidedMethodBase (mi: ProvidedMethodInfo MaybeNull) = + match mi with + | Null -> None + | NonNull mi -> Some(ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly) + + match tryGetILAccessForProvidedMethodBase (ppi.GetGetMethod()) with + | None -> tryGetILAccessForProvidedMethodBase (ppi.GetSetMethod()) + | x -> x), + m + ) + defaultArg a ILMemberAccess.Public + IsProvidedMemberAccessible amap m ad pp.ApparentEnclosingType access #endif | _ -> false -let IsFieldInfoAccessible ad (rfref:RecdFieldInfo) = +let IsFieldInfoAccessible ad (rfref: RecdFieldInfo) = IsAccessible ad rfref.RecdField.Accessibility diff --git a/src/Compiler/Checking/AttributeChecking.fs b/src/Compiler/Checking/AttributeChecking.fs index 6e6cef5461b..7bba0e47df7 100755 --- a/src/Compiler/Checking/AttributeChecking.fs +++ b/src/Compiler/Checking/AttributeChecking.fs @@ -1,14 +1,14 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -/// Logic associated with checking "ObsoleteAttribute" and other attributes +/// Logic associated with checking "ObsoleteAttribute" and other attributes /// on items from name resolution module internal FSharp.Compiler.AttributeChecking open System open System.Collections.Generic open Internal.Utilities.Library -open FSharp.Compiler.AbstractIL.IL -open FSharp.Compiler +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Features open FSharp.Compiler.Import @@ -24,11 +24,12 @@ open FSharp.Compiler.TypeProviders open FSharp.Core.CompilerServices #endif -let fail() = failwith "This custom attribute has an argument that cannot yet be converted using this API" +let fail () = + failwith "This custom attribute has an argument that cannot yet be converted using this API" -let rec private evalILAttribElem elem = - match elem with - | ILAttribElem.String (Some x) -> box x +let rec private evalILAttribElem elem = + match elem with + | ILAttribElem.String(Some x) -> box x | ILAttribElem.String None -> null | ILAttribElem.Bool x -> box x | ILAttribElem.Char x -> box x @@ -43,22 +44,22 @@ let rec private evalILAttribElem elem = | ILAttribElem.Single x -> box x | ILAttribElem.Double x -> box x | ILAttribElem.Null -> null - | ILAttribElem.Array (_, a) -> box [| for i in a -> evalILAttribElem i |] + | ILAttribElem.Array(_, a) -> box [| for i in a -> evalILAttribElem i |] // TODO: typeof<..> in attribute values - | ILAttribElem.Type (Some _t) -> fail() + | ILAttribElem.Type(Some _t) -> fail () | ILAttribElem.Type None -> null - | ILAttribElem.TypeRef (Some _t) -> fail() + | ILAttribElem.TypeRef(Some _t) -> fail () | ILAttribElem.TypeRef None -> null -let rec private evalFSharpAttribArg g attribExpr = +let rec private evalFSharpAttribArg g attribExpr = match stripDebugPoints attribExpr with - | Expr.Const (c, _, _) -> - match c with + | Expr.Const(c, _, _) -> + match c with | Const.Bool b -> box b | Const.SByte i -> box i - | Const.Int16 i -> box i + | Const.Int16 i -> box i | Const.Int32 i -> box i - | Const.Int64 i -> box i + | Const.Int64 i -> box i | Const.Byte i -> box i | Const.UInt16 i -> box i | Const.UInt32 i -> box i @@ -67,115 +68,122 @@ let rec private evalFSharpAttribArg g attribExpr = | Const.Double i -> box i | Const.Char i -> box i | Const.Zero -> null - | Const.String s -> box s - | _ -> fail() - | Expr.Op (TOp.Array, _, a, _) -> box [| for i in a -> evalFSharpAttribArg g i |] + | Const.String s -> box s + | _ -> fail () + | Expr.Op(TOp.Array, _, a, _) -> box [| for i in a -> evalFSharpAttribArg g i |] | TypeOfExpr g ty -> box ty // TODO: | TypeDefOfExpr g ty - | _ -> fail() + | _ -> fail () -type AttribInfo = +type AttribInfo = | FSAttribInfo of TcGlobals * Attrib | ILAttribInfo of TcGlobals * Import.ImportMap * ILScopeRef * ILAttribute * range - member x.Range = - match x with - | FSAttribInfo(_, attrib) -> attrib.Range - | ILAttribInfo (_, _, _, _, m) -> m - - member x.TyconRef = - match x with - | FSAttribInfo(_g, Attrib(tcref, _, _, _, _, _, _)) -> tcref - | ILAttribInfo (g, amap, scoref, a, m) -> - // We are skipping nullness check here because this reference is an attribute usage, nullness does not apply. - let ty = RescopeAndImportILTypeSkipNullness scoref amap m [] a.Method.DeclaringType - tcrefOfAppTy g ty - - member x.ConstructorArguments = - match x with - | FSAttribInfo(g, Attrib(_, _, unnamedArgs, _, _, _, _)) -> - unnamedArgs - |> List.map (fun (AttribExpr(origExpr, evaluatedExpr)) -> - let ty = tyOfExpr g origExpr - let obj = evalFSharpAttribArg g evaluatedExpr - ty, obj) - | ILAttribInfo (_g, amap, scoref, cattr, m) -> - let params_, _args = decodeILAttribData cattr - [ for argTy, arg in Seq.zip cattr.Method.FormalArgTypes params_ -> + member x.Range = + match x with + | FSAttribInfo(_, attrib) -> attrib.Range + | ILAttribInfo(_, _, _, _, m) -> m + + member x.TyconRef = + match x with + | FSAttribInfo(_g, Attrib(tcref, _, _, _, _, _, _)) -> tcref + | ILAttribInfo(g, amap, scoref, a, m) -> + // We are skipping nullness check here because this reference is an attribute usage, nullness does not apply. + let ty = RescopeAndImportILTypeSkipNullness scoref amap m [] a.Method.DeclaringType + tcrefOfAppTy g ty + + member x.ConstructorArguments = + match x with + | FSAttribInfo(g, Attrib(_, _, unnamedArgs, _, _, _, _)) -> + unnamedArgs + |> List.map (fun (AttribExpr(origExpr, evaluatedExpr)) -> + let ty = tyOfExpr g origExpr + let obj = evalFSharpAttribArg g evaluatedExpr + ty, obj) + | ILAttribInfo(_g, amap, scoref, cattr, m) -> + let params_, _args = decodeILAttribData cattr + + [ + for argTy, arg in Seq.zip cattr.Method.FormalArgTypes params_ -> // We are skipping nullness check here because this reference is an attribute usage, nullness does not apply. let ty = RescopeAndImportILTypeSkipNullness scoref amap m [] argTy let obj = evalILAttribElem arg - ty, obj ] - - member x.NamedArguments = - match x with - | FSAttribInfo(g, Attrib(_, _, _, namedArgs, _, _, _)) -> - namedArgs - |> List.map (fun (AttribNamedArg(nm, _, isField, AttribExpr(origExpr, evaluatedExpr))) -> - let ty = tyOfExpr g origExpr - let obj = evalFSharpAttribArg g evaluatedExpr - ty, nm, isField, obj) - | ILAttribInfo (_g, amap, scoref, cattr, m) -> - let _params_, namedArgs = decodeILAttribData cattr - [ for nm, argTy, isProp, arg in namedArgs -> + ty, obj + ] + + member x.NamedArguments = + match x with + | FSAttribInfo(g, Attrib(_, _, _, namedArgs, _, _, _)) -> + namedArgs + |> List.map (fun (AttribNamedArg(nm, _, isField, AttribExpr(origExpr, evaluatedExpr))) -> + let ty = tyOfExpr g origExpr + let obj = evalFSharpAttribArg g evaluatedExpr + ty, nm, isField, obj) + | ILAttribInfo(_g, amap, scoref, cattr, m) -> + let _params_, namedArgs = decodeILAttribData cattr + + [ + for nm, argTy, isProp, arg in namedArgs -> // We are skipping nullness check here because this reference is an attribute usage, nullness does not apply. let ty = RescopeAndImportILTypeSkipNullness scoref amap m [] argTy let obj = evalILAttribElem arg - let isField = not isProp - ty, nm, isField, obj ] - + let isField = not isProp + ty, nm, isField, obj + ] /// Check custom attributes. This is particularly messy because custom attributes come in in three different /// formats. -let AttribInfosOfIL g amap scoref m (attribs: ILAttributes) = - attribs.AsList() |> List.map (fun a -> ILAttribInfo (g, amap, scoref, a, m)) +let AttribInfosOfIL g amap scoref m (attribs: ILAttributes) = + attribs.AsList() |> List.map (fun a -> ILAttribInfo(g, amap, scoref, a, m)) -let AttribInfosOfFS g attribs = - attribs |> List.map (fun a -> FSAttribInfo (g, a)) +let AttribInfosOfFS g attribs = + attribs |> List.map (fun a -> FSAttribInfo(g, a)) -let GetAttribInfosOfEntity g amap m (tcref:TyconRef) = - match metadataOfTycon tcref.Deref with +let GetAttribInfosOfEntity g amap m (tcref: TyconRef) = + match metadataOfTycon tcref.Deref with #if !NO_TYPEPROVIDERS // TODO: provided attributes | 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 + //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(scoref, _, tdef)) -> - tdef.CustomAttrs |> AttribInfosOfIL g amap scoref m - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - tcref.Attribs |> List.map (fun a -> FSAttribInfo (g, a)) - - -let rec GetAttribInfosOfMethod amap m minfo = - match minfo with - | ILMeth (g, ilminfo, _) -> ilminfo.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap ilminfo.MetadataScope m - | FSMeth (g, _, vref, _) -> vref.Attribs |> AttribInfosOfFS g - | MethInfoWithModifiedReturnType(mi,_) -> GetAttribInfosOfMethod amap m mi + | ILTypeMetadata(TILObjectReprData(scoref, _, tdef)) -> tdef.CustomAttrs |> AttribInfosOfIL g amap scoref m + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> tcref.Attribs |> List.map (fun a -> FSAttribInfo(g, a)) + +let rec GetAttribInfosOfMethod amap m minfo = + match minfo with + | ILMeth(g, ilminfo, _) -> + ilminfo.RawMetadata.CustomAttrs + |> AttribInfosOfIL g amap ilminfo.MetadataScope m + | FSMeth(g, _, vref, _) -> vref.Attribs |> AttribInfosOfFS g + | MethInfoWithModifiedReturnType(mi, _) -> GetAttribInfosOfMethod amap m mi | DefaultStructCtor _ -> [] #if !NO_TYPEPROVIDERS // TODO: provided attributes - | ProvidedMeth (_, _mi, _, _m) -> - [] + | ProvidedMeth(_, _mi, _, _m) -> [] #endif -let GetAttribInfosOfProp amap m pinfo = - match pinfo with - | ILProp ilpinfo -> ilpinfo.RawMetadata.CustomAttrs |> AttribInfosOfIL ilpinfo.TcGlobals amap ilpinfo.ILTypeInfo.ILScopeRef m - | FSProp(g, _, Some vref, _) - | FSProp(g, _, _, Some vref) -> vref.Attribs |> AttribInfosOfFS g +let GetAttribInfosOfProp amap m pinfo = + match pinfo with + | ILProp ilpinfo -> + ilpinfo.RawMetadata.CustomAttrs + |> AttribInfosOfIL ilpinfo.TcGlobals amap ilpinfo.ILTypeInfo.ILScopeRef m + | FSProp(g, _, Some vref, _) + | FSProp(g, _, _, Some vref) -> vref.Attribs |> AttribInfosOfFS g | FSProp _ -> failwith "GetAttribInfosOfProp: unreachable" #if !NO_TYPEPROVIDERS // TODO: provided attributes - | ProvidedProp _ -> [] + | ProvidedProp _ -> [] #endif -let GetAttribInfosOfEvent amap m einfo = - match einfo with - | ILEvent ileinfo -> ileinfo.RawMetadata.CustomAttrs |> AttribInfosOfIL einfo.TcGlobals amap ileinfo.ILTypeInfo.ILScopeRef m +let GetAttribInfosOfEvent amap m einfo = + match einfo with + | ILEvent ileinfo -> + ileinfo.RawMetadata.CustomAttrs + |> AttribInfosOfIL einfo.TcGlobals amap ileinfo.ILTypeInfo.ILScopeRef m | FSEvent(_, pi, _vref1, _vref2) -> GetAttribInfosOfProp amap m pi #if !NO_TYPEPROVIDERS // TODO: provided attributes @@ -184,30 +192,39 @@ let GetAttribInfosOfEvent amap m einfo = /// Analyze three cases for attributes declared on methods: IL-declared attributes, F#-declared attributes and /// provided attributes. -let rec BindMethInfoAttributes m minfo f1 f2 f3 = - ignore m; ignore f3 - match minfo with - | ILMeth (_, x, _) -> f1 x.RawMetadata.CustomAttrs - | FSMeth (_, _, vref, _) -> f2 vref.Attribs - | MethInfoWithModifiedReturnType(mi,_) -> BindMethInfoAttributes m mi f1 f2 f3 +let rec BindMethInfoAttributes m minfo f1 f2 f3 = + ignore m + ignore f3 + + match minfo with + | ILMeth(_, x, _) -> f1 x.RawMetadata.CustomAttrs + | FSMeth(_, _, vref, _) -> f2 vref.Attribs + | MethInfoWithModifiedReturnType(mi, _) -> BindMethInfoAttributes m mi f1 f2 f3 | DefaultStructCtor _ -> f2 [] #if !NO_TYPEPROVIDERS - | ProvidedMeth (_, mi, _, _) -> f3 (mi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) + | ProvidedMeth(_, mi, _, _) -> f3 (mi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) #endif /// Analyze three cases for attributes declared on methods: IL-declared attributes, F#-declared attributes and /// provided attributes. -let TryBindMethInfoAttribute g (m: range) (AttribInfo(atref, _) as attribSpec) minfo f1 f2 f3 = +let TryBindMethInfoAttribute g (m: range) (AttribInfo(atref, _) as attribSpec) minfo f1 f2 f3 = #if NO_TYPEPROVIDERS // to prevent unused parameter warning ignore f3 #endif - BindMethInfoAttributes m minfo + BindMethInfoAttributes + m + minfo (fun ilAttribs -> TryDecodeILAttribute atref ilAttribs |> Option.bind f1) (fun fsAttribs -> TryFindFSharpAttribute g attribSpec fsAttribs |> Option.bind f2) #if !NO_TYPEPROVIDERS - (fun provAttribs -> - match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)), m) with + (fun provAttribs -> + match + provAttribs.PUntaint( + (fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)), + m + ) + with | Some args -> f3 args | None -> None) #else @@ -217,34 +234,40 @@ let TryBindMethInfoAttribute g (m: range) (AttribInfo(atref, _) as attribSpec) m /// Try to find a specific attribute on a method, where the attribute accepts a string argument. /// /// This is just used for the 'ConditionalAttribute' attribute -let TryFindMethInfoStringAttribute g (m: range) attribSpec minfo = - TryBindMethInfoAttribute g m attribSpec minfo - (function [ILAttribElem.String (Some msg) ], _ -> Some msg | _ -> None) - (function Attrib(_, _, [ AttribStringArg msg ], _, _, _, _) -> Some msg | _ -> None) - (function [ Some (:? string as msg : obj) ], _ -> Some msg | _ -> None) +let TryFindMethInfoStringAttribute g (m: range) attribSpec minfo = + TryBindMethInfoAttribute + g + m + attribSpec + minfo + (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 method has a specific attribute. -let MethInfoHasAttribute g m attribSpec minfo = - TryBindMethInfoAttribute g m attribSpec minfo - (fun _ -> Some ()) - (fun _ -> Some ()) - (fun _ -> Some ()) - |> Option.isSome +let MethInfoHasAttribute g m attribSpec minfo = + TryBindMethInfoAttribute g m attribSpec minfo (fun _ -> Some()) (fun _ -> Some()) (fun _ -> Some()) + |> Option.isSome let private CheckCompilerFeatureRequiredAttribute (g: TcGlobals) cattrs msg m = // In some cases C# will generate both ObsoleteAttribute and CompilerFeatureRequiredAttribute. // Specifically, when default constructor is generated for class with any required members in them. // ObsoleteAttribute should be ignored if CompilerFeatureRequiredAttribute is present, and its name is "RequiredMembers". - let (AttribInfo(tref,_)) = g.attrib_CompilerFeatureRequiredAttribute + let (AttribInfo(tref, _)) = g.attrib_CompilerFeatureRequiredAttribute + match TryDecodeILAttribute tref cattrs with - | Some([ILAttribElem.String (Some featureName) ], _) when featureName = "RequiredMembers" -> - CompleteD - | _ -> - ErrorD (ObsoleteDiagnostic(true, None, msg, None, m)) - -let private extractILAttribValueFrom name namedArgs = - match namedArgs with - | ExtractILAttributeNamedArg name (AttribElemStringArg v) -> Some v + | Some([ ILAttribElem.String(Some featureName) ], _) when featureName = "RequiredMembers" -> CompleteD + | _ -> ErrorD(ObsoleteDiagnostic(true, None, msg, None, m)) + +let private extractILAttribValueFrom name namedArgs = + match namedArgs with + | ExtractILAttributeNamedArg name (AttribElemStringArg v) -> Some v | _ -> None let private extractILAttributeInfo namedArgs = @@ -253,17 +276,18 @@ let private extractILAttributeInfo namedArgs = (diagnosticId, urlFormat) let private CheckILExperimentalAttributes (g: TcGlobals) cattrs m = - let (AttribInfo(tref,_)) = g.attrib_IlExperimentalAttribute + let (AttribInfo(tref, _)) = g.attrib_IlExperimentalAttribute + match TryDecodeILAttribute tref cattrs with // [Experimental("DiagnosticId")] // [Experimental(diagnosticId: "DiagnosticId")] // [Experimental("DiagnosticId", UrlFormat = "UrlFormat")] // [Experimental(diagnosticId = "DiagnosticId", UrlFormat = "UrlFormat")] // Constructors deciding on DiagnosticId and UrlFormat properties. - | Some ([ attribElement ], namedArgs) -> - let diagnosticId = - match attribElement with - | ILAttribElem.String (Some msg) -> Some msg + | Some([ attribElement ], namedArgs) -> + let diagnosticId = + match attribElement with + | ILAttribElem.String(Some msg) -> Some msg | ILAttribElem.String None | _ -> None @@ -279,7 +303,8 @@ let private CheckILObsoleteAttributes (g: TcGlobals) isByrefLikeTyconRef cattrs if isByrefLikeTyconRef then CompleteD else - let (AttribInfo(tref,_)) = g.attrib_SystemObsolete + let (AttribInfo(tref, _)) = g.attrib_SystemObsolete + match TryDecodeILAttribute tref cattrs with // [Obsolete] // [Obsolete("Message")] @@ -291,26 +316,28 @@ let private CheckILObsoleteAttributes (g: TcGlobals) isByrefLikeTyconRef cattrs // [Obsolete("Message", true, DiagnosticId = "DiagnosticId")] // [Obsolete("Message", true, DiagnosticId = "DiagnosticId", UrlFormat = "UrlFormat")] // Constructors deciding on IsError and Message properties. - | Some ([ attribElement ], namedArgs) -> + | Some([ attribElement ], namedArgs) -> let diagnosticId, urlFormat = extractILAttributeInfo namedArgs - let msg = - match attribElement with - | ILAttribElem.String (Some msg) -> Some msg + + let msg = + match attribElement with + | ILAttribElem.String(Some msg) -> Some msg | ILAttribElem.String None | _ -> None - WarnD (ObsoleteDiagnostic(false, diagnosticId, msg, urlFormat, m)) - | Some ([ILAttribElem.String msg; ILAttribElem.Bool isError ], namedArgs) -> + WarnD(ObsoleteDiagnostic(false, diagnosticId, msg, urlFormat, m)) + | Some([ ILAttribElem.String msg; ILAttribElem.Bool isError ], namedArgs) -> let diagnosticId, urlFormat = extractILAttributeInfo namedArgs + if isError then if g.langVersion.SupportsFeature(LanguageFeature.RequiredPropertiesSupport) then CheckCompilerFeatureRequiredAttribute g cattrs msg m else - ErrorD (ObsoleteDiagnostic(true, diagnosticId, msg, urlFormat, m)) + ErrorD(ObsoleteDiagnostic(true, diagnosticId, msg, urlFormat, m)) else - WarnD (ObsoleteDiagnostic(false, diagnosticId, msg, urlFormat, m)) + WarnD(ObsoleteDiagnostic(false, diagnosticId, msg, urlFormat, m)) // Only DiagnosticId, UrlFormat - | Some (_, namedArgs) -> + | Some(_, namedArgs) -> let diagnosticId, urlFormat = extractILAttributeInfo namedArgs WarnD(ObsoleteDiagnostic(false, diagnosticId, None, urlFormat, m)) // No arguments @@ -324,10 +351,11 @@ let private CheckILAttributes (g: TcGlobals) isByrefLikeTyconRef cattrs m = } let private extractObsoleteAttributeInfo namedArgs = - let extractILAttribValueFrom name namedArgs = - match namedArgs with - | ExtractAttribNamedArg name (AttribStringArg v) -> Some v + let extractILAttribValueFrom name namedArgs = + match namedArgs with + | ExtractAttribNamedArg name (AttribStringArg v) -> Some v | _ -> None + let diagnosticId = extractILAttribValueFrom "DiagnosticId" namedArgs let urlFormat = extractILAttribValueFrom "UrlFormat" namedArgs (diagnosticId, urlFormat) @@ -345,72 +373,75 @@ let private CheckObsoleteAttributes g attribs m = // [] // [] // Constructors deciding on IsError and Message properties. - | Some(Attrib(unnamedArgs= [ AttribStringArg s ]; propVal= namedArgs)) -> + | Some(Attrib(unnamedArgs = [ AttribStringArg s ]; propVal = namedArgs)) -> let diagnosticId, urlFormat = extractObsoleteAttributeInfo namedArgs do! WarnD(ObsoleteDiagnostic(false, diagnosticId, Some s, urlFormat, m)) - | Some(Attrib(unnamedArgs= [ AttribStringArg s; AttribBoolArg(isError) ]; propVal= namedArgs)) -> + | Some(Attrib(unnamedArgs = [ AttribStringArg s; AttribBoolArg(isError) ]; propVal = namedArgs)) -> let diagnosticId, urlFormat = extractObsoleteAttributeInfo namedArgs + if isError then - do! ErrorD (ObsoleteDiagnostic(true, diagnosticId, Some s, urlFormat, m)) + do! ErrorD(ObsoleteDiagnostic(true, diagnosticId, Some s, urlFormat, m)) else - do! WarnD (ObsoleteDiagnostic(false, diagnosticId, Some s, urlFormat, m)) + do! WarnD(ObsoleteDiagnostic(false, diagnosticId, Some s, urlFormat, m)) // Only DiagnosticId, UrlFormat - | Some(Attrib(propVal= namedArgs)) -> + | Some(Attrib(propVal = namedArgs)) -> let diagnosticId, urlFormat = extractObsoleteAttributeInfo namedArgs do! WarnD(ObsoleteDiagnostic(false, diagnosticId, None, urlFormat, m)) - | None -> () + | None -> () } - + let private CheckCompilerMessageAttribute g attribs m = trackErrors { match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with - | Some(Attrib(unnamedArgs= [ AttribStringArg s ; AttribInt32Arg n ]; propVal= namedArgs)) -> + | Some(Attrib(unnamedArgs = [ AttribStringArg s; AttribInt32Arg n ]; propVal = namedArgs)) -> let msg = UserCompilerMessage(s, n, m) - let isError = - match namedArgs with - | ExtractAttribNamedArg "IsError" (AttribBoolArg v) -> v - | _ -> false + + let isError = + match namedArgs with + | ExtractAttribNamedArg "IsError" (AttribBoolArg v) -> v + | _ -> false // If we are using a compiler that supports nameof then error 3501 is always suppressed. // See attribute on FSharp.Core 'nameof' if n = 3501 then () elif isError && (not g.compilingFSharpCore || n <> 1204) then - do! ErrorD msg + do! ErrorD msg else do! WarnD msg - | _ -> - () + | _ -> () } - + let private CheckFSharpExperimentalAttribute g attribs m = trackErrors { match TryFindFSharpAttribute g g.attrib_ExperimentalAttribute attribs with // [] - | Some(Attrib(unnamedArgs= [ AttribStringArg(s) ])) -> - let isExperimentalAttributeDisabled (s:string) = + | Some(Attrib(unnamedArgs = [ AttribStringArg(s) ])) -> + let isExperimentalAttributeDisabled (s: string) = if g.compilingFSharpCore then true else - g.langVersion.IsPreviewEnabled && (s.IndexOf("--langversion:preview", StringComparison.OrdinalIgnoreCase) >= 0) + g.langVersion.IsPreviewEnabled + && (s.IndexOf("--langversion:preview", StringComparison.OrdinalIgnoreCase) >= 0) + if not (isExperimentalAttributeDisabled s) then do! WarnD(Experimental(Some s, None, None, m)) // Empty constructor is not allowed. | Some _ | _ -> () } - -let private CheckUnverifiableAttribute g attribs m = + +let private CheckUnverifiableAttribute g attribs m = trackErrors { match TryFindFSharpAttribute g g.attrib_UnverifiableAttribute attribs with - | Some _ -> - do! WarnD(PossibleUnverifiableCode(m)) + | Some _ -> do! WarnD(PossibleUnverifiableCode(m)) | _ -> () } /// Check F# attributes for 'ObsoleteAttribute', 'CompilerMessageAttribute' and 'ExperimentalAttribute', /// returning errors and warnings as data -let CheckFSharpAttributes (g:TcGlobals) attribs m = - if isNil attribs then CompleteD +let CheckFSharpAttributes (g: TcGlobals) attribs m = + if isNil attribs then + CompleteD else trackErrors { do! CheckObsoleteAttributes g attribs m @@ -421,112 +452,112 @@ let CheckFSharpAttributes (g:TcGlobals) attribs m = #if !NO_TYPEPROVIDERS /// Check a list of provided attributes for 'ObsoleteAttribute', returning errors and warnings as data -let private CheckProvidedAttributes (g: TcGlobals) m (provAttribs: Tainted) = +let private CheckProvidedAttributes (g: TcGlobals) m (provAttribs: Tainted) = let (AttribInfo(tref, _)) = g.attrib_SystemObsolete - match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), tref.FullName)), m) with - | Some ([ Some (:? string as msg) ], _) -> WarnD(ObsoleteDiagnostic(false, None, Some msg, None, m)) - | Some ([ Some (:? string as msg); Some (:?bool as isError) ], _) -> - if isError then - ErrorD (ObsoleteDiagnostic(true, None, Some msg, None, m)) - else - WarnD (ObsoleteDiagnostic(false, None, Some msg, None, m)) - | Some ([ None ], _) -> - WarnD(ObsoleteDiagnostic(false, None, None, None, m)) - | Some _ -> - WarnD(ObsoleteDiagnostic(false, None, None, None, m)) - | None -> - CompleteD + + match + provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), tref.FullName)), m) + with + | Some([ Some(:? string as msg) ], _) -> WarnD(ObsoleteDiagnostic(false, None, Some msg, None, m)) + | Some([ Some(:? string as msg); Some(:? bool as isError) ], _) -> + if isError then + ErrorD(ObsoleteDiagnostic(true, None, Some msg, None, m)) + else + WarnD(ObsoleteDiagnostic(false, None, Some msg, None, m)) + | Some([ None ], _) -> WarnD(ObsoleteDiagnostic(false, None, None, None, m)) + | Some _ -> WarnD(ObsoleteDiagnostic(false, None, None, None, m)) + | None -> CompleteD #endif /// Indicate if a list of IL attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. -let CheckILAttributesForUnseen (g: TcGlobals) cattrs _m = +let CheckILAttributesForUnseen (g: TcGlobals) cattrs _m = let (AttribInfo(tref, _)) = g.attrib_SystemObsolete Option.isSome (TryDecodeILAttribute tref cattrs) /// Checks the attributes for CompilerMessageAttribute, which has an IsHidden argument that allows /// items to be suppressed from intellisense. -let CheckFSharpAttributesForHidden g attribs = - not (isNil attribs) && - (match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with - | Some(Attrib(_, _, [AttribStringArg _; AttribInt32Arg messageNumber], - ExtractAttribNamedArg "IsHidden" (AttribBoolArg v), _, _, _)) -> +let CheckFSharpAttributesForHidden g attribs = + not (isNil attribs) + && (match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with + | Some(Attrib(_, _, [ AttribStringArg _; AttribInt32Arg messageNumber ], ExtractAttribNamedArg "IsHidden" (AttribBoolArg v), _, _, _)) -> // Message number 62 is for "ML Compatibility". Items labelled with this are visible in intellisense // when mlCompatibility is set. v && not (messageNumber = 62 && g.mlCompatibility) | _ -> false) - || - (match TryFindFSharpAttribute g g.attrib_ComponentModelEditorBrowsableAttribute attribs with - | Some(Attrib(_, _, [AttribInt32Arg state], _, _, _, _)) -> state = int System.ComponentModel.EditorBrowsableState.Never - | _ -> false) + || (match TryFindFSharpAttribute g g.attrib_ComponentModelEditorBrowsableAttribute attribs with + | Some(Attrib(_, _, [ AttribInt32Arg state ], _, _, _, _)) -> state = int System.ComponentModel.EditorBrowsableState.Never + | _ -> false) /// Indicate if a list of F# attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. -let CheckFSharpAttributesForObsolete g attribs = +let CheckFSharpAttributesForObsolete g attribs = not (isNil attribs) && (HasFSharpAttribute g g.attrib_SystemObsolete attribs) /// Indicate if a list of F# attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. /// Also check the attributes for CompilerMessageAttribute, which has an IsHidden argument that allows /// items to be suppressed from intellisense. -let CheckFSharpAttributesForUnseen g attribs _m = - not (isNil attribs) && - (CheckFSharpAttributesForObsolete g attribs || - CheckFSharpAttributesForHidden g attribs) - +let CheckFSharpAttributesForUnseen g attribs _m = + not (isNil attribs) + && (CheckFSharpAttributesForObsolete g attribs + || CheckFSharpAttributesForHidden g attribs) + #if !NO_TYPEPROVIDERS /// Indicate if a list of provided attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. -let CheckProvidedAttributesForUnseen (provAttribs: Tainted) m = - provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), !! typeof.FullName).IsSome), m) +let CheckProvidedAttributesForUnseen (provAttribs: Tainted) m = + provAttribs.PUntaint( + (fun a -> + a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), !!typeof.FullName).IsSome), + m + ) #endif /// Check the attributes associated with a property, returning warnings and errors as data. -let CheckPropInfoAttributes pinfo m = +let CheckPropInfoAttributes pinfo m = match pinfo with | ILProp(ILPropInfo(_, pdef)) -> CheckILAttributes pinfo.TcGlobals false pdef.CustomAttrs m - | FSProp(g, _, Some vref, _) + | FSProp(g, _, Some vref, _) | FSProp(g, _, _, Some vref) -> CheckFSharpAttributes g vref.Attribs m | FSProp _ -> failwith "CheckPropInfoAttributes: unreachable" #if !NO_TYPEPROVIDERS - | ProvidedProp (amap, pi, m) -> - CheckProvidedAttributes amap.g m (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) - + | ProvidedProp(amap, pi, m) -> CheckProvidedAttributes amap.g m (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) + #endif - /// Check the attributes associated with a IL field, returning warnings and errors as data. -let CheckILFieldAttributes g (finfo:ILFieldInfo) m = - match finfo with - | ILFieldInfo(_, pd) -> - CheckILAttributes g false pd.CustomAttrs m |> CommitOperationResult +let CheckILFieldAttributes g (finfo: ILFieldInfo) m = + match finfo with + | ILFieldInfo(_, pd) -> CheckILAttributes g false pd.CustomAttrs m |> CommitOperationResult #if !NO_TYPEPROVIDERS - | ProvidedField (amap, fi, m) -> - CheckProvidedAttributes amap.g m (fi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) |> CommitOperationResult + | ProvidedField(amap, fi, m) -> + CheckProvidedAttributes amap.g m (fi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) + |> CommitOperationResult #endif /// Check the attributes on an entity, returning errors and warnings as data. -let CheckEntityAttributes g (tcref: TyconRef) m = - if tcref.IsILTycon then +let CheckEntityAttributes g (tcref: TyconRef) m = + if tcref.IsILTycon then CheckILAttributes g (isByrefLikeTyconRef g m tcref) tcref.ILTyconRawMetadata.CustomAttrs m - else + else CheckFSharpAttributes g tcref.Attribs m - -let CheckILEventAttributes g (tcref: TyconRef) cattrs m = + +let CheckILEventAttributes g (tcref: TyconRef) cattrs m = CheckILAttributes g (isByrefLikeTyconRef g m tcref) cattrs m -let CheckUnitOfMeasureAttributes g (measure: Measure) = +let CheckUnitOfMeasureAttributes g (measure: Measure) = let checkAttribs tm m = let attribs = ListMeasureConOccsWithNonZeroExponents g true tm |> List.map fst - |> List.map(_.Attribs) + |> List.map (_.Attribs) |> List.concat CheckFSharpAttributes g attribs m |> CommitOperationResult - + match measure with | Measure.Const(range = m) -> checkAttribs measure m | Measure.Inv ms -> checkAttribs measure ms.Range | Measure.One(m) -> checkAttribs measure m | Measure.RationalPower(measure = ms1) -> checkAttribs measure ms1.Range - | Measure.Prod(measure1= ms1; measure2= ms2) -> + | Measure.Prod(measure1 = ms1; measure2 = ms2) -> checkAttribs ms1 ms1.Range checkAttribs ms2 ms2.Range | Measure.Var(typar) -> checkAttribs measure typar.Range @@ -535,67 +566,83 @@ let CheckUnitOfMeasureAttributes g (measure: Measure) = let CheckMethInfoAttributes g m tyargsOpt (minfo: MethInfo) = trackErrors { match stripTyEqns g minfo.ApparentEnclosingAppType with - | TType_app(tcref, _, _) -> do! CheckEntityAttributes g tcref m + | TType_app(tcref, _, _) -> do! CheckEntityAttributes g tcref m | _ -> () let search = - BindMethInfoAttributes m minfo - (fun ilAttribs -> Some(CheckILAttributes g false ilAttribs m)) - (fun fsAttribs -> + BindMethInfoAttributes + m + minfo + (fun ilAttribs -> Some(CheckILAttributes g false ilAttribs m)) + (fun fsAttribs -> let res = trackErrors { - do! CheckFSharpAttributes g fsAttribs m - if Option.isNone tyargsOpt && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs then - do! ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName), m)) + do! CheckFSharpAttributes g fsAttribs m + + if + Option.isNone tyargsOpt + && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs + then + do! ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments (minfo.LogicalName), m)) } - - Some res) + + Some res) #if !NO_TYPEPROVIDERS - (fun provAttribs -> Some (CheckProvidedAttributes g m provAttribs)) + (fun provAttribs -> Some(CheckProvidedAttributes g m provAttribs)) #else (fun _provAttribs -> None) -#endif +#endif match search with | Some res -> do! res - | None -> () // no attribute = no errors -} + | None -> () // no attribute = no errors + } -/// Indicate if a method has 'Obsolete', 'CompilerMessageAttribute' or 'TypeProviderEditorHideMethodsAttribute'. +/// Indicate if a method has 'Obsolete', 'CompilerMessageAttribute' or 'TypeProviderEditorHideMethodsAttribute'. /// Used to suppress the item in intellisense. -let MethInfoIsUnseen g (m: range) (ty: TType) minfo = - let isUnseenByObsoleteAttrib () = - match BindMethInfoAttributes m minfo - (fun ilAttribs -> Some(CheckILAttributesForUnseen g ilAttribs m)) +let MethInfoIsUnseen g (m: range) (ty: TType) minfo = + let isUnseenByObsoleteAttrib () = + match + BindMethInfoAttributes + m + minfo + (fun ilAttribs -> Some(CheckILAttributesForUnseen g ilAttribs m)) (fun fsAttribs -> Some(CheckFSharpAttributesForUnseen g fsAttribs m)) #if !NO_TYPEPROVIDERS (fun provAttribs -> Some(CheckProvidedAttributesForUnseen provAttribs m)) #else (fun _provAttribs -> None) #endif - with + with | Some res -> res | None -> false - let isUnseenByHidingAttribute () = + let isUnseenByHidingAttribute () = #if !NO_TYPEPROVIDERS - not (isObjTyAnyNullness g ty) && - isAppTy g ty && - isObjTyAnyNullness g minfo.ApparentEnclosingType && - let tcref = tcrefOfAppTy g ty - match tcref.TypeReprInfo with - | TProvidedTypeRepr info -> - info.ProvidedType.PUntaint((fun st -> (st :> IProvidedCustomAttributeProvider).GetHasTypeProviderEditorHideMethodsAttribute(info.ProvidedType.TypeProvider.PUntaintNoFailure(id))), m) - | _ -> - // This attribute check is done by name to ensure compilation doesn't take a dependency - // on Microsoft.FSharp.Core.CompilerServices.TypeProviderEditorHideMethodsAttribute. - // - // We are only interested in filtering out the method on System.Object, so it is sufficient - // just to look at the attributes on IL methods. - if tcref.IsILTycon then - tcref.ILTyconRawMetadata.CustomAttrs.AsArray() - |> Array.exists (fun attr -> attr.Method.DeclaringType.TypeSpec.Name = !! typeof.FullName) - else - false + not (isObjTyAnyNullness g ty) + && isAppTy g ty + && isObjTyAnyNullness g minfo.ApparentEnclosingType + && let tcref = tcrefOfAppTy g ty in + + match tcref.TypeReprInfo with + | TProvidedTypeRepr info -> + info.ProvidedType.PUntaint( + (fun st -> + (st :> IProvidedCustomAttributeProvider) + .GetHasTypeProviderEditorHideMethodsAttribute(info.ProvidedType.TypeProvider.PUntaintNoFailure(id))), + m + ) + | _ -> + // This attribute check is done by name to ensure compilation doesn't take a dependency + // on Microsoft.FSharp.Core.CompilerServices.TypeProviderEditorHideMethodsAttribute. + // + // We are only interested in filtering out the method on System.Object, so it is sufficient + // just to look at the attributes on IL methods. + if tcref.IsILTycon then + tcref.ILTyconRawMetadata.CustomAttrs.AsArray() + |> Array.exists (fun attr -> + attr.Method.DeclaringType.TypeSpec.Name = !!typeof.FullName) + else + false #else ty |> ignore false @@ -605,67 +652,74 @@ let MethInfoIsUnseen g (m: range) (ty: TType) minfo = /// Indicate if a property has 'Obsolete' or 'CompilerMessageAttribute'. /// Used to suppress the item in intellisense. -let PropInfoIsUnseen m pinfo = +let PropInfoIsUnseen m pinfo = match pinfo with - | ILProp (ILPropInfo(_, pdef) as ilpinfo) -> + | ILProp(ILPropInfo(_, pdef) as ilpinfo) -> // Properties on .NET tuple types are resolvable but unseen - isAnyTupleTy pinfo.TcGlobals ilpinfo.ILTypeInfo.ToType || - CheckILAttributesForUnseen pinfo.TcGlobals pdef.CustomAttrs m - | FSProp (g, _, Some vref, _) - | FSProp (g, _, _, Some vref) -> CheckFSharpAttributesForUnseen g vref.Attribs m + isAnyTupleTy pinfo.TcGlobals ilpinfo.ILTypeInfo.ToType + || CheckILAttributesForUnseen pinfo.TcGlobals pdef.CustomAttrs m + | FSProp(g, _, Some vref, _) + | FSProp(g, _, _, Some vref) -> CheckFSharpAttributesForUnseen g vref.Attribs m | FSProp _ -> failwith "CheckPropInfoAttributes: unreachable" #if !NO_TYPEPROVIDERS - | ProvidedProp (_amap, pi, m) -> - CheckProvidedAttributesForUnseen (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) m + | ProvidedProp(_amap, pi, m) -> CheckProvidedAttributesForUnseen (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)), m)) m #endif /// Check the attributes on a union case, returning errors and warnings as data. -let CheckUnionCaseAttributes g (x:UnionCaseRef) m = +let CheckUnionCaseAttributes g (x: UnionCaseRef) m = trackErrors { do! CheckEntityAttributes g x.TyconRef m do! CheckFSharpAttributes g x.Attribs m } /// Check the attributes on a record field, returning errors and warnings as data. -let CheckRecdFieldAttributes g (x:RecdFieldRef) m = +let CheckRecdFieldAttributes g (x: RecdFieldRef) m = trackErrors { - do! CheckEntityAttributes g x.TyconRef m + do! CheckEntityAttributes g x.TyconRef m do! CheckFSharpAttributes g x.PropertyAttribs m do! CheckFSharpAttributes g x.RecdField.FieldAttribs m } /// Check the attributes on an F# value, returning errors and warnings as data. -let CheckValAttributes g (x:ValRef) m = - CheckFSharpAttributes g x.Attribs m +let CheckValAttributes g (x: ValRef) m = CheckFSharpAttributes g x.Attribs m /// Check the attributes on a record field, returning errors and warnings as data. -let CheckRecdFieldInfoAttributes g (x:RecdFieldInfo) m = +let CheckRecdFieldInfoAttributes g (x: RecdFieldInfo) m = CheckRecdFieldAttributes g x.RecdFieldRef m // Identify any security attributes -let IsSecurityAttribute (g: TcGlobals) amap (casmap : IDictionary) (Attrib(tcref, _, _, _, _, _, _)) m = +let IsSecurityAttribute (g: TcGlobals) amap (casmap: IDictionary) (Attrib(tcref, _, _, _, _, _, _)) m = // There's no CAS on Silverlight, so we have to be careful here match g.attrib_SecurityAttribute with | None -> false | Some attr -> match attr.TyconRef.TryDeref with - | ValueSome _ -> + | ValueSome _ -> let tcs = tcref.Stamp + match casmap.TryGetValue tcs with | true, c -> c | _ -> - let exists = ExistsInEntireHierarchyOfType (fun t -> typeEquiv g t (mkWoNullAppTy attr.TyconRef [])) g amap m AllowMultiIntfInstantiations.Yes (mkWoNullAppTy tcref []) + let exists = + ExistsInEntireHierarchyOfType + (fun t -> typeEquiv g t (mkWoNullAppTy attr.TyconRef [])) + g + amap + m + AllowMultiIntfInstantiations.Yes + (mkWoNullAppTy tcref []) + casmap[tcs] <- exists exists - | ValueNone -> false + | ValueNone -> false let IsSecurityCriticalAttribute g (Attrib(tcref, _, _, _, _, _, _)) = - (tyconRefEq g tcref g.attrib_SecurityCriticalAttribute.TyconRef || tyconRefEq g tcref g.attrib_SecuritySafeCriticalAttribute.TyconRef) + (tyconRefEq g tcref g.attrib_SecurityCriticalAttribute.TyconRef + || tyconRefEq g tcref g.attrib_SecuritySafeCriticalAttribute.TyconRef) // Identify any AssemblyVersion attributes let IsAssemblyVersionAttribute (g: TcGlobals) (Attrib(tcref, _, _, _, _, _, _)) = match g.TryFindSysAttrib("System.Reflection.AssemblyVersionAttribute") with | None -> false - | Some attr -> - attr.TyconRef.CompiledRepresentationForNamedType.QualifiedName = tcref.CompiledRepresentationForNamedType.QualifiedName + | Some attr -> attr.TyconRef.CompiledRepresentationForNamedType.QualifiedName = tcref.CompiledRepresentationForNamedType.QualifiedName diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fs b/src/Compiler/Checking/AugmentWithHashCompare.fs index b2e2eaf9be7..28634827610 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fs +++ b/src/Compiler/Checking/AugmentWithHashCompare.fs @@ -15,7 +15,14 @@ open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TypeHierarchy let mkIComparableCompareToSlotSig (g: TcGlobals) = - TSlotSig("CompareTo", g.mk_IComparable_ty, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty_withNulls, false, false, false, []) ] ], Some g.int_ty) + TSlotSig( + "CompareTo", + g.mk_IComparable_ty, + [], + [], + [ [ TSlotParam(Some("obj"), g.obj_ty_withNulls, false, false, false, []) ] ], + Some g.int_ty + ) let mkGenericIComparableCompareToSlotSig (g: TcGlobals) ty = TSlotSig( @@ -79,7 +86,14 @@ let mkGetHashCodeSlotSig (g: TcGlobals) = TSlotSig("GetHashCode", g.obj_ty_noNulls, [], [], [ [] ], Some g.int_ty) let mkEqualsSlotSig (g: TcGlobals) = - TSlotSig("Equals", g.obj_ty_noNulls, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty_withNulls, false, false, false, []) ] ], Some g.bool_ty) + TSlotSig( + "Equals", + g.obj_ty_noNulls, + [], + [], + [ [ TSlotParam(Some("obj"), g.obj_ty_withNulls, false, false, false, []) ] ], + Some g.bool_ty + ) //------------------------------------------------------------------------- // Helpers associated with code-generation of comparison/hash augmentations @@ -386,8 +400,8 @@ let mkRecdEqualityWithComparer g tcref (tycon: Tycon) thise thatobje (thatv, tha let expr = mkBindThatAddr g m ty thataddrv thatv thate expr - let expr = - if isexact then + let expr = + if isexact then expr else mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) @@ -395,11 +409,10 @@ let mkRecdEqualityWithComparer g tcref (tycon: Tycon) thise thatobje (thatv, tha let expr = if tycon.IsStructOrEnumTycon then expr + else if isexact then + mkBindThatNullEquals g m thise thate expr else - if isexact then - mkBindThatNullEquals g m thise thate expr - else - mkBindThisNullEquals g m thise thatobje expr + mkBindThisNullEquals g m thise thatobje expr expr @@ -464,20 +477,19 @@ let mkExnEqualityWithComparer g exnref (exnc: Tycon) thise thatobje (thatv, that let expr = mkBindThatAddr g m g.exn_ty thataddrv thatv thate expr - let expr = + let expr = if isexact then expr - else + else mkIsInstConditional g m g.exn_ty thatobje thatv expr (mkFalse g m) let expr = if exnc.IsStructOrEnumTycon then expr + else if isexact then + mkBindThatNullEquals g m thise thate expr else - if isexact then - mkBindThatNullEquals g m thise thate expr - else - mkBindThisNullEquals g m thise thatobje expr + mkBindThisNullEquals g m thise thatobje expr expr @@ -865,7 +877,7 @@ let mkUnionEqualityWithComparer g tcref (tycon: Tycon) thise thatobje (thatv, th let expr = mkBindThatAddr g m ty thataddrv thatv thate expr - let expr = + let expr = if isexact then expr else @@ -874,11 +886,10 @@ let mkUnionEqualityWithComparer g tcref (tycon: Tycon) thise thatobje (thatv, th let expr = if tycon.IsStructOrEnumTycon then expr + else if isexact then + mkBindThatNullEquals g m thise thate expr else - if isexact then - mkBindThatNullEquals g m thise thate expr - else - mkBindThisNullEquals g m thise thatobje expr + mkBindThisNullEquals g m thise thatobje expr expr @@ -1041,7 +1052,7 @@ let getAugmentationAttribs g (tycon: Tycon) = TryFindFSharpBoolAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs [] -type EqualityWithComparerAugmentation = +type EqualityWithComparerAugmentation = { GetHashCode: Val GetHashCodeWithComparer: Val @@ -1369,24 +1380,27 @@ let MakeValsForEqualityWithComparerAugmentation g (tcref: TyconRef) = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg false let withEqualsExactWithComparer = - let vis = TAccess (updateSyntaxAccessForCompPath (vis.CompilationPaths) SyntaxAccess.Public) + let vis = + TAccess(updateSyntaxAccessForCompPath (vis.CompilationPaths) SyntaxAccess.Public) + mkValSpec - g - tcref + g + tcref ty vis // This doesn't implement any interface. - None - "Equals" - (tps +-> (mkEqualsWithComparerTyExact g ty)) - tupArg + None + "Equals" + (tps +-> (mkEqualsWithComparerTyExact g ty)) + tupArg false + { GetHashCode = objGetHashCodeVal GetHashCodeWithComparer = withGetHashCodeVal EqualsWithComparer = withEqualsVal EqualsExactWithComparer = withEqualsExactWithComparer - } + } let MakeBindingsForCompareAugmentation g (tycon: Tycon) = let tcref = mkLocalTyconRef tycon @@ -1515,21 +1529,20 @@ let MakeBindingsForEqualityWithComparerAugmentation (g: TcGlobals) (tycon: Tycon let equalse = match withcEqualsExactValOption with | Some withcEqualsExactVal -> - mkIsInstConditional - g - m - ty - thatobje - thatv - (mkApps - g - ((exprForValRef m withcEqualsExactVal, withcEqualsExactVal.Type), - (if isNil tinst then [] else [ tinst ]), - [ thise; mkRefTupled g m [ thate; compe ] [ty; g.IEqualityComparer_ty ] ], - m)) - (mkFalse g m) - | None -> - equalsf g tcref tycon thise thatobje (thatv, thate) compe false + mkIsInstConditional + g + m + ty + thatobje + thatv + (mkApps + g + ((exprForValRef m withcEqualsExactVal, withcEqualsExactVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; mkRefTupled g m [ thate; compe ] [ ty; g.IEqualityComparer_ty ] ], + m)) + (mkFalse g m) + | None -> equalsf g tcref tycon thise thatobje (thatv, thate) compe false mkMultiLambdas g m tps [ [ thisv ]; [ thatobjv; compv ] ] (equalse, g.bool_ty) diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index 7cbca970cc3..266856aedb2 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -35,21 +35,14 @@ let TcStackGuardDepth = GetEnvInteger "FSHARP_TcStackGuardDepth" 80 #endif /// The ValReprInfo for a value, except the number of typars is not yet inferred -type PrelimValReprInfo = - | PrelimValReprInfo of - curriedArgInfos: ArgReprInfo list list * - returnInfo: ArgReprInfo +type PrelimValReprInfo = PrelimValReprInfo of curriedArgInfos: ArgReprInfo list list * returnInfo: ArgReprInfo //------------------------------------------------------------------------- // Data structures that track the gradual accumulation of information // about values and members during inference. //------------------------------------------------------------------------- -type PrelimMemberInfo = - | PrelimMemberInfo of - memberInfo: ValMemberInfo * - logicalName: string * - compiledName: string +type PrelimMemberInfo = PrelimMemberInfo of memberInfo: ValMemberInfo * logicalName: string * compiledName: string /// Indicates whether constraints should be checked when checking syntactic types type CheckConstraints = @@ -61,11 +54,7 @@ type CheckConstraints = /// /// The declared type parameters, e.g. let f<'a> (x:'a) = x, plus an indication /// of whether additional polymorphism may be inferred, e.g. let f<'a, ..> (x:'a) y = x -type ExplicitTyparInfo = - | ExplicitTyparInfo of - rigidCopyOfDeclaredTypars: Typars * - declaredTypars: Typars * - infer: bool +type ExplicitTyparInfo = ExplicitTyparInfo of rigidCopyOfDeclaredTypars: Typars * declaredTypars: Typars * infer: bool type ArgAndRetAttribs = ArgAndRetAttribs of Attribs list list * Attribs @@ -85,9 +74,9 @@ type PrelimVal1 = visibility: SynAccess option * isCompGen: bool - member x.Type = let (PrelimVal1(prelimType=ty)) = x in ty + member x.Type = let (PrelimVal1(prelimType = ty)) = x in ty - member x.Ident = let (PrelimVal1(id=id)) = x in id + member x.Ident = let (PrelimVal1(id = id)) = x in id type UnscopedTyparEnv = UnscopedTyparEnv of NameMap @@ -102,7 +91,8 @@ type TcPatPhase2Input = | TcPatPhase2Input of NameMap * bool // Get an input indicating we are no longer on the left-most path through a disjunctive "or" pattern - member x.WithRightPath() = (let (TcPatPhase2Input(a, _)) = x in TcPatPhase2Input(a, false)) + member x.WithRightPath() = + (let (TcPatPhase2Input(a, _)) = x in TcPatPhase2Input(a, false)) /// Represents information about the initialization field used to check that object constructors /// have completed before fields are accessed. @@ -110,49 +100,53 @@ type SafeInitData = | SafeInitField of RecdFieldRef * RecdField | NoSafeInitInfo -type TcPatValFlags = - | TcPatValFlags of - inlineFlag: ValInline * - explicitTyparInfo: ExplicitTyparInfo * - argAndRetAttribs: ArgAndRetAttribs * - isMutable: bool * - visibility: SynAccess option * +type TcPatValFlags = + | TcPatValFlags of + inlineFlag: ValInline * + explicitTyparInfo: ExplicitTyparInfo * + argAndRetAttribs: ArgAndRetAttribs * + isMutable: bool * + visibility: SynAccess option * isCompilerGenerated: bool /// Represents information about object constructors type CtorInfo = - { /// Object model constructors have a very specific form to satisfy .NET limitations. - /// For "new = \arg. { new C with ... }" - /// ctor = 3 indicates about to type check "\arg. (body)", - /// ctor = 2 indicates about to type check "body" - /// ctor = 1 indicates actually type checking the body expression - /// 0 indicates everywhere else, including auxiliary expressions such expr1 in "let x = expr1 in { new ... }" - /// REVIEW: clean up this rather odd approach ... - ctorShapeCounter: int - - /// A handle to the ref cell to hold results of 'this' for 'type X() as x = ...' and 'new() as x = ...' constructs - /// in case 'x' is used in the arguments to the 'inherits' call. - safeThisValOpt: Val option - - /// A handle to the boolean ref cell to hold success of initialized 'this' for 'type X() as x = ...' constructs - safeInitInfo: SafeInitData - - /// Is there an implicit constructor or an explicit one? - ctorIsImplicit: bool + { + /// Object model constructors have a very specific form to satisfy .NET limitations. + /// For "new = \arg. { new C with ... }" + /// ctor = 3 indicates about to type check "\arg. (body)", + /// ctor = 2 indicates about to type check "body" + /// ctor = 1 indicates actually type checking the body expression + /// 0 indicates everywhere else, including auxiliary expressions such expr1 in "let x = expr1 in { new ... }" + /// REVIEW: clean up this rather odd approach ... + ctorShapeCounter: int + + /// A handle to the ref cell to hold results of 'this' for 'type X() as x = ...' and 'new() as x = ...' constructs + /// in case 'x' is used in the arguments to the 'inherits' call. + safeThisValOpt: Val option + + /// A handle to the boolean ref cell to hold success of initialized 'this' for 'type X() as x = ...' constructs + safeInitInfo: SafeInitData + + /// Is there an implicit constructor or an explicit one? + ctorIsImplicit: bool } - static member InitialExplicit (safeThisValOpt, safeInitInfo) = - { ctorShapeCounter = 3 - safeThisValOpt = safeThisValOpt - safeInitInfo = safeInitInfo - ctorIsImplicit = false} - - static member InitialImplicit () = - { ctorShapeCounter = 0 - safeThisValOpt = None - safeInitInfo = NoSafeInitInfo - ctorIsImplicit = true } + static member InitialExplicit(safeThisValOpt, safeInitInfo) = + { + ctorShapeCounter = 3 + safeThisValOpt = safeThisValOpt + safeInitInfo = safeInitInfo + ctorIsImplicit = false + } + static member InitialImplicit() = + { + ctorShapeCounter = 0 + safeThisValOpt = None + safeInitInfo = NoSafeInitInfo + ctorIsImplicit = true + } /// Represents an item in the environment that may restrict the automatic generalization of later /// declarations because it refers to type inference variables. As type inference progresses @@ -173,11 +167,13 @@ type UngeneralizableItem(computeFreeTyvars: unit -> FreeTyvars) = let mutable cachedFreeTraitSolutions = emptyFreeLocals member _.GetFreeTyvars() = - let fvs = computeFreeTyvars() + let fvs = computeFreeTyvars () + if fvs.FreeTypars.IsEmpty then willNeverHaveFreeTypars <- true cachedFreeLocalTycons <- fvs.FreeTycons cachedFreeTraitSolutions <- fvs.FreeTraitSolutions + fvs member _.WillNeverHaveFreeTypars = willNeverHaveFreeTypars @@ -191,63 +187,64 @@ type UngeneralizableItem(computeFreeTyvars: unit -> FreeTyvars) = /// and other information about the scope. [] type TcEnv = - { /// Name resolution information - eNameResEnv: NameResolutionEnv - - /// The list of items in the environment that may contain free inference - /// variables (which may not be generalized). The relevant types may - /// change as a result of inference equations being asserted, hence may need to - /// be recomputed. - eUngeneralizableItems: UngeneralizableItem list - - // Two (!) versions of the current module path - // These are used to: - // - Look up the appropriate point in the corresponding signature - // see if an item is public or not - // - Change fslib canonical module type to allow compiler references to these items - // - Record the cpath for concrete modul_specs, tycon_specs and excon_specs so they can cache their generated IL representation where necessary - // - Record the pubpath of public, concrete {val, tycon, modul, excon}_specs. - // This information is used mainly when building non-local references - // to public items. - // - // Of the two, 'ePath' is the one that's barely used. It's only - // used by UpdateAccModuleOrNamespaceType to modify the CCU while compiling FSharp.Core - ePath: Ident list - - eCompPath: CompilationPath - - eAccessPath: CompilationPath - - /// This field is computed from other fields, but we amortize the cost of computing it. - eAccessRights: AccessorDomain - - /// Internals under these should be accessible - eInternalsVisibleCompPaths: CompilationPath list - - /// Mutable accumulator for the current module type - eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref - - /// Context information for type checker - eContextInfo: ContextInfo - - /// Here Some tcref indicates we can access protected members in all super types - eFamilyType: TyconRef option - - // Information to enforce special restrictions on valid expressions - // for .NET constructors. - eCtorInfo: CtorInfo option - - eCallerMemberName: string option - - // Active arg infos in iterated lambdas , allowing us to determine the attributes of arguments - eLambdaArgInfos: ArgReprInfo list list - - // Do we lay down an implicit debug point? - eIsControlFlow: bool - - // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. - // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : HashMultiMap + { + /// Name resolution information + eNameResEnv: NameResolutionEnv + + /// The list of items in the environment that may contain free inference + /// variables (which may not be generalized). The relevant types may + /// change as a result of inference equations being asserted, hence may need to + /// be recomputed. + eUngeneralizableItems: UngeneralizableItem list + + // Two (!) versions of the current module path + // These are used to: + // - Look up the appropriate point in the corresponding signature + // see if an item is public or not + // - Change fslib canonical module type to allow compiler references to these items + // - Record the cpath for concrete modul_specs, tycon_specs and excon_specs so they can cache their generated IL representation where necessary + // - Record the pubpath of public, concrete {val, tycon, modul, excon}_specs. + // This information is used mainly when building non-local references + // to public items. + // + // Of the two, 'ePath' is the one that's barely used. It's only + // used by UpdateAccModuleOrNamespaceType to modify the CCU while compiling FSharp.Core + ePath: Ident list + + eCompPath: CompilationPath + + eAccessPath: CompilationPath + + /// This field is computed from other fields, but we amortize the cost of computing it. + eAccessRights: AccessorDomain + + /// Internals under these should be accessible + eInternalsVisibleCompPaths: CompilationPath list + + /// Mutable accumulator for the current module type + eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref + + /// Context information for type checker + eContextInfo: ContextInfo + + /// Here Some tcref indicates we can access protected members in all super types + eFamilyType: TyconRef option + + // Information to enforce special restrictions on valid expressions + // for .NET constructors. + eCtorInfo: CtorInfo option + + eCallerMemberName: string option + + // Active arg infos in iterated lambdas , allowing us to determine the attributes of arguments + eLambdaArgInfos: ArgReprInfo list list + + // Do we lay down an implicit debug point? + eIsControlFlow: bool + + // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. + // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. + eCachedImplicitYieldExpressions: HashMultiMap } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv @@ -261,121 +258,149 @@ type TcEnv = /// Represents the compilation environment for typechecking a single file in an assembly. [] type TcFileState = - { g: TcGlobals + { + g: TcGlobals - /// Push an entry every time a recursive value binding is used, - /// in order to be able to fix up recursive type applications as - /// we infer type parameters - mutable recUses: ValMultiMap + /// Push an entry every time a recursive value binding is used, + /// in order to be able to fix up recursive type applications as + /// we infer type parameters + mutable recUses: ValMultiMap - /// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached - stackGuard: StackGuard + /// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached + stackGuard: StackGuard - /// Set to true if this file causes the creation of generated provided types. - mutable createsGeneratedProvidedTypes: bool + /// Set to true if this file causes the creation of generated provided types. + mutable createsGeneratedProvidedTypes: bool - /// Are we in a script? if so relax the reporting of discarded-expression warnings at the top level - isScript: bool + /// Are we in a script? if so relax the reporting of discarded-expression warnings at the top level + isScript: bool - /// Environment needed to convert IL types to F# types in the importer. - amap: Import.ImportMap + /// Environment needed to convert IL types to F# types in the importer. + amap: Import.ImportMap - /// Used to generate new syntactic argument names in post-parse syntactic processing - synArgNameGenerator: SynArgNameGenerator + /// Used to generate new syntactic argument names in post-parse syntactic processing + synArgNameGenerator: SynArgNameGenerator - tcSink: TcResultsSink + tcSink: TcResultsSink - /// Holds a reference to the component being compiled. - /// This field is very rarely used (mainly when fixing up forward references to fslib. - thisCcu: CcuThunk + /// Holds a reference to the component being compiled. + /// This field is very rarely used (mainly when fixing up forward references to fslib. + thisCcu: CcuThunk - /// Holds the current inference constraints - css: ConstraintSolverState + /// Holds the current inference constraints + css: ConstraintSolverState - /// Are we compiling the signature of a module from fslib? - compilingCanonicalFslibModuleType: bool + /// Are we compiling the signature of a module from fslib? + compilingCanonicalFslibModuleType: bool - /// Is this a .fsi file? - isSig: bool + /// Is this a .fsi file? + isSig: bool - /// Does this .fs file have a .fsi file? - haveSig: bool + /// Does this .fs file have a .fsi file? + haveSig: bool - /// Used to generate names - niceNameGen: NiceNameGenerator + /// Used to generate names + niceNameGen: NiceNameGenerator - /// Used to read and cache information about types and members - infoReader: InfoReader + /// Used to read and cache information about types and members + infoReader: InfoReader - /// Used to resolve names - nameResolver: NameResolver + /// Used to resolve names + nameResolver: NameResolver - /// The set of active conditional defines. The value is None when conditional erasure is disabled in tooling. - conditionalDefines: string list option + /// The set of active conditional defines. The value is None when conditional erasure is disabled in tooling. + conditionalDefines: string list option - namedDebugPointsForInlinedCode: Dictionary + namedDebugPointsForInlinedCode: Dictionary - isInternalTestSpanStackReferring: bool + isInternalTestSpanStackReferring: bool - diagnosticOptions: FSharpDiagnosticOptions + diagnosticOptions: FSharpDiagnosticOptions - argInfoCache: ConcurrentDictionary<(string * range), ArgReprInfo> + argInfoCache: ConcurrentDictionary<(string * range), ArgReprInfo> - // forward call - TcPat: WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv + // forward call + TcPat: + WarnOnUpperFlag + -> TcFileState + -> TcEnv + -> PrelimValReprInfo option + -> TcPatValFlags + -> TcPatLinearEnv + -> TType + -> SynPat + -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv - // forward call - TcSimplePats: TcFileState -> bool -> CheckConstraints -> TType -> TcEnv -> TcPatLinearEnv -> SynSimplePats -> string list * TcPatLinearEnv + // forward call + TcSimplePats: + TcFileState -> bool -> CheckConstraints -> TType -> TcEnv -> TcPatLinearEnv -> SynSimplePats -> string list * TcPatLinearEnv - // forward call - TcSequenceExpressionEntry: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv + // forward call + TcSequenceExpressionEntry: + TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv - // forward call - TcArrayOrListComputedExpression: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv + // forward call + TcArrayOrListComputedExpression: + TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv - // forward call - TcComputationExpression: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv + // forward call + TcComputationExpression: + TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv } /// Create a new compilation environment static member Create - (g, isScript, amap, thisCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal, isInternalTestSpanStackReferring, diagnosticOptions, - tcPat, - tcSimplePats, - tcSequenceExpressionEntry, - tcArrayOrListSequenceExpression, - tcComputationExpression) = + ( + g, + isScript, + amap, + thisCcu, + isSig, + haveSig, + conditionalDefines, + tcSink, + tcVal, + isInternalTestSpanStackReferring, + diagnosticOptions, + tcPat, + tcSimplePats, + tcSequenceExpressionEntry, + tcArrayOrListSequenceExpression, + tcComputationExpression + ) = let niceNameGen = NiceNameGenerator() let infoReader = InfoReader(g, amap) let instantiationGenerator m tpsorig = FreshenTypars g m tpsorig let nameResolver = NameResolver(g, amap, infoReader, instantiationGenerator) - { g = g - amap = amap - recUses = ValMultiMap<_>.Empty - stackGuard = StackGuard(TcStackGuardDepth, "TcFileState") - createsGeneratedProvidedTypes = false - thisCcu = thisCcu - isScript = isScript - css = ConstraintSolverState.New(g, amap, infoReader, tcVal) - infoReader = infoReader - tcSink = tcSink - nameResolver = nameResolver - niceNameGen = niceNameGen - synArgNameGenerator = SynArgNameGenerator() - isSig = isSig - haveSig = haveSig - namedDebugPointsForInlinedCode = Dictionary() - compilingCanonicalFslibModuleType = (isSig || not haveSig) && g.compilingFSharpCore - conditionalDefines = conditionalDefines - isInternalTestSpanStackReferring = isInternalTestSpanStackReferring - diagnosticOptions = diagnosticOptions - argInfoCache = ConcurrentDictionary() - TcPat = tcPat - TcSimplePats = tcSimplePats - TcSequenceExpressionEntry = tcSequenceExpressionEntry - TcArrayOrListComputedExpression = tcArrayOrListSequenceExpression - TcComputationExpression = tcComputationExpression + + { + g = g + amap = amap + recUses = ValMultiMap<_>.Empty + stackGuard = StackGuard(TcStackGuardDepth, "TcFileState") + createsGeneratedProvidedTypes = false + thisCcu = thisCcu + isScript = isScript + css = ConstraintSolverState.New(g, amap, infoReader, tcVal) + infoReader = infoReader + tcSink = tcSink + nameResolver = nameResolver + niceNameGen = niceNameGen + synArgNameGenerator = SynArgNameGenerator() + isSig = isSig + haveSig = haveSig + namedDebugPointsForInlinedCode = Dictionary() + compilingCanonicalFslibModuleType = (isSig || not haveSig) && g.compilingFSharpCore + conditionalDefines = conditionalDefines + isInternalTestSpanStackReferring = isInternalTestSpanStackReferring + diagnosticOptions = diagnosticOptions + argInfoCache = ConcurrentDictionary() + TcPat = tcPat + TcSimplePats = tcSimplePats + TcSequenceExpressionEntry = tcSequenceExpressionEntry + TcArrayOrListComputedExpression = tcArrayOrListSequenceExpression + TcComputationExpression = tcComputationExpression } override _.ToString() = "" diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 3d5e9e4ec91..592114c1c8e 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -61,6 +61,7 @@ type UnionReprDecisions<'Union, 'Alt, 'Type> getAlternatives: 'Union -> 'Alt[], nullPermitted: 'Union -> bool, isNullary: 'Alt -> bool, + isList: 'Union -> bool, isStruct: 'Union -> bool, nameOfAlt: 'Alt -> string, diff --git a/src/Compiler/Optimize/DetupleArgs.fs b/src/Compiler/Optimize/DetupleArgs.fs index f4521fa0e09..3fb69e82ca2 100644 --- a/src/Compiler/Optimize/DetupleArgs.fs +++ b/src/Compiler/Optimize/DetupleArgs.fs @@ -148,7 +148,6 @@ let DetupleRewriteStackGuardDepth = StackGuard.GetDepthOption "DetupleRewrite" // no longer can assume that all call sites have explicit tuples if collapsing. // in these new cases, take care to have let binding sequence (eval order...) - // Merge a tyapp node and app node. [] let (|TyappAndApp|_|) e = @@ -167,7 +166,8 @@ module GlobalUsageAnalysis = let GetValsBoundInExpr expr = let folder = { ExprFolder0 with - valBindingSiteIntercept = bindAccBounds } + valBindingSiteIntercept = bindAccBounds + } let z0 = Zset.empty valOrder let z = FoldExpr folder z0 expr @@ -200,12 +200,14 @@ module GlobalUsageAnalysis = } let z0 = - { Uses = Zmap.empty valOrder - Defns = Zmap.empty valOrder - RecursiveBindings = Zmap.empty valOrder - DecisionTreeBindings = Zset.empty valOrder - TopLevelBindings = Zset.empty valOrder - IterationIsAtTopLevel = true } + { + Uses = Zmap.empty valOrder + Defns = Zmap.empty valOrder + RecursiveBindings = Zmap.empty valOrder + DecisionTreeBindings = Zset.empty valOrder + TopLevelBindings = Zset.empty valOrder + IterationIsAtTopLevel = true + } /// Log the use of a value with a particular tuple shape at a callsite /// Note: this routine is called very frequently @@ -214,21 +216,24 @@ module GlobalUsageAnalysis = Uses = match Zmap.tryFind f z.Uses with | Some sites -> Zmap.add f (tup :: sites) z.Uses - | None -> Zmap.add f [ tup ] z.Uses } + | None -> Zmap.add f [ tup ] z.Uses + } /// Log the definition of a binding let logBinding z (isInDTree, v) = let z = if isInDTree then { z with - DecisionTreeBindings = Zset.add v z.DecisionTreeBindings } + DecisionTreeBindings = Zset.add v z.DecisionTreeBindings + } else z let z = if z.IterationIsAtTopLevel then { z with - TopLevelBindings = Zset.add v z.TopLevelBindings } + TopLevelBindings = Zset.add v z.TopLevelBindings + } else z @@ -241,7 +246,8 @@ module GlobalUsageAnalysis = { z with RecursiveBindings = Zmap.add v (false, vs) z.RecursiveBindings - Defns = Zmap.add v bind.Expr z.Defns } + Defns = Zmap.add v bind.Expr z.Defns + } /// Log the definition of a recursive binding let logRecBindings z binds = @@ -253,7 +259,8 @@ module GlobalUsageAnalysis = ||> List.fold (fun mubinds v -> Zmap.add v (true, vs) mubinds) Defns = (z.Defns, binds) - ||> List.fold (fun eqns bind -> Zmap.add bind.Var bind.Expr eqns) } + ||> List.fold (fun eqns bind -> Zmap.add bind.Var bind.Expr eqns) + } /// Work locally under a lambda of some kind let foldUnderLambda f z x = @@ -336,7 +343,8 @@ module GlobalUsageAnalysis = recBindingsIntercept = logRecBindings valBindingSiteIntercept = logBinding targetIntercept = targetIntercept - tmethodIntercept = tmethodIntercept } + tmethodIntercept = tmethodIntercept + } //------------------------------------------------------------------------- // GlobalUsageAnalysis - entry point @@ -406,8 +414,7 @@ let checkTS = /// explicit tuple-structure in expr let rec uncheckedExprTS expr = match expr with - | Expr.Op(TOp.Tuple tupInfo, _tys, args, _) when not (evalTupInfoIsStruct tupInfo) -> - TupleTS(List.map uncheckedExprTS args) + | Expr.Op(TOp.Tuple tupInfo, _tys, args, _) when not (evalTupInfoIsStruct tupInfo) -> TupleTS(List.map uncheckedExprTS args) | _ -> UnknownTS let rec uncheckedTypeTS g ty = @@ -490,10 +497,11 @@ type TransformedFormal = /// - yb1..ybp - replacement formal choices for x1...xp. /// - transformedVal - replaces f. type Transform = - { transformCallPattern: CallPattern - transformedFormals: TransformedFormal list - transformedVal: Val } - + { + transformCallPattern: CallPattern + transformedFormals: TransformedFormal list + transformedVal: Val + } //------------------------------------------------------------------------- // transform - mkTransform - decided, create necessary stuff @@ -535,14 +543,7 @@ let mkTransform g (f: Val) m tps x1Ntys retTy (callPattern, tyfringes: (TType li let valReprInfo = match f.ValReprInfo with | None -> None - | _ -> - Some( - ValReprInfo( - ValReprInfo.InferTyparInfo tps, - List.collect ValReprInfoForTS callPattern, - ValReprInfo.unnamedRetVal - ) - ) + | _ -> Some(ValReprInfo(ValReprInfo.InferTyparInfo tps, List.collect ValReprInfoForTS callPattern, ValReprInfo.unnamedRetVal)) (* type(transformedVal) tyfringes types replace initial arg types of f *) let tys1r = List.collect fst tyfringes (* types for collapsed initial r args *) let tysrN = List.skip tyfringes.Length x1Ntys (* types for remaining args *) @@ -559,10 +560,11 @@ let mkTransform g (f: Val) m tps x1Ntys retTy (callPattern, tyfringes: (TType li fCty valReprInfo - { transformCallPattern = callPattern - transformedFormals = transformedFormals - transformedVal = transformedVal } - + { + transformCallPattern = callPattern + transformedFormals = transformedFormals + transformedVal = transformedVal + } //------------------------------------------------------------------------- // transform - vTransforms - support @@ -669,7 +671,6 @@ let decideTransform g z v callPatterns (m, tps, vss: Val list list, retTy) = else Some(v, mkTransform g v m tps tys retTy (callPattern, tyfringes)) - //------------------------------------------------------------------------- // transform - determineTransforms //------------------------------------------------------------------------- @@ -717,9 +718,10 @@ let determineTransforms g (z: GlobalUsageAnalysis.Results) = type penv = { // The planned transforms - transforms: Zmap - ccu: CcuThunk - g: TcGlobals } + transforms: Zmap + ccu: CcuThunk + g: TcGlobals + } let hasTransform penv f = Zmap.tryFind f penv.transforms @@ -734,11 +736,13 @@ let hasTransform penv f = Zmap.tryFind f penv.transforms *) type env = - { eg: TcGlobals + { + eg: TcGlobals - prefix: string + prefix: string - m: range } + m: range + } override _.ToString() = "" @@ -859,7 +863,6 @@ let transRebind ybi xi = | [ u ], NewArgs(_vs, x) -> [ mkCompGenBind u x ] | us, NewArgs(_vs, x) -> List.map2 mkCompGenBind us (tryDestRefTupleExpr x) - //------------------------------------------------------------------------- // pass - mubinds //------------------------------------------------------------------------- @@ -939,11 +942,13 @@ let postTransformExpr (penv: penv) expr = let passImplFile penv assembly = let rwenv = - { PreIntercept = None - PreInterceptBinding = None - PostTransform = postTransformExpr penv - RewriteQuotations = false - StackGuard = StackGuard(DetupleRewriteStackGuardDepth, "RewriteImplFile") } + { + PreIntercept = None + PreInterceptBinding = None + PostTransform = postTransformExpr penv + RewriteQuotations = false + StackGuard = StackGuard(DetupleRewriteStackGuardDepth, "RewriteImplFile") + } assembly |> RewriteImplFile rwenv @@ -960,9 +965,11 @@ let DetupleImplFile ccu g expr = // Pass over term, rewriting bindings and fixing up call sites, under penv let penv = - { g = g - transforms = vtrans - ccu = ccu } + { + g = g + transforms = vtrans + ccu = ccu + } let expr = passImplFile penv expr expr diff --git a/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs b/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs index 0b1f58713ba..5e5a6b37fe5 100644 --- a/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs +++ b/src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs @@ -22,17 +22,21 @@ open FSharp.Compiler.TcGlobals let verboseTLR = false -let InnerLambdasToTopLevelFunctionsStackGuardDepth = StackGuard.GetDepthOption "InnerLambdasToTopLevelFunctions" +let InnerLambdasToTopLevelFunctionsStackGuardDepth = + StackGuard.GetDepthOption "InnerLambdasToTopLevelFunctions" //------------------------------------------------------------------------- // library helpers //------------------------------------------------------------------------- -let internalError str = dprintf "Error: %s\n" str;raise (Failure str) +let internalError str = + dprintf "Error: %s\n" str + raise (Failure str) module Zmap = - let force k mp (str, soK) = - try Zmap.find k mp + let force k mp (str, soK) = + try + Zmap.find k mp with exn -> dprintf "Zmap.force: %s %s\n" str (soK k) PreserveStackTrace exn @@ -51,12 +55,11 @@ let fringeTR tr = let rec collect tr acc = match tr with | TreeNode subts -> List.foldBack collect subts acc - | LeafNode x -> x :: acc + | LeafNode x -> x :: acc collect tr [] -let emptyTR = TreeNode[] - +let emptyTR = TreeNode [] //------------------------------------------------------------------------- // misc @@ -69,25 +72,48 @@ let emptyTR = TreeNode[] // and combined form, so this function should not be needed let destApp (f, fty, tys, args, m) = match stripExpr f with - | Expr.App (f2, fty2, tys2, [], _) -> (f2, fty2, tys2 @ tys, args, m) + | Expr.App(f2, fty2, tys2, [], _) -> (f2, fty2, tys2 @ tys, args, m) | Expr.App _ -> (f, fty, tys, args, m) (* has args, so not combine ty args *) | f -> (f, fty, tys, args, m) #if DEBUG -let showTyparSet tps = showL (commaListL (List.map typarL (Zset.elements tps))) +let showTyparSet tps = + showL (commaListL (List.map typarL (Zset.elements tps))) #endif // CLEANUP NOTE: don't like the look of this function - this distinction // should never be needed let isDelayedRepr (f: Val) e = let _tps, vss, _b, _rty = stripTopLambda (e, f.Type) - not(List.isEmpty vss) - + not (List.isEmpty vss) // REVIEW: these should just be replaced by direct calls to mkLocal, mkCompGenLocal etc. // REVIEW: However these set an arity whereas the others don't let mkLocalNameTypeArity compgen m name ty valReprInfo = - Construct.NewVal(name, m, None, ty, Immutable, compgen, valReprInfo, taccessPublic, ValNotInRecScope, None, NormalVal, [], ValInline.Optional, XmlDoc.Empty, false, false, false, false, false, false, None, ParentNone) + Construct.NewVal( + name, + m, + None, + ty, + Immutable, + compgen, + valReprInfo, + taccessPublic, + ValNotInRecScope, + None, + NormalVal, + [], + ValInline.Optional, + XmlDoc.Empty, + false, + false, + false, + false, + false, + false, + None, + ParentNone + ) //------------------------------------------------------------------------- // definitions: TLR, arity, arity-met, arity-short @@ -134,9 +160,11 @@ let mkLocalNameTypeArity compgen m name ty valReprInfo = let GetValsBoundUnderShouldInline xinfo = let accRejectFrom (v: Val) repr rejectS = - if v.InlineInfo = ValInline.Always then - Zset.union (GetValsBoundInExpr repr) rejectS - else rejectS + if v.InlineInfo = ValInline.Always then + Zset.union (GetValsBoundInExpr repr) rejectS + else + rejectS + let rejectS = Zset.empty valOrder let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS rejectS @@ -156,7 +184,16 @@ let IsRefusedTLR g (f: Val) = let alreadyChosen = f.ValReprInfo.IsSome let isResumableCode = isReturnsResumableCodeTy g f.Type let isInlineIfLambda = f.InlineIfLambda - let refuseTest = alreadyChosen || mutableVal || byrefVal || specialVal || dllImportStubOrOtherNeverInline || isResumableCode || isInlineIfLambda + + let refuseTest = + alreadyChosen + || mutableVal + || byrefVal + || specialVal + || dllImportStubOrOtherNeverInline + || isResumableCode + || isInlineIfLambda + refuseTest let IsMandatoryTopLevel (f: Val) = @@ -175,10 +212,12 @@ let IsMandatoryNonTopLevel g (f: Val) = module Pass1_DetermineTLRAndArities = let GetMaxNumArgsAtUses xinfo f = - match Zmap.tryFind f xinfo.Uses with - | None -> 0 (* no call sites *) - | Some sites -> - sites |> List.map (fun (_accessors, _tinst, args) -> List.length args) |> List.max + match Zmap.tryFind f xinfo.Uses with + | None -> 0 (* no call sites *) + | Some sites -> + sites + |> List.map (fun (_accessors, _tinst, args) -> List.length args) + |> List.max let SelectTLRVals g xinfo f e = if IsRefusedTLR g f then @@ -194,51 +233,57 @@ module Pass1_DetermineTLRAndArities = let nFormals = vss.Length let nMaxApplied = GetMaxNumArgsAtUses xinfo f let arity = Operators.min nFormals nMaxApplied - if atTopLevel then - Some (f, arity) - elif g.realsig then - None - else if arity<>0 || not (isNil tps) then - Some (f, arity) - else - None + + if atTopLevel then Some(f, arity) + elif g.realsig then None + else if arity <> 0 || not (isNil tps) then Some(f, arity) + else None /// Check if f involves any value recursion (so can skip those). /// ValRec considered: recursive && some f in mutual binding is not bound to a lambda let IsValueRecursionFree xinfo f = - let hasDelayedRepr f = isDelayedRepr f (Zmap.force f xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr", nameOfVal)) - let isRecursive, mudefs = Zmap.force f xinfo.RecursiveBindings ("IsValueRecursionFree", nameOfVal) + let hasDelayedRepr f = + isDelayedRepr f (Zmap.force f xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr", nameOfVal)) + + let isRecursive, mudefs = + Zmap.force f xinfo.RecursiveBindings ("IsValueRecursionFree", nameOfVal) + not isRecursive || List.forall hasDelayedRepr mudefs let DumpArity arityM = - let dump f n = dprintf "tlr: arity %50s = %d\n" (showL (valL f)) n + let dump f n = + dprintf "tlr: arity %50s = %d\n" (showL (valL f)) n + Zmap.iter dump arityM let DetermineTLRAndArities g expr = - let xinfo = GetUsageInfoOfImplFile g expr - let fArities = Zmap.chooseL (SelectTLRVals g xinfo) xinfo.Defns - let fArities = List.filter (fst >> IsValueRecursionFree xinfo) fArities - // Do not TLR v if it is bound under a shouldinline defn - // There is simply no point - the original value will be duplicated and TLR'd anyway - let rejectS = GetValsBoundUnderShouldInline xinfo - let fArities = List.filter (fun (v, _) -> not (Zset.contains v rejectS)) fArities - (*-*) - let tlrS = Zset.ofList valOrder (List.map fst fArities) - let topValS = xinfo.TopLevelBindings (* genuinely top level *) - let topValS = Zset.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) + let xinfo = GetUsageInfoOfImplFile g expr + let fArities = Zmap.chooseL (SelectTLRVals g xinfo) xinfo.Defns + let fArities = List.filter (fst >> IsValueRecursionFree xinfo) fArities + // Do not TLR v if it is bound under a shouldinline defn + // There is simply no point - the original value will be duplicated and TLR'd anyway + let rejectS = GetValsBoundUnderShouldInline xinfo + let fArities = List.filter (fun (v, _) -> not (Zset.contains v rejectS)) fArities + (*-*) + let tlrS = Zset.ofList valOrder (List.map fst fArities) + let topValS = xinfo.TopLevelBindings (* genuinely top level *) + let topValS = Zset.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) #if DEBUG - (* REPORT MISSED CASES *) - if verboseTLR then - let missed = Zset.diff xinfo.TopLevelBindings tlrS - missed |> Zset.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) - (* REPORT OVER *) + (* REPORT MISSED CASES *) + if verboseTLR then + let missed = Zset.diff xinfo.TopLevelBindings tlrS + + missed + |> Zset.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) + (* REPORT OVER *) #endif - let arityM = Zmap.ofList valOrder fArities + let arityM = Zmap.ofList valOrder fArities #if DEBUG - if verboseTLR then DumpArity arityM + if verboseTLR then + DumpArity arityM #endif - tlrS, topValS, arityM + tlrS, topValS, arityM (* NOTES: For constants, @@ -295,7 +340,6 @@ module Pass1_DetermineTLRAndArities = // so env(f) may be properly inside env(h), // so better not have env(h) in env(f)!!!]. - /// The subset of ids from a mutual binding that are chosen to be TLR. /// They share a common env. /// [Each fclass has an env, the fclass are the handles to envs.] @@ -305,15 +349,17 @@ type BindingGroupSharingSameReqdItems(bindings: Bindings) = member fclass.Vals = vals - member fclass.Contains (v: Val) = vset.Contains v + member fclass.Contains(v: Val) = vset.Contains v member fclass.IsEmpty = isNil vals member fclass.Pairs = vals |> List.map (fun f -> (f, fclass)) - override fclass.ToString() = "+" + String.concat "+" (List.map nameOfVal vals) + override fclass.ToString() = + "+" + String.concat "+" (List.map nameOfVal vals) -let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order valOrder) +let fclassOrder = + Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order valOrder) /// It is required to make the TLR closed wrt it's freevars (the env reqdVals0). /// For gv a generator, @@ -321,17 +367,18 @@ let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b. /// Other occurrences contribute the value gv. type ReqdItem = | ReqdSubEnv of Val - | ReqdVal of Val - override i.ToString() = - match i with - | ReqdSubEnv f -> "&" + f.LogicalName - | ReqdVal f -> f.LogicalName + | ReqdVal of Val + override i.ToString() = + match i with + | ReqdSubEnv f -> "&" + f.LogicalName + | ReqdVal f -> f.LogicalName let reqdItemOrder = - let rep = function - | ReqdSubEnv v -> struct (true, v) - | ReqdVal v -> struct (false, v) + let rep = + function + | ReqdSubEnv v -> struct (true, v) + | ReqdVal v -> struct (false, v) Order.orderOn rep (Pair.order (Bool.order, valOrder)) @@ -339,29 +386,45 @@ let reqdItemOrder = /// The reqdTypars are the free reqdTypars of the defns, and those required by any direct TLR arity-met calls. /// The reqdItems are the ids/subEnvs required from calls to freeVars. type ReqdItemsForDefn = - { + { reqdTypars: Zset reqdItems: Zset m: range } - member env.ReqdSubEnvs = [ for x in env.reqdItems do match x with | ReqdSubEnv f -> yield f | ReqdVal _ -> () ] - - member env.ReqdVals = [ for x in env.reqdItems do match x with | ReqdSubEnv _ -> () | ReqdVal v -> yield v ] - - member env.Extend (typars, items) = - {env with - reqdTypars = Zset.addList typars env.reqdTypars - reqdItems = Zset.addList items env.reqdItems} + member env.ReqdSubEnvs = + [ + for x in env.reqdItems do + match x with + | ReqdSubEnv f -> yield f + | ReqdVal _ -> () + ] + + member env.ReqdVals = + [ + for x in env.reqdItems do + match x with + | ReqdSubEnv _ -> () + | ReqdVal v -> yield v + ] + + member env.Extend(typars, items) = + { env with + reqdTypars = Zset.addList typars env.reqdTypars + reqdItems = Zset.addList items env.reqdItems + } static member Initial typars m = - {reqdTypars = Zset.addList typars (Zset.empty typarOrder) - reqdItems = Zset.empty reqdItemOrder - m = m } + { + reqdTypars = Zset.addList typars (Zset.empty typarOrder) + reqdItems = Zset.empty reqdItemOrder + m = m + } override env.ToString() = - (showL (commaListL (List.map typarL (Zset.elements env.reqdTypars)))) + "--" + - (String.concat ", " (List.map string (Zset.elements env.reqdItems))) + (showL (commaListL (List.map typarL (Zset.elements env.reqdTypars)))) + + "--" + + (String.concat ", " (List.map string (Zset.elements env.reqdItems))) //------------------------------------------------------------------------- // pass2: collector - state @@ -370,7 +433,7 @@ type ReqdItemsForDefn = type Generators = Zset /// check a named function value applied to sufficient arguments -let IsArityMet (vref: ValRef) wf (tys: TypeInst) args = +let IsArityMet (vref: ValRef) wf (tys: TypeInst) args = (tys.Length = vref.Typars.Length) && (wf <= List.length args) module Pass2_DetermineReqdItems = @@ -410,7 +473,6 @@ module Pass2_DetermineReqdItems = // fix up reqdTypars(-) according to direct call dependencies. // - /// This state collects: /// reqdItemsMap - fclass -> env /// fclassM - f -> fclass @@ -432,56 +494,68 @@ module Pass2_DetermineReqdItems = } let state0 = - { stack = [] - reqdItemsMap = Zmap.empty fclassOrder - fclassM = Zmap.empty valOrder - revDeclist = [] - recShortCallS = Zset.empty valOrder } + { + stack = [] + reqdItemsMap = Zmap.empty fclassOrder + fclassM = Zmap.empty valOrder + revDeclist = [] + recShortCallS = Zset.empty valOrder + } /// PUSH = start collecting for fclass let PushFrame (fclass: BindingGroupSharingSameReqdItems) (reqdTypars0, reqdVals0, m) state = if fclass.IsEmpty then state else - {state with - revDeclist = fclass :: state.revDeclist - stack = (let env = ReqdItemsForDefn.Initial reqdTypars0 m in (fclass, reqdVals0, env) :: state.stack) } + { state with + revDeclist = fclass :: state.revDeclist + stack = (let env = ReqdItemsForDefn.Initial reqdTypars0 m in (fclass, reqdVals0, env) :: state.stack) + } /// POP & SAVE = end collecting for fclass and store - let SaveFrame (fclass: BindingGroupSharingSameReqdItems) state = - if verboseTLR then dprintf "SaveFrame: %A\n" fclass + let SaveFrame (fclass: BindingGroupSharingSameReqdItems) state = + if verboseTLR then + dprintf "SaveFrame: %A\n" fclass + if fclass.IsEmpty then state else match state.stack with - | [] -> internalError "trl: popFrame has empty stack" + | [] -> internalError "trl: popFrame has empty stack" | (fclass, _reqdVals0, env) :: stack -> (* ASSERT: same fclass *) - {state with - stack = stack - reqdItemsMap = Zmap.add fclass env state.reqdItemsMap - fclassM = List.fold (fun mp (k, v) -> Zmap.add k v mp) state.fclassM fclass.Pairs } + { state with + stack = stack + reqdItemsMap = Zmap.add fclass env state.reqdItemsMap + fclassM = List.fold (fun mp (k, v) -> Zmap.add k v mp) state.fclassM fclass.Pairs + } /// Log requirements for gv in the relevant stack frames let LogRequiredFrom gv items state = let logIntoFrame (fclass, reqdVals0: Zset, env: ReqdItemsForDefn) = - let env = - if reqdVals0.Contains gv then - env.Extend ([], items) - else env + let env = if reqdVals0.Contains gv then env.Extend([], items) else env - fclass, reqdVals0, env + fclass, reqdVals0, env - {state with stack = List.map logIntoFrame state.stack} + { state with + stack = List.map logIntoFrame state.stack + } let LogShortCall gv state = - if state.stack |> List.exists (fun (fclass, _reqdVals0, _env) -> fclass.Contains gv) then - if verboseTLR then dprintf "shortCall: rec: %s\n" gv.LogicalName - // Have short call to gv within it's (mutual) definition(s) - {state with - recShortCallS = Zset.add gv state.recShortCallS} + if + state.stack + |> List.exists (fun (fclass, _reqdVals0, _env) -> fclass.Contains gv) + then + if verboseTLR then + dprintf "shortCall: rec: %s\n" gv.LogicalName + // Have short call to gv within it's (mutual) definition(s) + { state with + recShortCallS = Zset.add gv state.recShortCallS + } else - if verboseTLR then dprintf "shortCall: not-rec: %s\n" gv.LogicalName - state + if verboseTLR then + dprintf "shortCall: not-rec: %s\n" gv.LogicalName + + state let FreeInBindings bs = let opts = CollectTyparsAndLocalsWithStackGuard() @@ -493,103 +567,118 @@ module Pass2_DetermineReqdItems = /// "app (f, tps, args)" - occurrence /// /// On intercepted nodes, must recurseF fold to collect from subexpressions. - let ExprEnvIntercept (tlrS, arityM) recurseF noInterceptF z expr = - - let accInstance z (fvref: ValRef, tps, args) = - let f = fvref.Deref - match Zmap.tryFind f arityM with - - | Some wf -> - // f is TLR with arity wf - if IsArityMet fvref wf tps args then - // arity-met call to a TLR g - LogRequiredFrom f [ReqdSubEnv f] z - else - // arity-short instance - let z = LogRequiredFrom f [ReqdVal f] z - // LogShortCall - logs recursive short calls - let z = LogShortCall f z - z - - | None -> - // f is non-TLR - LogRequiredFrom f [ReqdVal f] z - - let accBinds m z (binds: Bindings) = - let tlrBs, nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var tlrS) - // For bindings marked TLR, collect implied env - let fclass = BindingGroupSharingSameReqdItems tlrBs - // what determines env? - let frees = FreeInBindings tlrBs - // put in env - let reqdTypars0 = frees.FreeTyvars.FreeTypars |> Zset.elements - // occurrences contribute to env - let reqdVals0 = frees.FreeLocals |> Zset.elements - // tlrBs are not reqdVals0 for themselves - let reqdVals0 = reqdVals0 |> List.filter (fclass.Contains >> not) - let reqdVals0 = reqdVals0 |> Zset.ofList valOrder - // collect into env over bodies - let z = PushFrame fclass (reqdTypars0, reqdVals0,m) z - let z = (z, tlrBs) ||> List.fold (foldOn (fun b -> b.Expr) recurseF) - let z = SaveFrame fclass z - // for bindings not marked TRL, collect - let z = (z, nonTlrBs) ||> List.fold (foldOn (fun b -> b.Expr) recurseF) - z - - match expr with - | Expr.Val (v, _, _) -> - accInstance z (v, [], []) - - | Expr.Op (TOp.LValueOp (_, v), _tys, args, _) -> - let z = accInstance z (v, [], []) - List.fold recurseF z args - - | Expr.App (f, fty, tys, args, m) -> - let f, _fty, tys, args, _m = destApp (f, fty, tys, args, m) - match f with - | Expr.Val (f, _, _) -> - // YES: APP vspec tps args - log - let z = accInstance z (f, tys, args) - List.fold recurseF z args - | _ -> - // NO: app, but function is not val - no log - noInterceptF z expr - - | Expr.LetRec (binds, body, m, _) -> - let z = accBinds m z binds - recurseF z body - - | Expr.Let (bind,body,m,_) -> - let z = accBinds m z [bind] - // tailcall for linear sequences - recurseF z body - - | _ -> - noInterceptF z expr + let ExprEnvIntercept (tlrS, arityM) recurseF noInterceptF z expr = + + let accInstance z (fvref: ValRef, tps, args) = + let f = fvref.Deref + + match Zmap.tryFind f arityM with + + | Some wf -> + // f is TLR with arity wf + if IsArityMet fvref wf tps args then + // arity-met call to a TLR g + LogRequiredFrom f [ ReqdSubEnv f ] z + else + // arity-short instance + let z = LogRequiredFrom f [ ReqdVal f ] z + // LogShortCall - logs recursive short calls + let z = LogShortCall f z + z + + | None -> + // f is non-TLR + LogRequiredFrom f [ ReqdVal f ] z + + let accBinds m z (binds: Bindings) = + let tlrBs, nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var tlrS) + // For bindings marked TLR, collect implied env + let fclass = BindingGroupSharingSameReqdItems tlrBs + // what determines env? + let frees = FreeInBindings tlrBs + // put in env + let reqdTypars0 = frees.FreeTyvars.FreeTypars |> Zset.elements + // occurrences contribute to env + let reqdVals0 = frees.FreeLocals |> Zset.elements + // tlrBs are not reqdVals0 for themselves + let reqdVals0 = reqdVals0 |> List.filter (fclass.Contains >> not) + let reqdVals0 = reqdVals0 |> Zset.ofList valOrder + // collect into env over bodies + let z = PushFrame fclass (reqdTypars0, reqdVals0, m) z + let z = (z, tlrBs) ||> List.fold (foldOn (fun b -> b.Expr) recurseF) + let z = SaveFrame fclass z + // for bindings not marked TRL, collect + let z = (z, nonTlrBs) ||> List.fold (foldOn (fun b -> b.Expr) recurseF) + z + + match expr with + | Expr.Val(v, _, _) -> accInstance z (v, [], []) + + | Expr.Op(TOp.LValueOp(_, v), _tys, args, _) -> + let z = accInstance z (v, [], []) + List.fold recurseF z args + + | Expr.App(f, fty, tys, args, m) -> + let f, _fty, tys, args, _m = destApp (f, fty, tys, args, m) + + match f with + | Expr.Val(f, _, _) -> + // YES: APP vspec tps args - log + let z = accInstance z (f, tys, args) + List.fold recurseF z args + | _ -> + // NO: app, but function is not val - no log + noInterceptF z expr + + | Expr.LetRec(binds, body, m, _) -> + let z = accBinds m z binds + recurseF z body + + | Expr.Let(bind, body, m, _) -> + let z = accBinds m z [ bind ] + // tailcall for linear sequences + recurseF z body + + | _ -> noInterceptF z expr /// Initially, reqdTypars(fclass) = freetps(bodies). /// For each direct call to a gv, a generator for fclass, /// Required to include the reqdTypars(gv) in reqdTypars(fclass). let CloseReqdTypars fclassM reqdItemsMap = - if verboseTLR then dprintf "CloseReqdTypars------\n" + if verboseTLR then + dprintf "CloseReqdTypars------\n" let closeStep reqdItemsMap changed fc (env: ReqdItemsForDefn) = let directCallReqdEnvs = env.ReqdSubEnvs - let directCallReqdTypars = directCallReqdEnvs |> List.map (fun f -> - let fc = Zmap.force f fclassM ("reqdTyparsFor", nameOfVal) - let env = Zmap.force fc reqdItemsMap ("reqdTyparsFor", string) - env.reqdTypars) + + let directCallReqdTypars = + directCallReqdEnvs + |> List.map (fun f -> + let fc = Zmap.force f fclassM ("reqdTyparsFor", nameOfVal) + let env = Zmap.force fc reqdItemsMap ("reqdTyparsFor", string) + env.reqdTypars) let reqdTypars0 = env.reqdTypars let reqdTypars = List.fold Zset.union reqdTypars0 directCallReqdTypars let changed = changed || (not (Zset.equal reqdTypars0 reqdTypars)) - let env = {env with reqdTypars = reqdTypars} + let env = { env with reqdTypars = reqdTypars } #if DEBUG if verboseTLR then - dprintf "closeStep: fc=%30A nSubs=%d reqdTypars0=%s reqdTypars=%s\n" fc directCallReqdEnvs.Length (showTyparSet reqdTypars0) (showTyparSet reqdTypars) - directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall f=%s\n" f.LogicalName) - directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall fc=%A\n" (Zmap.find f fclassM)) - directCallReqdTypars |> List.iter (fun _reqdTypars -> dprintf "closeStep: dcall reqdTypars=%s\n" (showTyparSet reqdTypars0)) + dprintf + "closeStep: fc=%30A nSubs=%d reqdTypars0=%s reqdTypars=%s\n" + fc + directCallReqdEnvs.Length + (showTyparSet reqdTypars0) + (showTyparSet reqdTypars) + + directCallReqdEnvs + |> List.iter (fun f -> dprintf "closeStep: dcall f=%s\n" f.LogicalName) + + directCallReqdEnvs + |> List.iter (fun f -> dprintf "closeStep: dcall fc=%A\n" (Zmap.find f fclassM)) + + directCallReqdTypars + |> List.iter (fun _reqdTypars -> dprintf "closeStep: dcall reqdTypars=%s\n" (showTyparSet reqdTypars0)) #else ignore fc #endif @@ -597,23 +686,29 @@ module Pass2_DetermineReqdItems = let rec fixpoint reqdItemsMap = let changed = false - let changed, reqdItemsMap = Zmap.foldMap (closeStep reqdItemsMap) changed reqdItemsMap - if changed then - fixpoint reqdItemsMap - else - reqdItemsMap + + let changed, reqdItemsMap = + Zmap.foldMap (closeStep reqdItemsMap) changed reqdItemsMap + + if changed then fixpoint reqdItemsMap else reqdItemsMap fixpoint reqdItemsMap #if DEBUG let DumpReqdValMap reqdItemsMap = for KeyValue(fc, env) in reqdItemsMap do - dprintf "CLASS=%A\n env=%A\n" fc env + dprintf "CLASS=%A\n env=%A\n" fc env #endif let DetermineReqdItems (tlrS, arityM) expr = - if verboseTLR then dprintf "DetermineReqdItems------\n" - let folder = {ExprFolder0 with exprIntercept = ExprEnvIntercept (tlrS, arityM)} + if verboseTLR then + dprintf "DetermineReqdItems------\n" + + let folder = + { ExprFolder0 with + exprIntercept = ExprEnvIntercept(tlrS, arityM) + } + let z = state0 // Walk the entire assembly let z = FoldImplFile folder z expr @@ -624,7 +719,8 @@ module Pass2_DetermineReqdItems = let recShortCallS = z.recShortCallS // diagnostic dump #if DEBUG - if verboseTLR then DumpReqdValMap reqdItemsMap + if verboseTLR then + DumpReqdValMap reqdItemsMap #endif // close the reqdTypars under the subEnv reln let reqdItemsMap = CloseReqdTypars fclassM reqdItemsMap @@ -635,9 +731,9 @@ module Pass2_DetermineReqdItems = #if DEBUG // diagnostic dump if verboseTLR then - DumpReqdValMap reqdItemsMap - declist |> List.iter (fun fc -> dprintf "Declist: %A\n" fc) - recShortCallS |> Zset.iter (fun f -> dprintf "RecShortCall: %s\n" f.LogicalName) + DumpReqdValMap reqdItemsMap + declist |> List.iter (fun fc -> dprintf "Declist: %A\n" fc) + recShortCallS |> Zset.iter (fun f -> dprintf "RecShortCall: %s\n" f.LogicalName) #endif reqdItemsMap, fclassM, declist, recShortCallS @@ -663,13 +759,13 @@ type PackedReqdItems = { /// The actual typars ep_etps: Typars - + /// The actual env carrier values - ep_aenvs: Val list - + ep_aenvs: Val list + /// Sequentially define the aenvs in terms of the fvs ep_pack: Bindings - + /// Sequentially define the fvs in terms of the aenvs ep_unpack: Bindings } @@ -684,13 +780,11 @@ exception AbortTLR of range /// Chooses to pass all env values as explicit args (no tupling). /// Note, tupling would cause an allocation, /// so, unless arg lists get very long, this flat packing will be preferable. - /// Given (fclass, env). /// Have env = ReqdVal vj, ReqdSubEnv subEnvk -- ranging over j, k /// Define vals(env) = {vj}|j union vals(subEnvk)|k -- trans closure of vals of env. /// Define for each vi in vals(env). /// This is the cmap for the env. - /// reqdTypars = env.reqdTypars /// carriers = aenvi|i /// pack = TBIND(aenvi = vi) for each (aenvi, vi) in cmap @@ -699,101 +793,129 @@ exception AbortTLR of range /// where /// aenvFor(v) = aenvi where (v, aenvi) in cmap. let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Zmap) = - let fclassOf f = Zmap.force f fclassM ("fclassM", nameOfVal) - let packEnv carrierMaps (fc: BindingGroupSharingSameReqdItems) = - if verboseTLR then dprintf "\ntlr: packEnv fc=%A\n" fc - let env = Zmap.force fc reqdItemsMap ("packEnv", string) - - // carrierMaps = (fclass, (v, aenv)map)map - let carrierMapFor f = Zmap.force (fclassOf f) carrierMaps ("carrierMapFor", string) - let valsSubEnvFor f = Zmap.keys (carrierMapFor f) - - // determine vals(env) - transclosure - let vals = env.ReqdVals @ List.collect valsSubEnvFor env.ReqdSubEnvs // list, with repeats - let vals = vals |> List.distinctBy (fun v -> v.Stamp) - - // Remove genuinely toplevel, no need to close over these - let vals = vals |> List.filter (IsMandatoryTopLevel >> not) - // Remove byrefs, no need to close over these, and would be invalid to do so since their values can change. - // - // Note that it is normally not OK to skip closing over values, since values given (method) TLR must have implementations - // which are truly closed. However, byref values never escape into any lambdas, so are never used in anything - // for which we will choose a method TLR. - // - // For example, consider this (FSharp 1.0 bug 5578): - // - // let mutable a = 1 - // - // let result1 = - // let x = &a // This is NOT given TLR, because it is byref - // x <- 111 - // let temp = x // This is given a static field TLR, not a method TLR - // // let f () = x // This is not allowed, can't capture x - // x <- 999 - // temp - // - // Compare with this: - // let mutable a = 1 - // - // let result2 = - // let x = a // this is given static field TLR - // a <- 111 - // let temp = a - // let f () = x // This is not allowed, and is given a method TLR - // a <- 999 - // temp - - let vals = vals |> List.filter (fun v -> not (isByrefLikeTy g v.Range v.Type)) - // Remove values which have been labelled TLR, no need to close over these - let vals = vals |> List.filter (Zset.memberOf topValS >> not) - - // Carrier sets cannot include constrained polymorphic values. We can't just take such a value out, so for the moment - // we'll just abandon TLR altogether and give a warning about this condition. - match vals |> List.tryFind (IsGenericValWithGenericConstraints g) with - | None -> () - | Some v -> raise (AbortTLR v.Range) - - // build cmap for env - let cmapPairs = vals |> List.map (fun v -> (v, (mkCompGenLocal env.m v.LogicalName v.Type |> fst))) - let cmap = Zmap.ofList valOrder cmapPairs - let aenvFor v = Zmap.force v cmap ("aenvFor", nameOfVal) - let aenvExprFor v = exprForVal env.m (aenvFor v) - - // build PackedReqdItems - let reqdTypars = env.reqdTypars - let aenvs = Zmap.values cmap - let pack = cmapPairs |> List.map (fun (v, aenv) -> mkInvisibleBind aenv (exprForVal env.m v)) - let unpack = - let unpackCarrier (v, aenv) = mkInvisibleBind (ClearValReprInfo v) (exprForVal env.m aenv) - let unpackSubenv f = - let subCMap = carrierMapFor f - let vaenvs = Zmap.toList subCMap - vaenvs |> List.map (fun (subv, subaenv) -> mkBind DebugPointAtBinding.NoneAtInvisible subaenv (aenvExprFor subv)) - List.map unpackCarrier (Zmap.toList cmap) @ - List.collect unpackSubenv env.ReqdSubEnvs - - // extend carrierMaps - let carrierMaps = Zmap.add fc cmap carrierMaps - - // dump - if verboseTLR then - dprintf "tlr: packEnv envVals =%s\n" (showL (listL valL env.ReqdVals)) - dprintf "tlr: packEnv envSubs =%s\n" (showL (listL valL env.ReqdSubEnvs)) - dprintf "tlr: packEnv vals =%s\n" (showL (listL valL vals)) - dprintf "tlr: packEnv aenvs =%s\n" (showL (listL valL aenvs)) - dprintf "tlr: packEnv pack =%s\n" (showL (listL bindingL pack)) - dprintf "tlr: packEnv unpack =%s\n" (showL (listL bindingL unpack)) - - // result - (fc, { ep_etps = Zset.elements reqdTypars - ep_aenvs = aenvs - ep_pack = pack - ep_unpack = unpack}), carrierMaps - - let carriedMaps = Zmap.empty fclassOrder - let envPacks, _carriedMaps = List.mapFold packEnv carriedMaps declist (* List.mapFold in dec order *) - let envPacks = Zmap.ofList fclassOrder envPacks - envPacks + let fclassOf f = + Zmap.force f fclassM ("fclassM", nameOfVal) + + let packEnv carrierMaps (fc: BindingGroupSharingSameReqdItems) = + if verboseTLR then + dprintf "\ntlr: packEnv fc=%A\n" fc + + let env = Zmap.force fc reqdItemsMap ("packEnv", string) + + // carrierMaps = (fclass, (v, aenv)map)map + let carrierMapFor f = + Zmap.force (fclassOf f) carrierMaps ("carrierMapFor", string) + + let valsSubEnvFor f = Zmap.keys (carrierMapFor f) + + // determine vals(env) - transclosure + let vals = env.ReqdVals @ List.collect valsSubEnvFor env.ReqdSubEnvs // list, with repeats + let vals = vals |> List.distinctBy (fun v -> v.Stamp) + + // Remove genuinely toplevel, no need to close over these + let vals = vals |> List.filter (IsMandatoryTopLevel >> not) + // Remove byrefs, no need to close over these, and would be invalid to do so since their values can change. + // + // Note that it is normally not OK to skip closing over values, since values given (method) TLR must have implementations + // which are truly closed. However, byref values never escape into any lambdas, so are never used in anything + // for which we will choose a method TLR. + // + // For example, consider this (FSharp 1.0 bug 5578): + // + // let mutable a = 1 + // + // let result1 = + // let x = &a // This is NOT given TLR, because it is byref + // x <- 111 + // let temp = x // This is given a static field TLR, not a method TLR + // // let f () = x // This is not allowed, can't capture x + // x <- 999 + // temp + // + // Compare with this: + // let mutable a = 1 + // + // let result2 = + // let x = a // this is given static field TLR + // a <- 111 + // let temp = a + // let f () = x // This is not allowed, and is given a method TLR + // a <- 999 + // temp + + let vals = vals |> List.filter (fun v -> not (isByrefLikeTy g v.Range v.Type)) + // Remove values which have been labelled TLR, no need to close over these + let vals = vals |> List.filter (Zset.memberOf topValS >> not) + + // Carrier sets cannot include constrained polymorphic values. We can't just take such a value out, so for the moment + // we'll just abandon TLR altogether and give a warning about this condition. + match vals |> List.tryFind (IsGenericValWithGenericConstraints g) with + | None -> () + | Some v -> raise (AbortTLR v.Range) + + // build cmap for env + let cmapPairs = + vals + |> List.map (fun v -> (v, (mkCompGenLocal env.m v.LogicalName v.Type |> fst))) + + let cmap = Zmap.ofList valOrder cmapPairs + + let aenvFor v = + Zmap.force v cmap ("aenvFor", nameOfVal) + + let aenvExprFor v = exprForVal env.m (aenvFor v) + + // build PackedReqdItems + let reqdTypars = env.reqdTypars + let aenvs = Zmap.values cmap + + let pack = + cmapPairs + |> List.map (fun (v, aenv) -> mkInvisibleBind aenv (exprForVal env.m v)) + + let unpack = + let unpackCarrier (v, aenv) = + mkInvisibleBind (ClearValReprInfo v) (exprForVal env.m aenv) + + let unpackSubenv f = + let subCMap = carrierMapFor f + let vaenvs = Zmap.toList subCMap + + vaenvs + |> List.map (fun (subv, subaenv) -> mkBind DebugPointAtBinding.NoneAtInvisible subaenv (aenvExprFor subv)) + + List.map unpackCarrier (Zmap.toList cmap) + @ List.collect unpackSubenv env.ReqdSubEnvs + + // extend carrierMaps + let carrierMaps = Zmap.add fc cmap carrierMaps + + // dump + if verboseTLR then + dprintf "tlr: packEnv envVals =%s\n" (showL (listL valL env.ReqdVals)) + dprintf "tlr: packEnv envSubs =%s\n" (showL (listL valL env.ReqdSubEnvs)) + dprintf "tlr: packEnv vals =%s\n" (showL (listL valL vals)) + dprintf "tlr: packEnv aenvs =%s\n" (showL (listL valL aenvs)) + dprintf "tlr: packEnv pack =%s\n" (showL (listL bindingL pack)) + dprintf "tlr: packEnv unpack =%s\n" (showL (listL bindingL unpack)) + + // result + (fc, + { + ep_etps = Zset.elements reqdTypars + ep_aenvs = aenvs + ep_pack = pack + ep_unpack = unpack + }), + carrierMaps + + let carriedMaps = Zmap.empty fclassOrder + + let envPacks, _carriedMaps = + List.mapFold packEnv carriedMaps declist (* List.mapFold in dec order *) + + let envPacks = Zmap.ofList fclassOrder envPacks + envPacks //------------------------------------------------------------------------- // step3: chooseEnvPacks @@ -807,9 +929,11 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Zmap Option.isSome) + assert (g.CompilerGlobalState |> Option.isSome) g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName(name, m) - let fHat = mkLocalNameTypeArity f.IsCompilerGenerated m fHatName fHatTy (Some fHatArity) + let fHat = + mkLocalNameTypeArity f.IsCompilerGenerated m fHatName fHatTy (Some fHatArity) + fHat let fs = Zset.elements tlrS @@ -859,24 +986,28 @@ module Pass4_RewriteAssembly = [] type RewriteContext = - { ccu: CcuThunk - g: TcGlobals - stackGuard: StackGuard - tlrS: Zset - topValS: Zset - arityM: Zmap - fclassM: Zmap - recShortCallS: Zset - envPackM: Zmap - /// The mapping from 'f' values to 'fHat' values - fHatM: Zmap - } + { + ccu: CcuThunk + g: TcGlobals + stackGuard: StackGuard + tlrS: Zset + topValS: Zset + arityM: Zmap + fclassM: Zmap + recShortCallS: Zset + envPackM: Zmap + /// The mapping from 'f' values to 'fHat' values + fHatM: Zmap + } //------------------------------------------------------------------------- // pass4: rwstate (z state) //------------------------------------------------------------------------- - type IsRecursive = IsRec | NotRec + type IsRecursive = + | IsRec + | NotRec + type LiftedDeclaration = IsRecursive * Bindings (* where bool=true if letrec *) /// This state is related to lifting to top-level (which is actually disabled right now) @@ -891,63 +1022,83 @@ module Pass4_RewriteAssembly = /// Any TLR repr bindings under lambdas can be filtered out (and collected), /// giving pre-declarations to insert before the outermost lambda expr. type RewriteState = - { rws_shouldinline: bool - /// counts level of enclosing "lambdas" - rws_innerLevel: int - /// collected preDecs (fringe is in-order) - rws_preDecs: Tree + { + rws_shouldinline: bool + /// counts level of enclosing "lambdas" + rws_innerLevel: int + /// collected preDecs (fringe is in-order) + rws_preDecs: Tree } - let rewriteState0 = {rws_shouldinline=false;rws_innerLevel=0;rws_preDecs=emptyTR} + let rewriteState0 = + { + rws_shouldinline = false + rws_innerLevel = 0 + rws_preDecs = emptyTR + } // move in/out of lambdas (or lambda containing construct) - let EnterInner z = {z with rws_innerLevel = z.rws_innerLevel + 1} + let EnterInner z = + { z with + rws_innerLevel = z.rws_innerLevel + 1 + } - let ExitInner z = {z with rws_innerLevel = z.rws_innerLevel - 1} + let ExitInner z = + { z with + rws_innerLevel = z.rws_innerLevel - 1 + } let EnterShouldInline b z f = let orig = z.rws_shouldinline - let x, z' = f (if b then {z with rws_shouldinline = true } else z) - {z' with rws_shouldinline = orig }, x + let x, z' = f (if b then { z with rws_shouldinline = true } else z) + { z' with rws_shouldinline = orig }, x /// extract PreDecs (iff at top-level) let ExtractPreDecs z = // If level=0, so at top-level, then pop decs, // else keep until get back to a top-level point. - if z.rws_innerLevel=0 then - // at top-level, extract preDecs - let preDecs = fringeTR z.rws_preDecs - preDecs, {z with rws_preDecs=emptyTR} + if z.rws_innerLevel = 0 then + // at top-level, extract preDecs + let preDecs = fringeTR z.rws_preDecs + preDecs, { z with rws_preDecs = emptyTR } else - // not yet top-level, keep decs - [], z + // not yet top-level, keep decs + [], z /// pop and set preDecs as "LiftedDeclaration tree" - let PopPreDecs z = {z with rws_preDecs=emptyTR}, z.rws_preDecs + let PopPreDecs z = + { z with rws_preDecs = emptyTR }, z.rws_preDecs - let SetPreDecs z pdt = {z with rws_preDecs=pdt} + let SetPreDecs z pdt = { z with rws_preDecs = pdt } /// collect Top* repr bindings - if needed... - let LiftTopBinds _isRec _penv z binds = - z, binds + let LiftTopBinds _isRec _penv z binds = z, binds /// Wrap preDecs (in order) over an expr - use letrec/let as approp - let MakePreDec m (isRec, binds: Bindings) expr = - if isRec=IsRec then + let MakePreDec m (isRec, binds: Bindings) expr = + if isRec = IsRec then // By definition top level bindings don't refer to non-top level bindings, so we can build them in two parts - let topLevelBinds, nonTopLevelBinds = binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) + let topLevelBinds, nonTopLevelBinds = + binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) + mkLetRecBinds m topLevelBinds (mkLetRecBinds m nonTopLevelBinds expr) else - mkLetsFromBindings m binds expr + mkLetsFromBindings m binds expr /// Must MakePreDecs around every construct that could do EnterInner (which filters TLR decs). /// i.e. let, letrec (bind may...), ilobj, lambda, tlambda. - let MakePreDecs m preDecs expr = List.foldBack (MakePreDec m) preDecs expr + let MakePreDecs m preDecs expr = + List.foldBack (MakePreDec m) preDecs expr let RecursivePreDecs pdsA pdsB = - let pds = fringeTR (TreeNode[pdsA;pdsB]) + let pds = + fringeTR ( + TreeNode[pdsA + pdsB] + ) + let decs = pds |> List.collect snd - LeafNode (IsRec, decs) + LeafNode(IsRec, decs) //------------------------------------------------------------------------- // pass4: lowertop - convert_vterm_bind on TopLevel binds @@ -955,8 +1106,8 @@ module Pass4_RewriteAssembly = let AdjustBindToValRepr g (TBind(v, repr, _)) = match v.ValReprInfo with - | None -> - v.SetValReprInfo (Some (InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v repr )) + | None -> + v.SetValReprInfo(Some(InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v repr)) // Things that don't have an arity from type inference but are top-level are compiler-generated v.SetIsCompilerGenerated(true) | Some _ -> () @@ -972,72 +1123,88 @@ module Pass4_RewriteAssembly = // let fHat f_freeVars vss = f_body[, f_freeVars] let TransTLRBindings penv (binds: Bindings) = let g = penv.g - if isNil binds then [], [] else - let fc = BindingGroupSharingSameReqdItems binds - let envp = Zmap.force fc penv.envPackM ("TransTLRBindings", string) - - let fRebinding (TBind(fOrig, body, letSeqPtOpt)) = - let m = fOrig.Range - let tps, vss, _b, bodyTy = stripTopLambda (body, fOrig.Type) - let aenvExprs = envp.ep_aenvs |> List.map (exprForVal m) - let vsExprs = vss |> List.map (mkRefTupledVars penv.g m) - let fHat = Zmap.force fOrig penv.fHatM ("fRebinding", nameOfVal) - - // REVIEW: is this mutation really, really necessary? - // Why are we applying TLR if the thing already has an arity? - let fOrig = ClearValReprInfo fOrig - - let fBind = - mkMultiLambdaBind g fOrig letSeqPtOpt m tps vss - (mkApps penv.g - ((exprForVal m fHat, fHat.Type), - [List.map mkTyparTy (envp.ep_etps @ tps)], - aenvExprs @ vsExprs, m), bodyTy) - fBind - - let fHatNewBinding (shortRecBinds: Bindings) (TBind(f, b, letSeqPtOpt)) = - let wf = Zmap.force f penv.arityM ("fHatNewBinding - arityM", nameOfVal) - let fHat = Zmap.force f penv.fHatM ("fHatNewBinding - fHatM", nameOfVal) - - // Take off the variables - let tps, vss, body, bodyTy = stripTopLambda (b, f.Type) - - // Don't take all the variables - only up to length wf - let vssTake, vssDrop = List.splitAt wf vss - - // Put the untaken variables back on - let body, bodyTy = mkMultiLambdasCore g body.Range vssDrop (body, bodyTy) - - // fHat, args - let m = fHat.Range - - // Add the type variables to the front - let fHat_tps = envp.ep_etps @ tps - - // Add the 'aenv' and original taken variables to the front - let fHat_args = List.map List.singleton envp.ep_aenvs @ vssTake - let fHat_body = mkLetsFromBindings m envp.ep_unpack body - let fHat_body = mkLetsFromBindings m shortRecBinds fHat_body // bind "f" if have short recursive calls (somewhere) - - // fHat binding, f rebinding - let fHatBind = mkMultiLambdaBind g fHat letSeqPtOpt m fHat_tps fHat_args (fHat_body, bodyTy) - fHatBind - - let rebinds = binds |> List.map fRebinding - let shortRecBinds = rebinds |> List.filter (fun b -> penv.recShortCallS.Contains(b.Var)) - let newBinds = binds |> List.map (fHatNewBinding shortRecBinds) - newBinds, rebinds + + if isNil binds then + [], [] + else + let fc = BindingGroupSharingSameReqdItems binds + let envp = Zmap.force fc penv.envPackM ("TransTLRBindings", string) + + let fRebinding (TBind(fOrig, body, letSeqPtOpt)) = + let m = fOrig.Range + let tps, vss, _b, bodyTy = stripTopLambda (body, fOrig.Type) + let aenvExprs = envp.ep_aenvs |> List.map (exprForVal m) + let vsExprs = vss |> List.map (mkRefTupledVars penv.g m) + let fHat = Zmap.force fOrig penv.fHatM ("fRebinding", nameOfVal) + + // REVIEW: is this mutation really, really necessary? + // Why are we applying TLR if the thing already has an arity? + let fOrig = ClearValReprInfo fOrig + + let fBind = + mkMultiLambdaBind + g + fOrig + letSeqPtOpt + m + tps + vss + (mkApps penv.g ((exprForVal m fHat, fHat.Type), [ List.map mkTyparTy (envp.ep_etps @ tps) ], aenvExprs @ vsExprs, m), + bodyTy) + + fBind + + let fHatNewBinding (shortRecBinds: Bindings) (TBind(f, b, letSeqPtOpt)) = + let wf = Zmap.force f penv.arityM ("fHatNewBinding - arityM", nameOfVal) + let fHat = Zmap.force f penv.fHatM ("fHatNewBinding - fHatM", nameOfVal) + + // Take off the variables + let tps, vss, body, bodyTy = stripTopLambda (b, f.Type) + + // Don't take all the variables - only up to length wf + let vssTake, vssDrop = List.splitAt wf vss + + // Put the untaken variables back on + let body, bodyTy = mkMultiLambdasCore g body.Range vssDrop (body, bodyTy) + + // fHat, args + let m = fHat.Range + + // Add the type variables to the front + let fHat_tps = envp.ep_etps @ tps + + // Add the 'aenv' and original taken variables to the front + let fHat_args = List.map List.singleton envp.ep_aenvs @ vssTake + let fHat_body = mkLetsFromBindings m envp.ep_unpack body + let fHat_body = mkLetsFromBindings m shortRecBinds fHat_body // bind "f" if have short recursive calls (somewhere) + + // fHat binding, f rebinding + let fHatBind = + mkMultiLambdaBind g fHat letSeqPtOpt m fHat_tps fHat_args (fHat_body, bodyTy) + + fHatBind + + let rebinds = binds |> List.map fRebinding + + let shortRecBinds = + rebinds |> List.filter (fun b -> penv.recShortCallS.Contains(b.Var)) + + let newBinds = binds |> List.map (fHatNewBinding shortRecBinds) + newBinds, rebinds let GetAEnvBindings penv fc = match Zmap.tryFind fc penv.envPackM with - | None -> [] // no env for this mutual binding + | None -> [] // no env for this mutual binding | Some envp -> envp.ep_pack // environment pack bindings let forceTopBindToHaveArity penv (bind: Binding) = - if penv.topValS.Contains(bind.Var) then AdjustBindToValRepr penv.g bind + if penv.topValS.Contains(bind.Var) then + AdjustBindToValRepr penv.g bind let TransBindings xisRec penv (binds: Bindings) = - let tlrBs, nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var penv.tlrS) + let tlrBs, nonTlrBs = + binds |> List.partition (fun b -> Zset.contains b.Var penv.tlrS) + let fclass = BindingGroupSharingSameReqdItems tlrBs // Trans each TLR f binding into fHat and f rebind @@ -1051,7 +1218,7 @@ module Pass4_RewriteAssembly = // Assemble into replacement bindings let bindAs, rebinds = match xisRec with - | IsRec -> newTlrBinds @ tlrRebinds @ nonTlrBs @ aenvBinds, [] // note: aenv last, order matters in letrec! + | IsRec -> newTlrBinds @ tlrRebinds @ nonTlrBs @ aenvBinds, [] // note: aenv last, order matters in letrec! | NotRec -> aenvBinds @ newTlrBinds, tlrRebinds @ nonTlrBs // note: aenv go first, they may be used bindAs, rebinds @@ -1064,24 +1231,29 @@ module Pass4_RewriteAssembly = // Is it a val app, where the val f is TLR with arity wf? // CLEANUP NOTE: should be using a mkApps to make all applications match fx with - | Expr.Val (fvref: ValRef, _, vm) when - (Zset.contains fvref.Deref penv.tlrS) && - (let wf = Zmap.force fvref.Deref penv.arityM ("TransApp - wf", nameOfVal) - IsArityMet fvref wf tys args) -> - - let f = fvref.Deref - (* replace by direct call to corresponding fHat (and additional closure args) *) - let fc = Zmap.force f penv.fclassM ("TransApp - fc", nameOfVal) - let envp = Zmap.force fc penv.envPackM ("TransApp - envp", string) - let fHat = Zmap.force f penv.fHatM ("TransApp - fHat", nameOfVal) - let tys = (List.map mkTyparTy envp.ep_etps) @ tys - let aenvExprs = List.map (exprForVal vm) envp.ep_aenvs - let args = aenvExprs @ args - mkApps penv.g ((exprForVal vm fHat, fHat.Type), [tys], args, m) (* change, direct fHat call with closure (reqdTypars, aenvs) *) + | Expr.Val(fvref: ValRef, _, vm) when + (Zset.contains fvref.Deref penv.tlrS) + && (let wf = Zmap.force fvref.Deref penv.arityM ("TransApp - wf", nameOfVal) + IsArityMet fvref wf tys args) + -> + + let f = fvref.Deref + (* replace by direct call to corresponding fHat (and additional closure args) *) + let fc = Zmap.force f penv.fclassM ("TransApp - fc", nameOfVal) + let envp = Zmap.force fc penv.envPackM ("TransApp - envp", string) + let fHat = Zmap.force f penv.fHatM ("TransApp - fHat", nameOfVal) + let tys = (List.map mkTyparTy envp.ep_etps) @ tys + let aenvExprs = List.map (exprForVal vm) envp.ep_aenvs + let args = aenvExprs @ args + + mkApps + penv.g + ((exprForVal vm fHat, fHat.Type), [ tys ], args, m) (* change, direct fHat call with closure (reqdTypars, aenvs) *) | _ -> if isNil tys && isNil args then fx - else Expr.App (fx, fty, tys, args, m) + else + Expr.App(fx, fty, tys, args, m) //------------------------------------------------------------------------- // pass4: pass (over expr) @@ -1091,174 +1263,189 @@ module Pass4_RewriteAssembly = /// At applications, fixup calls if they are arity-met instances of TLR. /// At free vals, fixup 0-call if it is an arity-met constant. /// Other cases rewrite structurally. - let rec TransExpr (penv: RewriteContext) (z: RewriteState) expr: Expr * RewriteState = - penv.stackGuard.Guard <| fun () -> - + let rec TransExpr (penv: RewriteContext) (z: RewriteState) expr : Expr * RewriteState = + penv.stackGuard.Guard + <| fun () -> + + match expr with + // Use TransLinearExpr with a rebuild-continuation for some forms to avoid stack overflows on large terms + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.LetRec _ // note, Expr.LetRec not normally considered linear, but keeping it here as it's always been here + | Expr.Let _ + | Expr.DebugPoint _ + | Expr.Sequential _ -> TransLinearExpr penv z expr id + + // app - call sites may require z. + // - match the app (collapsing reclinks and type instances). + // - patch it. + | Expr.App(f, fty, tys, args, m) -> + // pass over f, args subexprs + let f, z = TransExpr penv z f + let args, z = List.mapFold (TransExpr penv) z args + // match app, and fixup if needed + let f, fty, tys, args, m = destApp (f, fty, tys, args, m) + let expr = TransApp penv (f, fty, tys, args, m) + expr, z + + | Expr.Val(v, _, m) -> + // consider this a trivial app + let fx, fty = expr, v.Type + let expr = TransApp penv (fx, fty, [], [], m) + expr, z + + // reclink - suppress + | Expr.Link r -> TransExpr penv z r.Value + + // ilobj - has implicit lambda exprs and recursive/base references + | Expr.Obj(_, ty, basev, basecall, overrides, iimpls, m) -> + let basecall, z = TransExpr penv z basecall + let overrides, z = List.mapFold (TransMethod penv) z overrides + + let iimpls, z = + (z, iimpls) + ||> List.mapFold (fun z (tType, objExprs) -> + let objExprs', z' = List.mapFold (TransMethod penv) z objExprs + (tType, objExprs'), z') + + let expr = Expr.Obj(newUnique (), ty, basev, basecall, overrides, iimpls, m) + let pds, z = ExtractPreDecs z + MakePreDecs m pds expr, z (* if TopLevel, lift preDecs over the ilobj expr *) + + // lambda, tlambda - explicit lambda terms + | Expr.Lambda(_, ctorThisValOpt, baseValOpt, argvs, body, m, bodyTy) -> + let z = EnterInner z + let body, z = TransExpr penv z body + let z = ExitInner z + let pds, z = ExtractPreDecs z + MakePreDecs m pds (rebuildLambda m ctorThisValOpt baseValOpt argvs (body, bodyTy)), z + + | Expr.TyLambda(_, tps, body, m, bodyTy) -> + let z = EnterInner z + let body, z = TransExpr penv z body + let z = ExitInner z + let pds, z = ExtractPreDecs z + MakePreDecs m pds (mkTypeLambda m tps (body, bodyTy)), z + + // Lifting TLR out over constructs (disabled) + // Lift minimally to ensure the defn is not lifted up and over defns on which it depends (disabled) + | Expr.Match(spBind, mExpr, dtree, targets, m, ty) -> + let targets = Array.toList targets + let dtree, z = TransDecisionTree penv z dtree + let targets, z = List.mapFold (TransDecisionTreeTarget penv) z targets + // TransDecisionTreeTarget wraps EnterInner/exitInner, so need to collect any top decs + let pds, z = ExtractPreDecs z + MakePreDecs m pds (mkAndSimplifyMatch spBind mExpr m ty dtree targets), z + + // all others - below - rewrite structurally - so boiler plate code after this point... + | Expr.Const _ -> expr, z + + | Expr.Quote(a, dataCell, isFromQueryExpression, m, ty) -> + let doData (typeDefs, argTypes, argExprs, data) z = + let argExprs, z = List.mapFold (TransExpr penv) z argExprs + (typeDefs, argTypes, argExprs, data), z + + let data, z = + match dataCell.Value with + | Some(data1, data2) -> + let data1, z = doData data1 z + let data2, z = doData data2 z + Some(data1, data2), z + | None -> None, z + + Expr.Quote(a, ref data, isFromQueryExpression, m, ty), z + + | Expr.Op(c, tyargs, args, m) -> + let args, z = List.mapFold (TransExpr penv) z args + Expr.Op(c, tyargs, args, m), z + + | Expr.StaticOptimization(constraints, e2, e3, m) -> + let e2, z = TransExpr penv z e2 + let e3, z = TransExpr penv z e3 + Expr.StaticOptimization(constraints, e2, e3, m), z + + | Expr.TyChoose(_, _, m) -> error (Error(FSComp.SR.tlrUnexpectedTExpr (), m)) + + | Expr.WitnessArg(_witnessInfo, _m) -> expr, z + + /// Walk over linear structured terms in tail-recursive loop, using a continuation + /// to represent the rebuild-the-term stack + and TransLinearExpr penv z expr (contf: Expr * RewriteState -> Expr * RewriteState) = match expr with - // Use TransLinearExpr with a rebuild-continuation for some forms to avoid stack overflows on large terms - | LinearOpExpr _ - | LinearMatchExpr _ - | Expr.LetRec _ // note, Expr.LetRec not normally considered linear, but keeping it here as it's always been here - | Expr.Let _ - | Expr.DebugPoint _ - | Expr.Sequential _ -> - TransLinearExpr penv z expr id - - // app - call sites may require z. - // - match the app (collapsing reclinks and type instances). - // - patch it. - | Expr.App (f, fty, tys, args, m) -> - // pass over f, args subexprs - let f, z = TransExpr penv z f - let args, z = List.mapFold (TransExpr penv) z args - // match app, and fixup if needed - let f, fty, tys, args, m = destApp (f, fty, tys, args, m) - let expr = TransApp penv (f, fty, tys, args, m) - expr, z - - | Expr.Val (v, _, m) -> - // consider this a trivial app - let fx, fty = expr, v.Type - let expr = TransApp penv (fx, fty, [], [], m) - expr, z - - // reclink - suppress - | Expr.Link r -> - TransExpr penv z r.Value - - // ilobj - has implicit lambda exprs and recursive/base references - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> - let basecall, z = TransExpr penv z basecall - let overrides, z = List.mapFold (TransMethod penv) z overrides - let iimpls, z = - (z, iimpls) ||> List.mapFold (fun z (tType, objExprs) -> - let objExprs', z' = List.mapFold (TransMethod penv) z objExprs - (tType, objExprs'), z') - let expr = Expr.Obj (newUnique(), ty, basev, basecall, overrides, iimpls, m) - let pds, z = ExtractPreDecs z - MakePreDecs m pds expr, z (* if TopLevel, lift preDecs over the ilobj expr *) + | Expr.Sequential(e1, e2, dir, m) -> + let e1, z = TransExpr penv z e1 + TransLinearExpr penv z e2 (contf << (fun (e2, z) -> Expr.Sequential(e1, e2, dir, m), z)) - // lambda, tlambda - explicit lambda terms - | Expr.Lambda (_, ctorThisValOpt, baseValOpt, argvs, body, m, bodyTy) -> - let z = EnterInner z - let body, z = TransExpr penv z body - let z = ExitInner z - let pds, z = ExtractPreDecs z - MakePreDecs m pds (rebuildLambda m ctorThisValOpt baseValOpt argvs (body, bodyTy)), z + | Expr.DebugPoint(dpm, innerExpr) -> + TransLinearExpr penv z innerExpr (contf << (fun (innerExprR, z) -> Expr.DebugPoint(dpm, innerExprR), z)) - | Expr.TyLambda (_, tps, body, m, bodyTy) -> + // letrec - pass_recbinds does the work + | Expr.LetRec(binds, e, m, _) -> let z = EnterInner z - let body, z = TransExpr penv z body + // For letrec, preDecs from RHS must mutually recurse with those from the bindings + let z, pdsPrior = PopPreDecs z + let binds, z = List.mapFold (TransBindingRhs penv) z binds + let z, pdsRhs = PopPreDecs z + let binds, rebinds = TransBindings IsRec penv binds + let z, binds = LiftTopBinds IsRec penv z binds (* factor Top* repr binds *) + let z, rebinds = LiftTopBinds IsRec penv z rebinds + let z, pdsBind = PopPreDecs z + let z = SetPreDecs z (TreeNode [ pdsPrior; RecursivePreDecs pdsBind pdsRhs ]) let z = ExitInner z let pds, z = ExtractPreDecs z - MakePreDecs m pds (mkTypeLambda m tps (body, bodyTy)), z - - // Lifting TLR out over constructs (disabled) - // Lift minimally to ensure the defn is not lifted up and over defns on which it depends (disabled) - | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> - let targets = Array.toList targets + // tailcall + TransLinearExpr + penv + z + e + (contf + << (fun (e, z) -> + let e = mkLetsFromBindings m rebinds e + MakePreDecs m pds (Expr.LetRec(binds, e, m, Construct.NewFreeVarsCache())), z)) + + // let - can consider the mu-let bindings as mu-letrec bindings - so like as above + | Expr.Let(bind, e, m, _) -> + + // For let, preDecs from RHS go before those of bindings, which is collection order + let bind, z = TransBindingRhs penv z bind + let binds, rebinds = TransBindings NotRec penv [ bind ] + // factor Top* repr binds + let z, binds = LiftTopBinds NotRec penv z binds + let z, rebinds = LiftTopBinds NotRec penv z rebinds + // any lifted PreDecs from binding, if so wrap them... + let pds, z = ExtractPreDecs z + // tailcall + TransLinearExpr + penv + z + e + (contf + << (fun (e, z) -> + let e = mkLetsFromBindings m rebinds e + MakePreDecs m pds (mkLetsFromBindings m binds e), z)) + + | LinearMatchExpr(spBind, mExpr, dtree, tg1, e2, m2, ty) -> let dtree, z = TransDecisionTree penv z dtree - let targets, z = List.mapFold (TransDecisionTreeTarget penv) z targets - // TransDecisionTreeTarget wraps EnterInner/exitInner, so need to collect any top decs - let pds,z = ExtractPreDecs z - MakePreDecs m pds (mkAndSimplifyMatch spBind mExpr m ty dtree targets), z - - // all others - below - rewrite structurally - so boiler plate code after this point... - | Expr.Const _ -> - expr,z - - | Expr.Quote (a,dataCell,isFromQueryExpression,m,ty) -> - let doData (typeDefs,argTypes,argExprs,data) z = - let argExprs,z = List.mapFold (TransExpr penv) z argExprs - (typeDefs,argTypes,argExprs,data), z - - let data, z = - match dataCell.Value with - | Some (data1, data2) -> - let data1, z = doData data1 z - let data2, z = doData data2 z - Some (data1, data2), z - | None -> None, z - - Expr.Quote (a,ref data,isFromQueryExpression,m,ty),z - - | Expr.Op (c,tyargs,args,m) -> - let args,z = List.mapFold (TransExpr penv) z args - Expr.Op (c,tyargs,args,m),z - - | Expr.StaticOptimization (constraints,e2,e3,m) -> - let e2,z = TransExpr penv z e2 - let e3,z = TransExpr penv z e3 - Expr.StaticOptimization (constraints,e2,e3,m),z - - | Expr.TyChoose (_,_,m) -> - error(Error(FSComp.SR.tlrUnexpectedTExpr(),m)) - - | Expr.WitnessArg (_witnessInfo, _m) -> - expr, z - - /// Walk over linear structured terms in tail-recursive loop, using a continuation - /// to represent the rebuild-the-term stack - and TransLinearExpr penv z expr (contf: Expr * RewriteState -> Expr * RewriteState) = - match expr with - | Expr.Sequential (e1, e2, dir, m) -> - let e1, z = TransExpr penv z e1 - TransLinearExpr penv z e2 (contf << (fun (e2, z) -> - Expr.Sequential (e1, e2, dir, m), z)) - - | Expr.DebugPoint (dpm, innerExpr) -> - TransLinearExpr penv z innerExpr (contf << (fun (innerExprR, z) -> - Expr.DebugPoint (dpm, innerExprR), z)) - - // letrec - pass_recbinds does the work - | Expr.LetRec (binds, e, m, _) -> - let z = EnterInner z - // For letrec, preDecs from RHS must mutually recurse with those from the bindings - let z, pdsPrior = PopPreDecs z - let binds, z = List.mapFold (TransBindingRhs penv) z binds - let z, pdsRhs = PopPreDecs z - let binds, rebinds = TransBindings IsRec penv binds - let z, binds = LiftTopBinds IsRec penv z binds (* factor Top* repr binds *) - let z, rebinds = LiftTopBinds IsRec penv z rebinds - let z, pdsBind = PopPreDecs z - let z = SetPreDecs z (TreeNode [pdsPrior;RecursivePreDecs pdsBind pdsRhs]) - let z = ExitInner z - let pds, z = ExtractPreDecs z - // tailcall - TransLinearExpr penv z e (contf << (fun (e, z) -> - let e = mkLetsFromBindings m rebinds e - MakePreDecs m pds (Expr.LetRec (binds, e, m, Construct.NewFreeVarsCache())), z)) - - // let - can consider the mu-let bindings as mu-letrec bindings - so like as above - | Expr.Let (bind, e, m, _) -> - - // For let, preDecs from RHS go before those of bindings, which is collection order - let bind, z = TransBindingRhs penv z bind - let binds, rebinds = TransBindings NotRec penv [bind] - // factor Top* repr binds - let z, binds = LiftTopBinds NotRec penv z binds - let z, rebinds = LiftTopBinds NotRec penv z rebinds - // any lifted PreDecs from binding, if so wrap them... - let pds, z = ExtractPreDecs z - // tailcall - TransLinearExpr penv z e (contf << (fun (e, z) -> - let e = mkLetsFromBindings m rebinds e - MakePreDecs m pds (mkLetsFromBindings m binds e), z)) - - | LinearMatchExpr (spBind, mExpr, dtree, tg1, e2, m2, ty) -> - let dtree, z = TransDecisionTree penv z dtree - let tg1, z = TransDecisionTreeTarget penv z tg1 - // tailcall - TransLinearExpr penv z e2 (contf << (fun (e2, z) -> - rebuildLinearMatchExpr (spBind, mExpr, dtree, tg1, e2, m2, ty), z)) - - | LinearOpExpr (op, tyargs, argsHead, argLast, m) -> - let argsHead,z = List.mapFold (TransExpr penv) z argsHead - // tailcall - TransLinearExpr penv z argLast (contf << (fun (argLast, z) -> - rebuildLinearOpExpr (op, tyargs, argsHead, argLast, m), z)) - - | _ -> + let tg1, z = TransDecisionTreeTarget penv z tg1 + // tailcall + TransLinearExpr + penv + z + e2 + (contf + << (fun (e2, z) -> rebuildLinearMatchExpr (spBind, mExpr, dtree, tg1, e2, m2, ty), z)) + + | LinearOpExpr(op, tyargs, argsHead, argLast, m) -> + let argsHead, z = List.mapFold (TransExpr penv) z argsHead + // tailcall + TransLinearExpr + penv + z + argLast + (contf + << (fun (argLast, z) -> rebuildLinearOpExpr (op, tyargs, argsHead, argLast, m), z)) + + | _ -> // not a linear expression contf (TransExpr penv z expr) @@ -1271,28 +1458,29 @@ module Pass4_RewriteAssembly = and TransBindingRhs penv z (TBind(v, e, letSeqPtOpt)) : Binding * RewriteState = let shouldInline = v.ShouldInline let z, e = EnterShouldInline shouldInline z (fun z -> TransExpr penv z e) - TBind (v, e, letSeqPtOpt), z + TBind(v, e, letSeqPtOpt), z + + and TransDecisionTree penv z x : DecisionTree * RewriteState = + match x with + | TDSuccess(es, n) -> + let es, z = List.mapFold (TransExpr penv) z es + TDSuccess(es, n), z - and TransDecisionTree penv z x: DecisionTree * RewriteState = - match x with - | TDSuccess (es, n) -> - let es, z = List.mapFold (TransExpr penv) z es - TDSuccess(es, n), z + | TDBind(bind, rest) -> + let bind, z = TransBindingRhs penv z bind + let rest, z = TransDecisionTree penv z rest + TDBind(bind, rest), z - | TDBind (bind, rest) -> - let bind, z = TransBindingRhs penv z bind - let rest, z = TransDecisionTree penv z rest - TDBind(bind, rest), z + | TDSwitch(e, cases, dflt, m) -> + let e, z = TransExpr penv z e - | TDSwitch (e, cases, dflt, m) -> - let e, z = TransExpr penv z e - let TransDecisionTreeCase penv z (TCase (discrim, dtree)) = - let dtree, z = TransDecisionTree penv z dtree - TCase(discrim, dtree), z + let TransDecisionTreeCase penv z (TCase(discrim, dtree)) = + let dtree, z = TransDecisionTree penv z dtree + TCase(discrim, dtree), z - let cases, z = List.mapFold (TransDecisionTreeCase penv) z cases - let dflt, z = Option.mapFold (TransDecisionTree penv) z dflt - TDSwitch (e, cases, dflt, m), z + let cases, z = List.mapFold (TransDecisionTreeCase penv) z cases + let dflt, z = Option.mapFold (TransDecisionTree penv) z dflt + TDSwitch(e, cases, dflt, m), z and TransDecisionTreeTarget penv z (TTarget(vs, e, flags)) = let z = EnterInner z @@ -1302,26 +1490,27 @@ module Pass4_RewriteAssembly = and TransValBinding penv z bind = TransBindingRhs penv z bind - and TransValBindings penv z binds = List.mapFold (TransValBinding penv) z binds + and TransValBindings penv z binds = + List.mapFold (TransValBinding penv) z binds - and TransModuleContents penv (z: RewriteState) x: ModuleOrNamespaceContents * RewriteState = + and TransModuleContents penv (z: RewriteState) x : ModuleOrNamespaceContents * RewriteState = match x with | TMDefRec(isRec, opens, tycons, mbinds, m) -> let mbinds, z = TransModuleBindings penv z mbinds TMDefRec(isRec, opens, tycons, mbinds, m), z - | TMDefLet(bind, m) -> + | TMDefLet(bind, m) -> let bind, z = TransValBinding penv z bind TMDefLet(bind, m), z - | TMDefDo(e, m) -> + | TMDefDo(e, m) -> let _bind, z = TransExpr penv z e TMDefDo(e, m), z - | TMDefs defs -> + | TMDefs defs -> let defs, z = List.mapFold (TransModuleContents penv) z defs TMDefs defs, z - | TMDefOpens _ -> - x, z + | TMDefOpens _ -> x, z - and TransModuleBindings penv z binds = List.mapFold (TransModuleBinding penv) z binds + and TransModuleBindings penv z binds = + List.mapFold (TransModuleBinding penv) z binds and TransModuleBinding penv z x = match x with @@ -1332,58 +1521,73 @@ module Pass4_RewriteAssembly = let rhs, z = TransModuleContents penv z rhs ModuleOrNamespaceBinding.Module(nm, rhs), z - let TransImplFile penv z (CheckedImplFile (fragName, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = + let TransImplFile + penv + z + (CheckedImplFile(fragName, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) + = let contentsR, z = TransModuleContents penv z contents - (CheckedImplFile (fragName, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)), z + (CheckedImplFile(fragName, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)), z //------------------------------------------------------------------------- // pass5: copyExpr //------------------------------------------------------------------------- -let RecreateUniqueBounds g expr = - copyImplFile g OnlyCloneExprVals expr +let RecreateUniqueBounds g expr = copyImplFile g OnlyCloneExprVals expr //------------------------------------------------------------------------- // entry point //------------------------------------------------------------------------- let MakeTopLevelRepresentationDecisions ccu g expr = - try - // pass1: choose the f to be TLR with arity(f) - let tlrS, topValS, arityM = Pass1_DetermineTLRAndArities.DetermineTLRAndArities g expr - - // pass2: determine the typar/freevar closures, f->fclass and fclass declist - let reqdItemsMap, fclassM, declist, recShortCallS = Pass2_DetermineReqdItems.DetermineReqdItems (tlrS, arityM) expr - - // pass3 - let envPackM = ChooseReqdItemPackings g fclassM topValS declist reqdItemsMap - let fHatM = CreateNewValuesForTLR g tlrS arityM fclassM envPackM - - // pass4: rewrite - if verboseTLR then dprintf "TransExpr(rw)------\n" - let expr, _ = - let penv: Pass4_RewriteAssembly.RewriteContext = - { ccu = ccu - g = g - tlrS = tlrS - topValS = topValS - arityM = arityM - fclassM = fclassM - recShortCallS = recShortCallS - envPackM = envPackM - fHatM = fHatM - stackGuard = StackGuard(InnerLambdasToTopLevelFunctionsStackGuardDepth, "InnerLambdasToTopLevelFunctionsStackGuardDepth") } - let z = Pass4_RewriteAssembly.rewriteState0 - Pass4_RewriteAssembly.TransImplFile penv z expr - - // pass5: copyExpr to restore "each bound is unique" property - // aka, copyExpr - if verboseTLR then dprintf "copyExpr------\n" - let expr = RecreateUniqueBounds g expr - if verboseTLR then dprintf "TLR-done------\n" - - expr - - with AbortTLR m -> - warning(Error(FSComp.SR.tlrLambdaLiftingOptimizationsNotApplied(), m)) - expr + try + // pass1: choose the f to be TLR with arity(f) + let tlrS, topValS, arityM = + Pass1_DetermineTLRAndArities.DetermineTLRAndArities g expr + + // pass2: determine the typar/freevar closures, f->fclass and fclass declist + let reqdItemsMap, fclassM, declist, recShortCallS = + Pass2_DetermineReqdItems.DetermineReqdItems (tlrS, arityM) expr + + // pass3 + let envPackM = ChooseReqdItemPackings g fclassM topValS declist reqdItemsMap + let fHatM = CreateNewValuesForTLR g tlrS arityM fclassM envPackM + + // pass4: rewrite + if verboseTLR then + dprintf "TransExpr(rw)------\n" + + let expr, _ = + let penv: Pass4_RewriteAssembly.RewriteContext = + { + ccu = ccu + g = g + tlrS = tlrS + topValS = topValS + arityM = arityM + fclassM = fclassM + recShortCallS = recShortCallS + envPackM = envPackM + fHatM = fHatM + stackGuard = + StackGuard(InnerLambdasToTopLevelFunctionsStackGuardDepth, "InnerLambdasToTopLevelFunctionsStackGuardDepth") + } + + let z = Pass4_RewriteAssembly.rewriteState0 + Pass4_RewriteAssembly.TransImplFile penv z expr + + // pass5: copyExpr to restore "each bound is unique" property + // aka, copyExpr + if verboseTLR then + dprintf "copyExpr------\n" + + let expr = RecreateUniqueBounds g expr + + if verboseTLR then + dprintf "TLR-done------\n" + + expr + + with AbortTLR m -> + warning (Error(FSComp.SR.tlrLambdaLiftingOptimizationsNotApplied (), m)) + expr diff --git a/src/Compiler/Optimize/LowerCalls.fs b/src/Compiler/Optimize/LowerCalls.fs index 4fcbf9f36f1..0858cbf0f49 100644 --- a/src/Compiler/Optimize/LowerCalls.fs +++ b/src/Compiler/Optimize/LowerCalls.fs @@ -15,27 +15,28 @@ let LowerCallsRewriteStackGuardDepth = StackGuard.GetDepthOption "LowerCallsRewr let InterceptExpr g cont expr = match expr with - | Expr.Val (vref, flags, m) -> + | Expr.Val(vref, flags, m) -> match vref.ValReprInfo with - | Some arity -> Some (fst (AdjustValForExpectedValReprInfo g m vref flags arity)) + | Some arity -> Some(fst (AdjustValForExpectedValReprInfo g m vref flags arity)) | None -> None // App (Val v, tys, args) - | Expr.App (Expr.Val (vref, flags, _) as f0, f0ty, tyargsl, argsl, m) -> + | Expr.App(Expr.Val(vref, flags, _) as f0, f0ty, tyargsl, argsl, m) -> // Only transform if necessary, i.e. there are not enough arguments match vref.ValReprInfo with | Some(valReprInfo) -> let argsl = List.map cont argsl + let f0 = - if valReprInfo.AritiesOfArgs.Length > argsl.Length - then fst(AdjustValForExpectedValReprInfo g m vref flags valReprInfo) - else f0 + if valReprInfo.AritiesOfArgs.Length > argsl.Length then + fst (AdjustValForExpectedValReprInfo g m vref flags valReprInfo) + else + f0 - Some (MakeApplicationAndBetaReduce g (f0, f0ty, [tyargsl], argsl, m)) + Some(MakeApplicationAndBetaReduce g (f0, f0ty, [ tyargsl ], argsl, m)) | None -> None - | Expr.App (f0, f0ty, tyargsl, argsl, m) -> - Some (MakeApplicationAndBetaReduce g (f0, f0ty, [tyargsl], argsl, m) ) + | Expr.App(f0, f0ty, tyargsl, argsl, m) -> Some(MakeApplicationAndBetaReduce g (f0, f0ty, [ tyargsl ], argsl, m)) | _ -> None @@ -45,9 +46,12 @@ let InterceptExpr g cont expr = /// optimizer in opt.fs let LowerImplFile g assembly = let rwenv = - { PreIntercept = Some(InterceptExpr g) - PreInterceptBinding=None - PostTransform= (fun _ -> None) - RewriteQuotations=false - StackGuard = StackGuard(LowerCallsRewriteStackGuardDepth, "LowerCallsRewriteStackGuardDepth") } + { + PreIntercept = Some(InterceptExpr g) + PreInterceptBinding = None + PostTransform = (fun _ -> None) + RewriteQuotations = false + StackGuard = StackGuard(LowerCallsRewriteStackGuardDepth, "LowerCallsRewriteStackGuardDepth") + } + assembly |> RewriteImplFile rwenv diff --git a/src/Compiler/Optimize/LowerComputedCollections.fs b/src/Compiler/Optimize/LowerComputedCollections.fs index 4e74722e1bf..36f1eb8971a 100644 --- a/src/Compiler/Optimize/LowerComputedCollections.fs +++ b/src/Compiler/Optimize/LowerComputedCollections.fs @@ -21,42 +21,69 @@ open Import /// Build the 'test and dispose' part of a 'use' statement let BuildDisposableCleanup tcVal (g: TcGlobals) infoReader m (v: Val) = - let disposeMethod = - match GetIntrinsicMethInfosOfType infoReader (Some "Dispose") AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m g.system_IDisposable_ty with - | [x] -> x - | _ -> error(InternalError(FSComp.SR.tcCouldNotFindIDisposable(), m)) + let disposeMethod = + match + GetIntrinsicMethInfosOfType + infoReader + (Some "Dispose") + AccessibleFromSomewhere + AllowMultiIntfInstantiations.Yes + IgnoreOverrides + m + g.system_IDisposable_ty + with + | [ x ] -> x + | _ -> error (InternalError(FSComp.SR.tcCouldNotFindIDisposable (), m)) // For struct types the test is simpler if isStructTy g v.Type then assert (TypeFeasiblySubsumesType 0 g infoReader.amap m g.system_IDisposable_ty CanCoerce v.Type) // We can use NeverMutates here because the variable is going out of scope, there is no need to take a defensive // copy of it. - let disposeExpr, _ = BuildMethodCall tcVal g infoReader.amap NeverMutates m false disposeMethod NormalValUse [] [exprForVal v.Range v] [] None + let disposeExpr, _ = + BuildMethodCall tcVal g infoReader.amap NeverMutates m false disposeMethod NormalValUse [] [ exprForVal v.Range v ] [] None //callNonOverloadedILMethod g infoReader.amap m "Dispose" g.system_IDisposable_ty [exprForVal v.Range v] - + disposeExpr else - let disposeObjVar, disposeObjExpr = mkCompGenLocal m "objectToDispose" g.system_IDisposableNull_ty - let disposeExpr, _ = BuildMethodCall tcVal g infoReader.amap PossiblyMutates m false disposeMethod NormalValUse [] [disposeObjExpr] [] None - let inputExpr = mkCoerceExpr(exprForVal v.Range v, g.obj_ty_ambivalent, m, v.Type) + let disposeObjVar, disposeObjExpr = + mkCompGenLocal m "objectToDispose" g.system_IDisposableNull_ty + + let disposeExpr, _ = + BuildMethodCall tcVal g infoReader.amap PossiblyMutates m false disposeMethod NormalValUse [] [ disposeObjExpr ] [] None + + let inputExpr = mkCoerceExpr (exprForVal v.Range v, g.obj_ty_ambivalent, m, v.Type) mkIsInstConditional g m g.system_IDisposable_ty inputExpr disposeObjVar disposeExpr (mkUnit g m) let mkCallCollectorMethod tcVal (g: TcGlobals) infoReader m name collExpr args = let listCollectorTy = tyOfExpr g collExpr - let addMethod = - match GetIntrinsicMethInfosOfType infoReader (Some name) AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m listCollectorTy with - | [x] -> x - | _ -> error(InternalError("no " + name + " method found on Collector", m)) - let expr, _ = BuildMethodCall tcVal g infoReader.amap DefinitelyMutates m false addMethod NormalValUse [] [collExpr] args None + + let addMethod = + match + GetIntrinsicMethInfosOfType + infoReader + (Some name) + AccessibleFromSomewhere + AllowMultiIntfInstantiations.Yes + IgnoreOverrides + m + listCollectorTy + with + | [ x ] -> x + | _ -> error (InternalError("no " + name + " method found on Collector", m)) + + let expr, _ = + BuildMethodCall tcVal g infoReader.amap DefinitelyMutates m false addMethod NormalValUse [] [ collExpr ] args None + expr let mkCallCollectorAdd tcVal (g: TcGlobals) infoReader m collExpr arg = - mkCallCollectorMethod tcVal g infoReader m "Add" collExpr [arg] + mkCallCollectorMethod tcVal g infoReader m "Add" collExpr [ arg ] let mkCallCollectorAddMany tcVal (g: TcGlobals) infoReader m collExpr arg = - mkCallCollectorMethod tcVal g infoReader m "AddMany" collExpr [arg] + mkCallCollectorMethod tcVal g infoReader m "AddMany" collExpr [ arg ] let mkCallCollectorAddManyAndClose tcVal (g: TcGlobals) infoReader m collExpr arg = - mkCallCollectorMethod tcVal g infoReader m "AddManyAndClose" collExpr [arg] + mkCallCollectorMethod tcVal g infoReader m "AddManyAndClose" collExpr [ arg ] let mkCallCollectorClose tcVal (g: TcGlobals) infoReader m collExpr = mkCallCollectorMethod tcVal g infoReader m "Close" collExpr [] @@ -67,169 +94,217 @@ let LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr = //let collExpr = mkValAddr m false (mkLocalValRef collVal) let rec ConvertSeqExprCode isUninteresting isTailcall expr = match expr with - | SeqYield g (e, m) -> + | SeqYield g (e, m) -> let exprR = mkCallCollectorAdd tcVal g infoReader m collExpr e - Result.Ok (false, exprR) + Result.Ok(false, exprR) - | SeqDelay g (delayedExpr, _elemTy) -> - ConvertSeqExprCode isUninteresting isTailcall delayedExpr + | SeqDelay g (delayedExpr, _elemTy) -> ConvertSeqExprCode isUninteresting isTailcall delayedExpr | SeqAppend g (e1, e2, m) -> let res1 = ConvertSeqExprCode false false e1 let res2 = ConvertSeqExprCode false isTailcall e2 - match res1, res2 with - | Result.Ok (_, e1R), Result.Ok (closed2, e2R) -> + + match res1, res2 with + | Result.Ok(_, e1R), Result.Ok(closed2, e2R) -> let exprR = mkSequential m e1R e2R - Result.Ok (closed2, exprR) - | Result.Error msg, _ | _, Result.Error msg -> Result.Error msg + Result.Ok(closed2, exprR) + | Result.Error msg, _ + | _, Result.Error msg -> Result.Error msg | SeqWhile g (guardExpr, bodyExpr, spWhile, m) -> let resBody = ConvertSeqExprCode false false bodyExpr - match resBody with - | Result.Ok (_, bodyExprR) -> + + match resBody with + | Result.Ok(_, bodyExprR) -> let exprR = mkWhile g (spWhile, NoSpecialWhileLoopMarker, guardExpr, bodyExprR, m) - Result.Ok (false, exprR) + Result.Ok(false, exprR) | Result.Error msg -> Result.Error msg | SeqUsing g (resource, v, bodyExpr, _elemTy, spBind, m) -> let resBody = ConvertSeqExprCode false false bodyExpr - match resBody with - | Result.Ok (_, bodyExprR) -> + + match resBody with + | Result.Ok(_, bodyExprR) -> // printfn "found Seq.using" let cleanupE = BuildDisposableCleanup tcVal g infoReader m v - let exprR = - mkLet spBind m v resource + + let exprR = + mkLet + spBind + m + v + resource (mkTryFinally g (bodyExprR, cleanupE, m, tyOfExpr g bodyExpr, DebugPointAtTry.No, DebugPointAtFinally.No)) - Result.Ok (false, exprR) + + Result.Ok(false, exprR) | Result.Error msg -> Result.Error msg | SeqForEach g (inp, v, bodyExpr, _genElemTy, mFor, mIn, spIn) -> let resBody = ConvertSeqExprCode false false bodyExpr - match resBody with - | Result.Ok (_, bodyExprR) -> + + match resBody with + | Result.Ok(_, bodyExprR) -> // printfn "found Seq.for" let inpElemTy = v.Type let inpEnumTy = mkIEnumeratorTy g inpElemTy let enumv, enumve = mkCompGenLocal m "enum" inpEnumTy - let guardExpr = callNonOverloadedILMethod g amap m "MoveNext" inpEnumTy [enumve] + let guardExpr = callNonOverloadedILMethod g amap m "MoveNext" inpEnumTy [ enumve ] let cleanupE = BuildDisposableCleanup tcVal g infoReader m enumv // A debug point should get emitted prior to both the evaluation of 'inp' and the call to GetEnumerator - let addForDebugPoint e = Expr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, e) + let addForDebugPoint e = + Expr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, e) - let spInAsWhile = match spIn with DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + let spInAsWhile = + match spIn with + | DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m + | DebugPointAtInOrTo.No -> DebugPointAtWhile.No let exprR = - mkInvisibleLet mFor enumv (callNonOverloadedILMethod g amap mFor "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) - (mkTryFinally g - (mkWhile g (spInAsWhile, NoSpecialWhileLoopMarker, guardExpr, - (mkInvisibleLet mIn v - (callNonOverloadedILMethod g amap mIn "get_Current" inpEnumTy [enumve])) - bodyExprR, mIn), - cleanupE, - mFor, tyOfExpr g bodyExpr, DebugPointAtTry.No, DebugPointAtFinally.No)) + mkInvisibleLet + mFor + enumv + (callNonOverloadedILMethod g amap mFor "GetEnumerator" (mkSeqTy g inpElemTy) [ inp ]) + (mkTryFinally + g + (mkWhile + g + (spInAsWhile, + NoSpecialWhileLoopMarker, + guardExpr, + (mkInvisibleLet mIn v (callNonOverloadedILMethod g amap mIn "get_Current" inpEnumTy [ enumve ])) bodyExprR, + mIn), + cleanupE, + mFor, + tyOfExpr g bodyExpr, + DebugPointAtTry.No, + DebugPointAtFinally.No)) |> addForDebugPoint - Result.Ok (false, exprR) + + Result.Ok(false, exprR) | Result.Error msg -> Result.Error msg | SeqTryFinally g (bodyExpr, compensation, spTry, spFinally, m) -> let resBody = ConvertSeqExprCode false false bodyExpr - match resBody with - | Result.Ok (_, bodyExprR) -> + + match resBody with + | Result.Ok(_, bodyExprR) -> let exprR = mkTryFinally g (bodyExprR, compensation, m, tyOfExpr g bodyExpr, spTry, spFinally) - Result.Ok (false, exprR) + + Result.Ok(false, exprR) | Result.Error msg -> Result.Error msg | SeqEmpty g m -> let exprR = mkUnit g m Result.Ok(false, exprR) - | Expr.Sequential (x1, bodyExpr, NormalSeq, m) -> + | Expr.Sequential(x1, bodyExpr, NormalSeq, m) -> let resBody = ConvertSeqExprCode isUninteresting isTailcall bodyExpr - match resBody with - | Result.Ok (closed, bodyExprR) -> - let exprR = Expr.Sequential (x1, bodyExprR, NormalSeq, m) + + match resBody with + | Result.Ok(closed, bodyExprR) -> + let exprR = Expr.Sequential(x1, bodyExprR, NormalSeq, m) Result.Ok(closed, exprR) | Result.Error msg -> Result.Error msg - | Expr.Let (bind, bodyExpr, m, _) -> + | Expr.Let(bind, bodyExpr, m, _) -> let resBody = ConvertSeqExprCode isUninteresting isTailcall bodyExpr - match resBody with - | Result.Ok (closed, bodyExprR) -> + + match resBody with + | Result.Ok(closed, bodyExprR) -> let exprR = mkLetBind m bind bodyExprR Result.Ok(closed, exprR) | Result.Error msg -> Result.Error msg - | Expr.LetRec (binds, bodyExpr, m, _) -> + | Expr.LetRec(binds, bodyExpr, m, _) -> let resBody = ConvertSeqExprCode isUninteresting isTailcall bodyExpr - match resBody with - | Result.Ok (closed, bodyExprR) -> + + match resBody with + | Result.Ok(closed, bodyExprR) -> let exprR = mkLetRecBinds m binds bodyExprR Result.Ok(closed, exprR) | Result.Error msg -> Result.Error msg - | Expr.Match (spBind, mExpr, pt, targets, m, ty) -> + | Expr.Match(spBind, mExpr, pt, targets, m, ty) -> // lower all the targets. abandon if any fail to lower let resTargets = - targets |> Array.map (fun (TTarget(vs, targetExpr, flags)) -> - match ConvertSeqExprCode false false targetExpr with - | Result.Ok (_, targetExprR) -> - Result.Ok (TTarget(vs, targetExprR, flags)) - | Result.Error msg -> Result.Error msg ) - - if resTargets |> Array.forall (function Result.Ok _ -> true | _ -> false) then - let tglArray = Array.map (function Result.Ok v -> v | _ -> failwith "unreachable") resTargets + targets + |> Array.map (fun (TTarget(vs, targetExpr, flags)) -> + match ConvertSeqExprCode false false targetExpr with + | Result.Ok(_, targetExprR) -> Result.Ok(TTarget(vs, targetExprR, flags)) + | Result.Error msg -> Result.Error msg) + + if + resTargets + |> Array.forall (function + | Result.Ok _ -> true + | _ -> false) + then + let tglArray = + Array.map + (function + | Result.Ok v -> v + | _ -> failwith "unreachable") + resTargets let exprR = primMkMatch (spBind, mExpr, pt, tglArray, m, ty) Result.Ok(false, exprR) else - resTargets |> Array.pick (function Result.Error msg -> Some (Result.Error msg) | _ -> None) + resTargets + |> Array.pick (function + | Result.Error msg -> Some(Result.Error msg) + | _ -> None) | Expr.DebugPoint(dp, innerExpr) -> let resInnerExpr = ConvertSeqExprCode isUninteresting isTailcall innerExpr - match resInnerExpr with - | Result.Ok (flag, innerExprR) -> + + match resInnerExpr with + | Result.Ok(flag, innerExprR) -> let exprR = Expr.DebugPoint(dp, innerExprR) - Result.Ok (flag, exprR) + Result.Ok(flag, exprR) | Result.Error msg -> Result.Error msg // yield! e ---> (for x in e -> x) | arbitrarySeqExpr -> let m = arbitrarySeqExpr.Range + if isUninteresting then // printfn "FAILED - not worth compiling an unrecognized Seq.toList at %s " (stringOfRange m) - Result.Error () - else + Result.Error() + else if // If we're the final in a sequential chain then we can AddMany, Close and return - if isTailcall then - let exprR = mkCallCollectorAddManyAndClose tcVal (g: TcGlobals) infoReader m collExpr arbitrarySeqExpr - // Return 'true' to indicate the collector was closed and the overall result of the expression is the result - Result.Ok(true, exprR) - else - let exprR = mkCallCollectorAddMany tcVal (g: TcGlobals) infoReader m collExpr arbitrarySeqExpr - Result.Ok(false, exprR) + isTailcall + then + let exprR = + mkCallCollectorAddManyAndClose tcVal (g: TcGlobals) infoReader m collExpr arbitrarySeqExpr + // Return 'true' to indicate the collector was closed and the overall result of the expression is the result + Result.Ok(true, exprR) + else + let exprR = + mkCallCollectorAddMany tcVal (g: TcGlobals) infoReader m collExpr arbitrarySeqExpr + Result.Ok(false, exprR) // Perform conversion - match ConvertSeqExprCode true true overallSeqExpr with - | Result.Ok (closed, overallSeqExprR) -> - mkInvisibleLet m collVal (mkDefault (m, collectorTy)) - (if closed then - // If we ended with AddManyAndClose then we're done - overallSeqExprR + match ConvertSeqExprCode true true overallSeqExpr with + | Result.Ok(closed, overallSeqExprR) -> + mkInvisibleLet + m + collVal + (mkDefault (m, collectorTy)) + (if closed then + // If we ended with AddManyAndClose then we're done + overallSeqExprR else - mkSequential m - overallSeqExprR - (mkCallCollectorClose tcVal g infoReader m collExpr)) + mkSequential m overallSeqExprR (mkCallCollectorClose tcVal g infoReader m collExpr)) |> Some - | Result.Error () -> - None + | Result.Error() -> None -let (|OptionalCoerce|) expr = +let (|OptionalCoerce|) expr = match expr with - | Expr.Op (TOp.Coerce, _, [arg], _) -> arg + | Expr.Op(TOp.Coerce, _, [ arg ], _) -> arg | _ -> expr // Making 'seq' optional means this kicks in for FSharp.Core, see TcArrayOrListComputedExpression @@ -238,25 +313,23 @@ let (|OptionalCoerce|) expr = let (|OptionalSeq|_|) g amap expr = match expr with // use 'seq { ... }' as an indicator - | Seq g (e, elemTy) -> - ValueSome (e, elemTy) - | _ -> - // search for the relevant element type - match tyOfExpr g expr with - | SeqElemTy g amap expr.Range elemTy -> - ValueSome (expr, elemTy) - | _ -> ValueNone + | Seq g (e, elemTy) -> ValueSome(e, elemTy) + | _ -> + // search for the relevant element type + match tyOfExpr g expr with + | SeqElemTy g amap expr.Range elemTy -> ValueSome(expr, elemTy) + | _ -> ValueNone [] let (|SeqToList|_|) g expr = match expr with - | ValApp g g.seq_to_list_vref (_, [seqExpr], m) -> ValueSome (seqExpr, m) + | ValApp g g.seq_to_list_vref (_, [ seqExpr ], m) -> ValueSome(seqExpr, m) | _ -> ValueNone [] let (|SeqToArray|_|) g expr = match expr with - | ValApp g g.seq_to_array_vref (_, [seqExpr], m) -> ValueSome (seqExpr, m) + | ValApp g g.seq_to_array_vref (_, [ seqExpr ], m) -> ValueSome(seqExpr, m) | _ -> ValueNone module List = @@ -266,7 +339,7 @@ module List = let srcListTy = tyOfExpr g srcList mkCompGenLetMutableIn m "collector" collectorTy (mkDefault (m, collectorTy)) (fun (_, collector) -> - let reader = InfoReader (g, amap) + let reader = InfoReader(g, amap) // Adapted from DetectAndOptimizeForEachExpression in TypedTreeOps.fs. @@ -278,29 +351,44 @@ module List = let srcElemTy = loopVal.val_type let guardExpr = mkNonNullTest g mFor nextExpr - let headOrDefaultExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [srcElemTy], IndexHead, mIn) - let tailOrNullExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [srcElemTy], IndexTail, mIn) + + let headOrDefaultExpr = + mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [ srcElemTy ], IndexHead, mIn) + + let tailOrNullExpr = + mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [ srcElemTy ], IndexTail, mIn) let body = - mkInvisibleLet mIn loopVal headOrDefaultExpr - (mkSequential mIn + mkInvisibleLet + mIn + loopVal + headOrDefaultExpr + (mkSequential + mIn (mkCallCollectorAdd tcVal g reader mIn collector body) - (mkSequential mIn + (mkSequential + mIn (mkValSet mIn (mkLocalValRef currentVar) nextExpr) (mkValSet mIn (mkLocalValRef nextVar) tailOrNullExpr))) let loop = // let mutable current = enumerableExpr - mkLet spFor m currentVar srcList + mkLet + spFor + m + currentVar + srcList // let mutable next = current.TailOrNull - (mkInvisibleLet mFor nextVar tailOrNullExpr + (mkInvisibleLet + mFor + nextVar + tailOrNullExpr // while nonNull next do - (mkWhile g (spInWhile, WhileLoopForCompiledForEachExprMarker, guardExpr, body, mBody))) + (mkWhile g (spInWhile, WhileLoopForCompiledForEachExprMarker, guardExpr, body, mBody))) let close = mkCallCollectorClose tcVal g reader m collector - mkSequential m loop close - ) + mkSequential m loop close) /// Makes an expression that will build a list from an integral range. let mkFromIntegralRange @@ -324,7 +412,7 @@ module List = /// collector.Close () let mkListInit mkLoop = mkCompGenLetMutableIn m "collector" collectorTy (mkDefault (m, collectorTy)) (fun (_, collector) -> - let reader = InfoReader (g, amap) + let reader = InfoReader(g, amap) let loop = mkLoop (fun _idxVar loopVar -> @@ -336,25 +424,15 @@ module List = mkCallCollectorAdd tcVal g reader mBody collector body) let close = mkCallCollectorClose tcVal g reader mBody collector - mkSequential m loop close - ) + mkSequential m loop close) - mkOptimizedRangeLoop - g - (mBody, mFor, mIn, spInWhile) - (rangeTy, rangeExpr) - (start, step, finish) - (fun count mkLoop -> - match count with - | Expr.Const (value = IntegralConst.Zero) -> - mkNil g m overallElemTy - - | Expr.Const (value = _nonzeroConstant) -> - mkListInit mkLoop - - | _dynamicCount -> - mkListInit mkLoop - ) + mkOptimizedRangeLoop g (mBody, mFor, mIn, spInWhile) (rangeTy, rangeExpr) (start, step, finish) (fun count mkLoop -> + match count with + | Expr.Const(value = IntegralConst.Zero) -> mkNil g m overallElemTy + + | Expr.Const(value = _nonzeroConstant) -> mkListInit mkLoop + + | _dynamicCount -> mkListInit mkLoop) module Array = let private mkIlInstr (g: TcGlobals) specific any ilTy = @@ -381,17 +459,13 @@ module Array = /// (# "newarr !0" type ('T) count : 'T array #) let array = - mkAsmExpr - ( - [I_newarr (ILArrayShape.SingleDimensional, destIlTy)], - [], - [len], - [arrayTy], - m - ) + mkAsmExpr ([ I_newarr(ILArrayShape.SingleDimensional, destIlTy) ], [], [ len ], [ arrayTy ], m) - let ldelem = mkIlInstr g I_ldelem (fun ilTy -> I_ldelem_any (ILArrayShape.SingleDimensional, ilTy)) srcIlTy - let stelem = mkIlInstr g I_stelem (fun ilTy -> I_stelem_any (ILArrayShape.SingleDimensional, ilTy)) destIlTy + let ldelem = + mkIlInstr g I_ldelem (fun ilTy -> I_ldelem_any(ILArrayShape.SingleDimensional, ilTy)) srcIlTy + + let stelem = + mkIlInstr g I_stelem (fun ilTy -> I_stelem_any(ILArrayShape.SingleDimensional, ilTy)) destIlTy let mapping = mkCompGenLetIn m (nameof array) arrayTy array (fun (_, array) -> @@ -404,40 +478,36 @@ module Array = let freeLocals = (freeInExpr CollectLocals body).FreeLocals if freeLocals.Contains loopVal then - mkInvisibleLet mBody loopVal (mkAsmExpr ([ldelem], [], [srcArray; i], [loopVal.val_type], mBody)) body + mkInvisibleLet + mBody + loopVal + (mkAsmExpr ([ ldelem ], [], [ srcArray; i ], [ loopVal.val_type ], mBody)) + body else body // destArray[i] <- body srcArray[i] - let setArrSubI = mkAsmExpr ([stelem], [], [array; i; body], [], mIn) + let setArrSubI = mkAsmExpr ([ stelem ], [], [ array; i; body ], [], mIn) // i <- i + 1 - let incrI = mkValSet mIn (mkLocalValRef iVal) (mkAsmExpr ([AI_add], [], [i; mkTypedOne g mIn g.int32_ty], [g.int32_ty], mIn)) + let incrI = + mkValSet + mIn + (mkLocalValRef iVal) + (mkAsmExpr ([ AI_add ], [], [ i; mkTypedOne g mIn g.int32_ty ], [ g.int32_ty ], mIn)) mkSequential mIn setArrSubI incrI let guard = mkILAsmClt g mFor i (mkLdlen g mFor array) - let loop = - mkWhile - g - ( - spInWhile, - NoSpecialWhileLoopMarker, - guard, - body, - mIn - ) + let loop = mkWhile g (spInWhile, NoSpecialWhileLoopMarker, guard, body, mIn) // while i < array.Length do done // array - mkSequential m loop array - ) - ) + mkSequential m loop array)) // Add a debug point at the `for`, before anything gets evaluated. - Expr.DebugPoint (DebugPointAtLeafExpr.Yes mFor, mapping) - ) + Expr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, mapping)) /// Whether to check for overflow when converting a value to a native int. [] @@ -450,7 +520,19 @@ module Array = | NoCheckOvf /// Makes an expression that will build an array from an integral range. - let mkFromIntegralRange g m (mBody, _spFor, _spIn, mFor, mIn, spInWhile) rangeTy ilTy overallElemTy (rangeExpr: Expr) start step finish (body: (Val * Expr) option) = + let mkFromIntegralRange + g + m + (mBody, _spFor, _spIn, mFor, mIn, spInWhile) + rangeTy + ilTy + overallElemTy + (rangeExpr: Expr) + start + step + finish + (body: (Val * Expr) option) + = let arrayTy = mkArrayType g overallElemTy let convToNativeInt ovf expr = @@ -463,28 +545,22 @@ module Array = | CheckOvf -> AI_conv_ovf_un DT_I if typeEquivAux EraseMeasures g ty g.int64_ty then - mkAsmExpr ([conv], [], [expr], [g.nativeint_ty], mIn) + mkAsmExpr ([ conv ], [], [ expr ], [ g.nativeint_ty ], mIn) elif typeEquivAux EraseMeasures g ty g.nativeint_ty then - mkAsmExpr ([conv], [], [mkAsmExpr ([AI_conv DT_I8], [], [expr], [g.int64_ty], mIn)], [g.nativeint_ty], mIn) + mkAsmExpr ([ conv ], [], [ mkAsmExpr ([ AI_conv DT_I8 ], [], [ expr ], [ g.int64_ty ], mIn) ], [ g.nativeint_ty ], mIn) elif typeEquivAux EraseMeasures g ty g.uint64_ty then - mkAsmExpr ([conv], [], [expr], [g.nativeint_ty], mIn) + mkAsmExpr ([ conv ], [], [ expr ], [ g.nativeint_ty ], mIn) elif typeEquivAux EraseMeasures g ty g.unativeint_ty then - mkAsmExpr ([conv], [], [mkAsmExpr ([AI_conv DT_U8], [], [expr], [g.uint64_ty], mIn)], [g.nativeint_ty], mIn) + mkAsmExpr ([ conv ], [], [ mkAsmExpr ([ AI_conv DT_U8 ], [], [ expr ], [ g.uint64_ty ], mIn) ], [ g.nativeint_ty ], mIn) else expr - let stelem = mkIlInstr g I_stelem (fun ilTy -> I_stelem_any (ILArrayShape.SingleDimensional, ilTy)) ilTy + let stelem = + mkIlInstr g I_stelem (fun ilTy -> I_stelem_any(ILArrayShape.SingleDimensional, ilTy)) ilTy /// (# "newarr !0" type ('T) count : 'T array #) let mkNewArray count = - mkAsmExpr - ( - [I_newarr (ILArrayShape.SingleDimensional, ilTy)], - [], - [convToNativeInt CheckOvf count], - [arrayTy], - m - ) + mkAsmExpr ([ I_newarr(ILArrayShape.SingleDimensional, ilTy) ], [], [ convToNativeInt CheckOvf count ], [ arrayTy ], m) /// let array = (# "newarr !0" type ('T) count : 'T array #) in /// @@ -498,48 +574,39 @@ module Array = |> Option.map (fun (loopVal, body) -> mkInvisibleLet mBody loopVal loopVar body) |> Option.defaultValue loopVar - mkAsmExpr ([stelem], [], [array; convToNativeInt NoCheckOvf idxVar; body], [], mBody)) + mkAsmExpr ([ stelem ], [], [ array; convToNativeInt NoCheckOvf idxVar; body ], [], mBody)) mkSequential m loop array) - mkOptimizedRangeLoop - g - (mBody, mFor, mIn, spInWhile) - (rangeTy, rangeExpr) - (start, step, finish) - (fun count mkLoop -> - match count with - | Expr.Const (value = IntegralConst.Zero) -> - mkArray (overallElemTy, [], m) - - | Expr.Const (value = _nonzeroConstant) -> - mkArrayInit count mkLoop - - | _dynamicCount -> - mkCompGenLetIn m (nameof count) (tyOfExpr g count) count (fun (_, count) -> - let countTy = tyOfExpr g count - - // if count = 0 then - // [||] - // else - // let array = (# "newarr !0" type ('T) count : 'T array #) in - // - // array - mkCond - DebugPointAtBinding.NoneAtInvisible - m - arrayTy - (mkILAsmCeq g m count (mkTypedZero g m countTy)) - (mkArray (overallElemTy, [], m)) - (mkArrayInit count mkLoop) - ) - ) + mkOptimizedRangeLoop g (mBody, mFor, mIn, spInWhile) (rangeTy, rangeExpr) (start, step, finish) (fun count mkLoop -> + match count with + | Expr.Const(value = IntegralConst.Zero) -> mkArray (overallElemTy, [], m) + + | Expr.Const(value = _nonzeroConstant) -> mkArrayInit count mkLoop + + | _dynamicCount -> + mkCompGenLetIn m (nameof count) (tyOfExpr g count) count (fun (_, count) -> + let countTy = tyOfExpr g count + + // if count = 0 then + // [||] + // else + // let array = (# "newarr !0" type ('T) count : 'T array #) in + // + // array + mkCond + DebugPointAtBinding.NoneAtInvisible + m + arrayTy + (mkILAsmCeq g m count (mkTypedZero g m countTy)) + (mkArray (overallElemTy, [], m)) + (mkArrayInit count mkLoop))) /// Matches Seq.singleton and returns the body expression. [] let (|SeqSingleton|_|) g expr : Expr voption = match expr with - | ValApp g g.seq_singleton_vref (_, [body], _) -> ValueSome body + | ValApp g g.seq_singleton_vref (_, [ body ], _) -> ValueSome body | _ -> ValueNone /// Matches the compiled representation of the mapping in @@ -557,23 +624,27 @@ let (|SeqSingleton|_|) g expr : Expr voption = let (|SingleYield|_|) g expr : Expr voption = let rec loop expr cont = match expr with - | Expr.Let (binding, DebugPoints (SeqSingleton g body, debug), m, frees) -> - ValueSome (cont (Expr.Let (binding, debug body, m, frees))) + | Expr.Let(binding, DebugPoints(SeqSingleton g body, debug), m, frees) -> ValueSome(cont (Expr.Let(binding, debug body, m, frees))) - | Expr.Let (binding, DebugPoints (body, debug), m, frees) -> - loop body (cont << fun body -> Expr.Let (binding, debug body, m, frees)) + | Expr.Let(binding, DebugPoints(body, debug), m, frees) -> loop body (cont << fun body -> Expr.Let(binding, debug body, m, frees)) - | Expr.Sequential (expr1, DebugPoints (SeqSingleton g body, debug), kind, m) -> - ValueSome (cont (Expr.Sequential (expr1, debug body, kind, m))) + | Expr.Sequential(expr1, DebugPoints(SeqSingleton g body, debug), kind, m) -> + ValueSome(cont (Expr.Sequential(expr1, debug body, kind, m))) - | Expr.Sequential (expr1, DebugPoints (body, debug), kind, m) -> - loop body (cont << fun body -> Expr.Sequential (expr1, debug body, kind, m)) + | Expr.Sequential(expr1, DebugPoints(body, debug), kind, m) -> + loop body (cont << fun body -> Expr.Sequential(expr1, debug body, kind, m)) - | Expr.Match (debugPoint, mInput, decision, [|TTarget (boundVals, DebugPoints (SeqSingleton g body, debug), isStateVarFlags)|], mFull, exprType) -> - ValueSome (cont (Expr.Match (debugPoint, mInput, decision, [|TTarget (boundVals, debug body, isStateVarFlags)|], mFull, exprType))) + | Expr.Match(debugPoint, + mInput, + decision, + [| TTarget(boundVals, DebugPoints(SeqSingleton g body, debug), isStateVarFlags) |], + mFull, + exprType) -> + ValueSome( + cont (Expr.Match(debugPoint, mInput, decision, [| TTarget(boundVals, debug body, isStateVarFlags) |], mFull, exprType)) + ) - | SeqSingleton g body -> - ValueSome (cont body) + | SeqSingleton g body -> ValueSome(cont body) | _ -> ValueNone @@ -593,17 +664,15 @@ let (|SingleYield|_|) g expr : Expr voption = /// let y = f () in [for … in … -> …] /// /// f (); g (); [for … in … -> …] -let gatherPrelude ((|App|_|) : _ -> _ voption) expr = +let gatherPrelude ((|App|_|): _ -> _ voption) expr = let rec loop expr cont = match expr with - | Expr.Let (binding, DebugPoints (body, debug), m, frees) -> - loop body (cont << fun body -> Expr.Let (binding, debug body, m, frees)) + | Expr.Let(binding, DebugPoints(body, debug), m, frees) -> loop body (cont << fun body -> Expr.Let(binding, debug body, m, frees)) - | Expr.Sequential (expr1, DebugPoints (body, debug), kind, m) -> - loop body (cont << fun body -> Expr.Sequential (expr1, debug body, kind, m)) + | Expr.Sequential(expr1, DebugPoints(body, debug), kind, m) -> + loop body (cont << fun body -> Expr.Sequential(expr1, debug body, kind, m)) - | App contents -> - ValueSome (cont, contents) + | App contents -> ValueSome(cont, contents) | _ -> ValueNone @@ -617,12 +686,23 @@ let gatherPrelude ((|App|_|) : _ -> _ voption) expr = [] let (|SeqMap|_|) g = gatherPrelude (function - | ValApp g g.seq_map_vref ([ty1; ty2], [Expr.Lambda (valParams = [loopVal]; bodyExpr = body; range = mIn) as mapping; input], mFor) -> - let spIn = match mIn.NotedSourceConstruct with NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn | _ -> DebugPointAtInOrTo.No + | ValApp g g.seq_map_vref ([ ty1; ty2 ], + [ Expr.Lambda(valParams = [ loopVal ]; bodyExpr = body; range = mIn) as mapping; input ], + mFor) -> + let spIn = + match mIn.NotedSourceConstruct with + | NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn + | _ -> DebugPointAtInOrTo.No + let spFor = DebugPointAtBinding.Yes mFor - let spInWhile = match spIn with DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + + let spInWhile = + match spIn with + | DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m + | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + let ranges = body.Range, spFor, spIn, mFor, mIn, spInWhile - ValueSome (ty1, ty2, input, mapping, loopVal, body, ranges) + ValueSome(ty1, ty2, input, mapping, loopVal, body, ranges) | _ -> ValueNone) @@ -635,12 +715,24 @@ let (|SeqMap|_|) g = [] let (|SeqCollectSingle|_|) g = gatherPrelude (function - | ValApp g g.seq_collect_vref ([ty1; _; ty2], [Expr.Lambda (valParams = [loopVal]; bodyExpr = DebugPoints (SingleYield g body, debug); range = mIn) as mapping; input], mFor) -> - let spIn = match mIn.NotedSourceConstruct with NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn | _ -> DebugPointAtInOrTo.No + | ValApp g g.seq_collect_vref ([ ty1; _; ty2 ], + [ Expr.Lambda(valParams = [ loopVal ]; bodyExpr = DebugPoints(SingleYield g body, debug); range = mIn) as mapping + input ], + mFor) -> + let spIn = + match mIn.NotedSourceConstruct with + | NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn + | _ -> DebugPointAtInOrTo.No + let spFor = DebugPointAtBinding.Yes mFor - let spInWhile = match spIn with DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + + let spInWhile = + match spIn with + | DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m + | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + let ranges = body.Range, spFor, spIn, mFor, mIn, spInWhile - ValueSome (ty1, ty2, input, mapping, loopVal, debug body, ranges) + ValueSome(ty1, ty2, input, mapping, loopVal, debug body, ranges) | _ -> ValueNone) @@ -657,54 +749,89 @@ let (|SimpleMapping|_|) g expr = // for … in … -> … // for … in … do yield … // for … in … do … - | ValApp g g.seq_delay_vref (_, [Expr.Lambda (bodyExpr = DebugPoints (SeqMap g (cont, (ty1, ty2, input, mapping, loopVal, body, ranges)), debug))], _) + | ValApp g g.seq_delay_vref (_, + [ Expr.Lambda( + bodyExpr = DebugPoints(SeqMap g (cont, (ty1, ty2, input, mapping, loopVal, body, ranges)), debug)) ], + _) // for … in … do f (); …; yield … // for … in … do let … = … in yield … // for … in … do f (); …; … // for … in … do let … = … in … - | ValApp g g.seq_delay_vref (_, [Expr.Lambda (bodyExpr = DebugPoints (SeqCollectSingle g (cont, (ty1, ty2, input, mapping, loopVal, body, ranges)), debug))], _) -> - ValueSome (debug >> cont, (ty1, ty2, input, mapping, loopVal, body, ranges)) + | ValApp g g.seq_delay_vref (_, + [ Expr.Lambda( + bodyExpr = DebugPoints(SeqCollectSingle g (cont, (ty1, ty2, input, mapping, loopVal, body, ranges)), + debug)) ], + _) -> ValueSome(debug >> cont, (ty1, ty2, input, mapping, loopVal, body, ranges)) | _ -> ValueNone [] let (|Array|_|) g (OptionalCoerce expr) = - if isArray1DTy g (tyOfExpr g expr) then ValueSome expr - else ValueNone + if isArray1DTy g (tyOfExpr g expr) then + ValueSome expr + else + ValueNone [] let (|List|_|) g (OptionalCoerce expr) = - if isListTy g (tyOfExpr g expr) then ValueSome expr - else ValueNone + if isListTy g (tyOfExpr g expr) then + ValueSome expr + else + ValueNone let LowerComputedListOrArrayExpr tcVal (g: TcGlobals) amap ilTyForTy overallExpr = // If ListCollector is in FSharp.Core then this optimization kicks in if g.ListCollector_tcr.CanDeref then match overallExpr with // […] - | SeqToList g (OptionalCoerce (OptionalSeq g amap (overallSeqExpr, overallElemTy)), m) -> + | SeqToList g (OptionalCoerce(OptionalSeq g amap (overallSeqExpr, overallElemTy)), m) -> match overallSeqExpr with // [for … in xs -> …] (* When xs is a list. *) | SimpleMapping g (cont, (_, _, List g list, _, loopVal, body, ranges)) when g.langVersion.SupportsFeature LanguageFeature.LowerSimpleMappingsInComprehensionsToFastLoops -> - Some (cont (List.mkMap tcVal g amap m ranges list overallElemTy loopVal body)) + Some(cont (List.mkMap tcVal g amap m ranges list overallElemTy loopVal body)) // [start..finish] // [start..step..finish] | IntegralRange g (rangeTy, (start, step, finish)) when g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops -> - let ranges = m, DebugPointAtBinding.NoneAtInvisible, DebugPointAtInOrTo.No, m, m, DebugPointAtWhile.No - Some (List.mkFromIntegralRange tcVal g amap m ranges rangeTy overallElemTy overallSeqExpr start step finish None) + let ranges = + m, DebugPointAtBinding.NoneAtInvisible, DebugPointAtInOrTo.No, m, m, DebugPointAtWhile.No + + Some(List.mkFromIntegralRange tcVal g amap m ranges rangeTy overallElemTy overallSeqExpr start step finish None) // [for … in start..finish -> …] // [for … in start..step..finish -> …] - | SimpleMapping g (cont, (_, _, DebugPoints (rangeExpr & IntegralRange g (rangeTy, (start, step, finish)), debug), _, loopVal, body, ranges)) when - g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops - -> - Some (cont (debug (List.mkFromIntegralRange tcVal g amap m ranges rangeTy overallElemTy rangeExpr start step finish (Some (loopVal, body))))) + | SimpleMapping g (cont, + (_, + _, + DebugPoints(rangeExpr & IntegralRange g (rangeTy, (start, step, finish)), debug), + _, + loopVal, + body, + ranges)) when g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops -> + Some( + cont ( + debug ( + List.mkFromIntegralRange + tcVal + g + amap + m + ranges + rangeTy + overallElemTy + rangeExpr + start + step + finish + (Some(loopVal, body)) + ) + ) + ) // [(* Anything more complex. *)] | _ -> @@ -712,28 +839,65 @@ let LowerComputedListOrArrayExpr tcVal (g: TcGlobals) amap ilTyForTy overallExpr LowerComputedListOrArraySeqExpr tcVal g amap m collectorTy overallSeqExpr // [|…|] - | SeqToArray g (OptionalCoerce (OptionalSeq g amap (overallSeqExpr, overallElemTy)), m) -> + | SeqToArray g (OptionalCoerce(OptionalSeq g amap (overallSeqExpr, overallElemTy)), m) -> match overallSeqExpr with // [|for … in xs -> …|] (* When xs is an array. *) | SimpleMapping g (cont, (ty1, ty2, Array g array, _, loopVal, body, ranges)) when g.langVersion.SupportsFeature LanguageFeature.LowerSimpleMappingsInComprehensionsToFastLoops -> - Some (cont (Array.mkMap g m ranges array (ilTyForTy ty1) (ilTyForTy ty2) overallElemTy loopVal body)) + Some(cont (Array.mkMap g m ranges array (ilTyForTy ty1) (ilTyForTy ty2) overallElemTy loopVal body)) // [|start..finish|] // [|start..step..finish|] | IntegralRange g (rangeTy, (start, step, finish)) when g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops -> - let ranges = m, DebugPointAtBinding.NoneAtInvisible, DebugPointAtInOrTo.No, m, m, DebugPointAtWhile.No - Some (Array.mkFromIntegralRange g m ranges rangeTy (ilTyForTy overallElemTy) overallElemTy overallSeqExpr start step finish None) + let ranges = + m, DebugPointAtBinding.NoneAtInvisible, DebugPointAtInOrTo.No, m, m, DebugPointAtWhile.No + + Some( + Array.mkFromIntegralRange + g + m + ranges + rangeTy + (ilTyForTy overallElemTy) + overallElemTy + overallSeqExpr + start + step + finish + None + ) // [|for … in start..finish -> …|] // [|for … in start..step..finish -> …|] - | SimpleMapping g (cont, (_, _, DebugPoints (rangeExpr & IntegralRange g (rangeTy, (start, step, finish)), debug), _, loopVal, body, ranges)) when - g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops - -> - Some (cont (debug (Array.mkFromIntegralRange g m ranges rangeTy (ilTyForTy overallElemTy) overallElemTy rangeExpr start step finish (Some (loopVal, body))))) + | SimpleMapping g (cont, + (_, + _, + DebugPoints(rangeExpr & IntegralRange g (rangeTy, (start, step, finish)), debug), + _, + loopVal, + body, + ranges)) when g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops -> + Some( + cont ( + debug ( + Array.mkFromIntegralRange + g + m + ranges + rangeTy + (ilTyForTy overallElemTy) + overallElemTy + rangeExpr + start + step + finish + (Some(loopVal, body)) + ) + ) + ) // [|(* Anything more complex. *)|] | _ -> diff --git a/src/Compiler/Optimize/LowerLocalMutables.fs b/src/Compiler/Optimize/LowerLocalMutables.fs index 0899875242d..c84cfd39838 100644 --- a/src/Compiler/Optimize/LowerLocalMutables.fs +++ b/src/Compiler/Optimize/LowerLocalMutables.fs @@ -1,10 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -module internal FSharp.Compiler.LowerLocalMutables +module internal FSharp.Compiler.LowerLocalMutables open Internal.Utilities.Collections open Internal.Utilities.Library.Extras -open FSharp.Compiler +open FSharp.Compiler open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics @@ -17,117 +17,141 @@ open FSharp.Compiler.TypeRelations let AutoboxRewriteStackGuardDepth = StackGuard.GetDepthOption "AutoboxRewrite" -type cenv = - { g: TcGlobals - amap: Import.ImportMap } +type cenv = + { + g: TcGlobals + amap: Import.ImportMap + } override _.ToString() = "" /// Find all the mutable locals that escape a method, function or lambda expression let DecideEscapes syntacticArgs body = - let isMutableEscape v = - let passedIn = ListSet.contains valEq v syntacticArgs - not passedIn && - v.IsMutable && - v.ValReprInfo.IsNone && - not (Optimizer.IsKnownOnlyMutableBeforeUse (mkLocalValRef v)) + let isMutableEscape v = + let passedIn = ListSet.contains valEq v syntacticArgs + + not passedIn + && v.IsMutable + && v.ValReprInfo.IsNone + && not (Optimizer.IsKnownOnlyMutableBeforeUse(mkLocalValRef v)) let frees = freeInExpr (CollectLocalsWithStackGuard()) body - frees.FreeLocals |> Zset.filter isMutableEscape + frees.FreeLocals |> Zset.filter isMutableEscape /// Find all the mutable locals that escape a lambda expression, ignoring the arguments to the lambda -let DecideLambda exprF cenv valReprInfo expr exprTy z = - match stripDebugPoints expr with +let DecideLambda exprF cenv valReprInfo expr exprTy z = + match stripDebugPoints expr with | Expr.Lambda _ | Expr.TyLambda _ -> - let _tps, ctorThisValOpt, baseValOpt, vsl, body, _bodyty = destLambdaWithValReprInfo cenv.g cenv.amap valReprInfo (expr, exprTy) + let _tps, ctorThisValOpt, baseValOpt, vsl, body, _bodyty = + destLambdaWithValReprInfo cenv.g cenv.amap valReprInfo (expr, exprTy) + let snoc = fun x y -> y :: x let args = List.concat vsl let args = Option.fold snoc args baseValOpt - let syntacticArgs = Option.fold snoc args ctorThisValOpt - + let syntacticArgs = Option.fold snoc args ctorThisValOpt + let z = Zset.union z (DecideEscapes syntacticArgs body) - let z = match exprF with Some f -> f z body | None -> z + + let z = + match exprF with + | Some f -> f z body + | None -> z + z | _ -> z -///Special cases where representation uses Lambda. -/// Handle these as special cases since mutables are allowed inside their bodies +///Special cases where representation uses Lambda. +/// Handle these as special cases since mutables are allowed inside their bodies let DecideExprOp exprF noInterceptF (z: Zset) (expr: Expr) (op, tyargs, args) = - match op, tyargs, args with - | TOp.While _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)] -> - exprF (exprF z e1) e2 + match op, tyargs, args with + | TOp.While _, _, [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ] -> exprF (exprF z e1) e2 - | TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> - exprF (exprF z e1) e2 + | TOp.TryFinally _, [ _ ], [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ] -> exprF (exprF z e1) e2 - | TOp.IntegerForLoop _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> + | TOp.IntegerForLoop _, + _, + [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _); Expr.Lambda(_, _, _, [ _ ], e3, _, _) ] -> exprF (exprF (exprF z e1) e2) e3 - | TOp.TryWith _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], _e2, _, _); Expr.Lambda (_, _, _, [_], e3, _, _)] -> + | TOp.TryWith _, + [ _ ], + [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], _e2, _, _); Expr.Lambda(_, _, _, [ _ ], e3, _, _) ] -> exprF (exprF (exprF z e1) _e2) e3 - // In Check code it said - // e2; -- don't check filter body - duplicates logic in 'catch' body - // Is that true for this code too? - | _ -> - noInterceptF z expr - -/// Find all the mutable locals that escape a lambda expression or object expression -let DecideExpr cenv exprF noInterceptF z expr = + // In Check code it said + // e2; -- don't check filter body - duplicates logic in 'catch' body + // Is that true for this code too? + | _ -> noInterceptF z expr + +/// Find all the mutable locals that escape a lambda expression or object expression +let DecideExpr cenv exprF noInterceptF z expr = let g = cenv.g - match stripDebugPoints expr with - | Expr.Lambda (_, _ctorThisValOpt, _baseValOpt, argvs, _, m, bodyTy) -> - let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) - let ty = mkMultiLambdaTy g m argvs bodyTy + + match stripDebugPoints expr with + | Expr.Lambda(_, _ctorThisValOpt, _baseValOpt, argvs, _, m, bodyTy) -> + let valReprInfo = + ValReprInfo([], [ argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1) ], ValReprInfo.unnamedRetVal) + + let ty = mkMultiLambdaTy g m argvs bodyTy DecideLambda (Some exprF) cenv valReprInfo expr ty z - | Expr.TyLambda (_, tps, _, _m, bodyTy) -> - let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - let ty = mkForallTyIfNeeded tps bodyTy - DecideLambda (Some exprF) cenv valReprInfo expr ty z + | Expr.TyLambda(_, tps, _, _m, bodyTy) -> + let valReprInfo = + ValReprInfo(ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - | Expr.Obj (_, _, baseValOpt, superInitCall, overrides, iimpls, _m) -> - let CheckMethod z (TObjExprMethod(_, _attribs, _tps, vs, body, _m)) = + let ty = mkForallTyIfNeeded tps bodyTy + DecideLambda (Some exprF) cenv valReprInfo expr ty z + + | Expr.Obj(_, _, baseValOpt, superInitCall, overrides, iimpls, _m) -> + let CheckMethod z (TObjExprMethod(_, _attribs, _tps, vs, body, _m)) = let vs = List.concat vs - let syntacticArgs = (match baseValOpt with Some x -> x :: vs | None -> vs) + + let syntacticArgs = + (match baseValOpt with + | Some x -> x :: vs + | None -> vs) + let z = Zset.union z (DecideEscapes syntacticArgs body) exprF z body - let CheckMethods z l = (z, l) ||> List.fold CheckMethod - - let CheckInterfaceImpl z (_ty, overrides) = CheckMethods z overrides + let CheckMethods z l = (z, l) ||> List.fold CheckMethod + + let CheckInterfaceImpl z (_ty, overrides) = CheckMethods z overrides let z = exprF z superInitCall - let z = CheckMethods z overrides - let z = (z, iimpls) ||> List.fold CheckInterfaceImpl + let z = CheckMethods z overrides + let z = (z, iimpls) ||> List.fold CheckInterfaceImpl z - | Expr.Op (c, tyargs, args, _m) -> - DecideExprOp exprF noInterceptF z expr (c, tyargs, args) + | Expr.Op(c, tyargs, args, _m) -> DecideExprOp exprF noInterceptF z expr (c, tyargs, args) - | _ -> - noInterceptF z expr + | _ -> noInterceptF z expr /// Find all the mutable locals that escape a binding -let DecideBinding cenv z (TBind(v, expr, _m) as bind) = - let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData - DecideLambda None cenv valReprInfo expr v.Type z +let DecideBinding cenv z (TBind(v, expr, _m) as bind) = + let valReprInfo = + match bind.Var.ValReprInfo with + | Some info -> info + | _ -> ValReprInfo.emptyValData + + DecideLambda None cenv valReprInfo expr v.Type z /// Find all the mutable locals that escape a set of bindings -let DecideBindings cenv z binds = (z, binds) ||> List.fold (DecideBinding cenv) +let DecideBindings cenv z binds = + (z, binds) ||> List.fold (DecideBinding cenv) /// Find all the mutable locals to promote to reference cells in an implementation file let DecideImplFile g amap implFile = - + let cenv = { g = g; amap = amap } - let folder = - {ExprFolder0 with - nonRecBindingsIntercept = DecideBinding cenv - recBindingsIntercept = DecideBindings cenv - exprIntercept = DecideExpr cenv - } + let folder = + { ExprFolder0 with + nonRecBindingsIntercept = DecideBinding cenv + recBindingsIntercept = DecideBindings cenv + exprIntercept = DecideExpr cenv + } let z = FoldImplFile folder emptyFreeLocals implFile @@ -137,65 +161,70 @@ let DecideImplFile g amap implFile = // Apply the transform /// Rewrite fetches, stores and address-of expressions for mutable locals which we are transforming -let TransformExpr g (heapValMap: ValMap<_>) exprF expr = +let TransformExpr g (heapValMap: ValMap<_>) exprF expr = match expr with - // Rewrite uses of mutable values - | Expr.Val (ValDeref(v), _, m) when heapValMap.ContainsVal v -> + // Rewrite uses of mutable values + | Expr.Val(ValDeref(v), _, m) when heapValMap.ContainsVal v -> - let _nv, nve = heapValMap[v] - Some (mkRefCellGet g m v.Type nve) + let _nv, nve = heapValMap[v] + Some(mkRefCellGet g m v.Type nve) - // Rewrite assignments to mutable values - | Expr.Op (TOp.LValueOp (LSet, ValDeref(v)), [], [arg], m) when heapValMap.ContainsVal v -> + // Rewrite assignments to mutable values + | Expr.Op(TOp.LValueOp(LSet, ValDeref(v)), [], [ arg ], m) when heapValMap.ContainsVal v -> - let _nv, nve = heapValMap[v] - let arg = exprF arg - Some (mkRefCellSet g m v.Type nve arg) + let _nv, nve = heapValMap[v] + let arg = exprF arg + Some(mkRefCellSet g m v.Type nve arg) - // Rewrite taking the address of mutable values - | Expr.Op (TOp.LValueOp (LAddrOf readonly, ValDeref(v)), [], [], m) when heapValMap.ContainsVal v -> - let _nv,nve = heapValMap[v] - Some (mkRecdFieldGetAddrViaExprAddr (readonly, nve, mkRefCellContentsRef g, [v.Type], m)) + // Rewrite taking the address of mutable values + | Expr.Op(TOp.LValueOp(LAddrOf readonly, ValDeref(v)), [], [], m) when heapValMap.ContainsVal v -> + let _nv, nve = heapValMap[v] + Some(mkRecdFieldGetAddrViaExprAddr (readonly, nve, mkRefCellContentsRef g, [ v.Type ], m)) | _ -> None /// Rewrite bindings for mutable locals which we are transforming -let TransformBinding g (heapValMap: ValMap<_>) exprF (TBind(v, expr, m)) = - if heapValMap.ContainsVal v then - let nv, _nve = heapValMap[v] - let exprRange = expr.Range - let expr = exprF expr - Some(TBind(nv, mkRefCell g exprRange v.Type expr, m)) +let TransformBinding g (heapValMap: ValMap<_>) exprF (TBind(v, expr, m)) = + if heapValMap.ContainsVal v then + let nv, _nve = heapValMap[v] + let exprRange = expr.Range + let expr = exprF expr + Some(TBind(nv, mkRefCell g exprRange v.Type expr, m)) else - None + None /// Rewrite mutable locals to reference cells across an entire implementation file -let TransformImplFile g amap implFile = +let TransformImplFile g amap implFile = let localsToTransform = DecideImplFile g amap implFile - if Zset.isEmpty localsToTransform then + + if Zset.isEmpty localsToTransform then implFile else for fv in localsToTransform do - warning (Error(FSComp.SR.abImplicitHeapAllocation(fv.DisplayName), fv.Range)) - - let heapValMap = - [ for localVal in localsToTransform do - let heapTy = mkRefCellTy g localVal.Type - let heapVal, heapValExpr = - if localVal.IsCompilerGenerated then - mkCompGenLocal localVal.Range localVal.LogicalName heapTy - else - mkLocal localVal.Range localVal.LogicalName heapTy - yield (localVal, (heapVal, heapValExpr)) ] + warning (Error(FSComp.SR.abImplicitHeapAllocation (fv.DisplayName), fv.Range)) + + let heapValMap = + [ + for localVal in localsToTransform do + let heapTy = mkRefCellTy g localVal.Type + + let heapVal, heapValExpr = + if localVal.IsCompilerGenerated then + mkCompGenLocal localVal.Range localVal.LogicalName heapTy + else + mkLocal localVal.Range localVal.LogicalName heapTy + + yield (localVal, (heapVal, heapValExpr)) + ] |> ValMap.OfList - implFile |> - RewriteImplFile - { PreIntercept = Some(TransformExpr g heapValMap) + implFile + |> RewriteImplFile + { + PreIntercept = Some(TransformExpr g heapValMap) PreInterceptBinding = Some(TransformBinding g heapValMap) PostTransform = (fun _ -> None) RewriteQuotations = true - StackGuard = StackGuard(AutoboxRewriteStackGuardDepth, "AutoboxRewriteStackGuardDepth") } - - + StackGuard = StackGuard(AutoboxRewriteStackGuardDepth, "AutoboxRewriteStackGuardDepth") + } diff --git a/src/Compiler/Optimize/LowerSequences.fs b/src/Compiler/Optimize/LowerSequences.fs index df19323cb66..3be53815deb 100644 --- a/src/Compiler/Optimize/LowerSequences.fs +++ b/src/Compiler/Optimize/LowerSequences.fs @@ -20,59 +20,58 @@ open FSharp.Compiler.TypeHierarchy //---------------------------------------------------------------------------- // General helpers -let mkLambdaNoType g m uv e = - mkLambda m uv (e, tyOfExpr g e) +let mkLambdaNoType g m uv e = mkLambda m uv (e, tyOfExpr g e) let callNonOverloadedILMethod g amap m methName ty args = - match TryFindIntrinsicMethInfo (InfoReader(g, amap)) m AccessibleFromSomeFSharpCode methName ty with - | [] -> error(InternalError("No method called '"+methName+"' was found", m)) - | ILMeth(g, ilMethInfo, _) :: _ -> + match TryFindIntrinsicMethInfo (InfoReader(g, amap)) m AccessibleFromSomeFSharpCode methName ty with + | [] -> error (InternalError("No method called '" + methName + "' was found", m)) + | ILMeth(g, ilMethInfo, _) :: _ -> // REVIEW: consider if this should ever be a constrained call. At the moment typecheck limitations in the F# typechecker // ensure the enumerator type used within computation expressions is not a struct type - BuildILMethInfoCall g amap m false ilMethInfo NormalValUse [] false args |> fst - | _ -> - error(InternalError("The method called '"+methName+"' resolved to a non-IL type", m)) + BuildILMethInfoCall g amap m false ilMethInfo NormalValUse [] false args |> fst + | _ -> error (InternalError("The method called '" + methName + "' resolved to a non-IL type", m)) //---------------------------------------------------------------------------- // State machine compilation for sequence expressions type LoweredSeqFirstPhaseResult = - { - /// The second phase of the transformation. This rebuilds the 'generate', 'dispose' and 'checkDispose' expressions for the - /// state machine. It is run after all code labels and their mapping to program counters have been determined - /// after the first phase. - /// - /// The arguments to phase2 are as follows: - /// 'pc' is the state machine variable allocated to hold the "program counter" for the state machine - /// 'current' is the state machine variable allocated to hold the "current" value being yielded from the enumeration - /// 'nextVar' is the argument variable for the GenerateNext method that represents the byref argument - /// that holds the "goto" destination for a tailcalling sequence expression - /// 'pcMap' is the mapping from code labels to values for 'pc' - /// - /// The phase2 function returns the core of the generate, dispose and checkDispose implementations. - phase2 : ValRef * (* current: *) ValRef * (* nextVar: *) ValRef * Map -> Expr * Expr * Expr - - /// The labels allocated for one portion of the sequence expression - entryPoints : int list - - /// Indicates if any actual work is done in dispose, i.e. is there a 'try-finally' (or 'use') in the computation. - significantClose : bool - - /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) - stateVars: ValRef list - - /// The vars captured by the non-synchronous path - asyncVars: FreeVars - } + { + /// The second phase of the transformation. This rebuilds the 'generate', 'dispose' and 'checkDispose' expressions for the + /// state machine. It is run after all code labels and their mapping to program counters have been determined + /// after the first phase. + /// + /// The arguments to phase2 are as follows: + /// 'pc' is the state machine variable allocated to hold the "program counter" for the state machine + /// 'current' is the state machine variable allocated to hold the "current" value being yielded from the enumeration + /// 'nextVar' is the argument variable for the GenerateNext method that represents the byref argument + /// that holds the "goto" destination for a tailcalling sequence expression + /// 'pcMap' is the mapping from code labels to values for 'pc' + /// + /// The phase2 function returns the core of the generate, dispose and checkDispose implementations. + phase2: ValRef * (* current: *) ValRef * (* nextVar: *) ValRef * Map -> Expr * Expr * Expr + + /// The labels allocated for one portion of the sequence expression + entryPoints: int list + + /// Indicates if any actual work is done in dispose, i.e. is there a 'try-finally' (or 'use') in the computation. + significantClose: bool + + /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) + stateVars: ValRef list + + /// The vars captured by the non-synchronous path + asyncVars: FreeVars + } let IsPossibleSequenceExpr g overallExpr = - match overallExpr with Seq g _ -> true | _ -> false + match overallExpr with + | Seq g _ -> true + | _ -> false -let tyConfirmsToSeq g ty = +let tyConfirmsToSeq g ty = match tryTcrefOfAppTy g ty with - | ValueSome tcref -> - tyconRefEq g tcref g.tcref_System_Collections_Generic_IEnumerable - | _ -> false + | ValueSome tcref -> tyconRefEq g tcref g.tcref_System_Collections_Generic_IEnumerable + | _ -> false [] let (|SeqElemTy|_|) g amap m ty = @@ -98,92 +97,121 @@ let (|SeqElemTy|_|) g amap m ty = let ConvertSequenceExprToObject g amap overallExpr = /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLocal (bind: Binding) resBody m = - if verbose then + if verbose then printfn "LowerSeq: found local variable %s" bind.Var.DisplayName { resBody with - phase2 = (fun ctxt -> - let generateBody, disposeBody, checkDisposeBody = resBody.phase2 ctxt - let generate = mkLetBind m bind generateBody - let dispose = disposeBody - let checkDispose = checkDisposeBody - generate, dispose, checkDispose) - stateVars = resBody.stateVars } + phase2 = + (fun ctxt -> + let generateBody, disposeBody, checkDisposeBody = resBody.phase2 ctxt + let generate = mkLetBind m bind generateBody + let dispose = disposeBody + let checkDispose = checkDisposeBody + generate, dispose, checkDispose) + stateVars = resBody.stateVars + } /// Implement a decision to represent a 'let' binding as a state machine variable let RepresentBindingAsStateMachineLocal (bind: Binding) resBody m = - if verbose then + if verbose then printfn "LowerSeq: found state variable %s" bind.Var.DisplayName let (TBind(v, e, sp)) = bind + let addDebugPoint e = match sp with | DebugPointAtBinding.Yes m -> Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, e) | _ -> e + let vref = mkLocalValRef v + { resBody with - phase2 = (fun ctxt -> - let generateBody, disposeBody, checkDisposeBody = resBody.phase2 ctxt - let generate = - mkSequential m - (mkSequential m - (mkValSet m vref e |> addDebugPoint) - generateBody) - // zero out the current value to free up its memory - (mkValSet m vref (mkDefault (m, vref.Type))) - let dispose = disposeBody - let checkDispose = checkDisposeBody - generate, dispose, checkDispose) - stateVars = vref :: resBody.stateVars } + phase2 = + (fun ctxt -> + let generateBody, disposeBody, checkDisposeBody = resBody.phase2 ctxt + + let generate = + mkSequential + m + (mkSequential m (mkValSet m vref e |> addDebugPoint) generateBody) + // zero out the current value to free up its memory + (mkValSet m vref (mkDefault (m, vref.Type))) + + let dispose = disposeBody + let checkDispose = checkDisposeBody + generate, dispose, checkDispose) + stateVars = vref :: resBody.stateVars + } let RepresentBindingsAsLifted mkBinds resBody = - if verbose then + if verbose then printfn "found top level let " { resBody with - phase2 = (fun ctxt -> - let generateBody, disposeBody, checkDisposeBody = resBody.phase2 ctxt - let generate = mkBinds generateBody - let dispose = disposeBody - let checkDispose = checkDisposeBody - generate, dispose, checkDispose) } + phase2 = + (fun ctxt -> + let generateBody, disposeBody, checkDisposeBody = resBody.phase2 ctxt + let generate = mkBinds generateBody + let dispose = disposeBody + let checkDispose = checkDisposeBody + generate, dispose, checkDispose) + } let rec ConvertSeqExprCode - isWholeExpr - isTailCall // is this sequence in tailcall position? - noDisposeContinuationLabel // represents the label for the code where there is effectively nothing to do to dispose the iterator for the current state - currentDisposeContinuationLabel // represents the label for the code we have to run to dispose the iterator given the current state - expr = + isWholeExpr + isTailCall // is this sequence in tailcall position? + noDisposeContinuationLabel // represents the label for the code where there is effectively nothing to do to dispose the iterator for the current state + currentDisposeContinuationLabel // represents the label for the code we have to run to dispose the iterator given the current state + expr + = match expr with | SeqYield g (e, m) -> // printfn "found Seq.singleton" - //this.pc <- NEXT - //curr <- e - //return true - //NEXT: - let label = generateCodeLabel() - Some { phase2 = (fun (pcVar, currVar, _nextv, pcMap) -> - let generate = - mkSequential m - (mkValSet m pcVar (mkInt32 g m pcMap[label])) - (mkCompGenSequential m - (mkValSet m currVar e) - (mkCompGenSequential m - (Expr.Op (TOp.Return, [], [mkOne g m], m)) - (Expr.Op (TOp.Label label, [], [], m)))) - let dispose = - mkLabelled m label - (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m)) - let checkDispose = - mkLabelled m label - (Expr.Op (TOp.Return, [], [mkBool g m (not (noDisposeContinuationLabel = currentDisposeContinuationLabel))], m)) - generate, dispose, checkDispose) - entryPoints=[label] - stateVars=[] - significantClose = false - asyncVars = emptyFreeVars - } + //this.pc <- NEXT + //curr <- e + //return true + //NEXT: + let label = generateCodeLabel () + + Some + { + phase2 = + (fun (pcVar, currVar, _nextv, pcMap) -> + let generate = + mkSequential + m + (mkValSet m pcVar (mkInt32 g m pcMap[label])) + (mkCompGenSequential + m + (mkValSet m currVar e) + (mkCompGenSequential + m + (Expr.Op(TOp.Return, [], [ mkOne g m ], m)) + (Expr.Op(TOp.Label label, [], [], m)))) + + let dispose = + mkLabelled m label (Expr.Op(TOp.Goto currentDisposeContinuationLabel, [], [], m)) + + let checkDispose = + mkLabelled + m + label + (Expr.Op( + TOp.Return, + [], + [ + mkBool g m (not (noDisposeContinuationLabel = currentDisposeContinuationLabel)) + ], + m + )) + + generate, dispose, checkDispose) + entryPoints = [ label ] + stateVars = [] + significantClose = false + asyncVars = emptyFreeVars + } | SeqDelay g (delayedExpr, _elemTy) -> // printfn "found Seq.delay" @@ -192,8 +220,12 @@ let ConvertSequenceExprToObject g amap overallExpr = | SeqAppend g (e1, e2, m) -> // printfn "found Seq.append" - let res1 = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 - let res2 = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 + let res1 = + ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 + + let res2 = + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 + match res1, res2 with | Some res1, Some res2 -> @@ -204,51 +236,65 @@ let ConvertSequenceExprToObject g amap overallExpr = // All of 'e2' is needed after resuming at any of the labels unionFreeVars res1.asyncVars (freeInExpr CollectLocals e2) - Some { phase2 = (fun ctxt -> - let generate1, dispose1, checkDispose1 = res1.phase2 ctxt - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = mkSequential m generate1 generate2 - // Order shouldn't matter here, since disposals actions are linked together by goto's (each ends in a goto). - // However leaving as is for now. - let dispose = mkSequential m dispose2 dispose1 - let checkDispose = mkSequential m checkDispose2 checkDispose1 - generate, dispose, checkDispose) - entryPoints= res1.entryPoints @ res2.entryPoints - stateVars = res1.stateVars @ res2.stateVars - significantClose = res1.significantClose || res2.significantClose - asyncVars = asyncVars } - | _ -> - None + Some + { + phase2 = + (fun ctxt -> + let generate1, dispose1, checkDispose1 = res1.phase2 ctxt + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + let generate = mkSequential m generate1 generate2 + // Order shouldn't matter here, since disposals actions are linked together by goto's (each ends in a goto). + // However leaving as is for now. + let dispose = mkSequential m dispose2 dispose1 + let checkDispose = mkSequential m checkDispose2 checkDispose1 + generate, dispose, checkDispose) + entryPoints = res1.entryPoints @ res2.entryPoints + stateVars = res1.stateVars @ res2.stateVars + significantClose = res1.significantClose || res2.significantClose + asyncVars = asyncVars + } + | _ -> None | SeqWhile g (guardExpr, innerExpr, spWhile, m) -> - let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel innerExpr + let resBody = + ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel innerExpr + match resBody with - | Some res2 -> + | Some res2 -> let asyncVars = if res2.entryPoints.IsEmpty then - res2.asyncVars // the whole loop is synchronous, no labels + res2.asyncVars // the whole loop is synchronous, no labels else freeInExpr CollectLocals expr // everything is needed on subsequent iterations - Some { phase2 = (fun ctxt -> - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = mkWhile g (spWhile, NoSpecialWhileLoopMarker, guardExpr, generate2, m) - let dispose = dispose2 - let checkDispose = checkDispose2 - generate, dispose, checkDispose) - entryPoints = res2.entryPoints - stateVars = res2.stateVars - significantClose = res2.significantClose - asyncVars = asyncVars } - | _ -> - None + Some + { + phase2 = + (fun ctxt -> + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + + let generate = + mkWhile g (spWhile, NoSpecialWhileLoopMarker, guardExpr, generate2, m) + + let dispose = dispose2 + let checkDispose = checkDispose2 + generate, dispose, checkDispose) + entryPoints = res2.entryPoints + stateVars = res2.stateVars + significantClose = res2.significantClose + asyncVars = asyncVars + } + | _ -> None | SeqUsing g (resource, v, body, elemTy, spBind, m) -> let reduction = - mkLet spBind m v resource - (mkCallSeqFinally g m elemTy body - (mkUnitDelayLambda g m - (mkCallDispose g m v.Type (exprForVal m v)))) + mkLet + spBind + m + v + resource + (mkCallSeqFinally g m elemTy body (mkUnitDelayLambda g m (mkCallDispose g m v.Type (exprForVal m v)))) + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction | SeqForEach g (inp, v, body, genElemTy, mFor, mIn, spIn) -> @@ -262,127 +308,177 @@ let ConvertSequenceExprToObject g amap overallExpr = // body ]] // A debug point should get emitted prior to both the evaluation of 'inp' and the call to GetEnumerator - let addForDebugPoint e = Expr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, e) + let addForDebugPoint e = + Expr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, e) // The 'in' debug point is put back into the TypedTree at the right place for SeqWhile - let mIn = match spIn with DebugPointAtInOrTo.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) | DebugPointAtInOrTo.No -> mIn + let mIn = + match spIn with + | DebugPointAtInOrTo.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) + | DebugPointAtInOrTo.No -> mIn let reduction = - mkInvisibleLet mFor enumv (callNonOverloadedILMethod g amap mFor "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) + mkInvisibleLet + mFor + enumv + (callNonOverloadedILMethod g amap mFor "GetEnumerator" (mkSeqTy g inpElemTy) [ inp ]) // try..finally - will get reduced again - (mkCallSeqFinally g mFor genElemTy + (mkCallSeqFinally + g + mFor + genElemTy // while e.MoveNext do (will get reduced again) // - The lambda of the call to Seq.generated gets mIn as expected by SeqWhile - (mkCallSeqGenerated g mFor genElemTy - (mkUnitDelayLambda g mIn (callNonOverloadedILMethod g amap mIn "MoveNext" inpEnumTy [enume])) + (mkCallSeqGenerated + g + mFor + genElemTy + (mkUnitDelayLambda g mIn (callNonOverloadedILMethod g amap mIn "MoveNext" inpEnumTy [ enume ])) // let v = e.Current - (mkInvisibleLet mIn v - (callNonOverloadedILMethod g amap mIn "get_Current" inpEnumTy [enume]) - (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) - body))) + (mkInvisibleLet + mIn + v + (callNonOverloadedILMethod g amap mIn "get_Current" inpEnumTy [ enume ]) + (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) body))) (mkUnitDelayLambda g mFor (mkCallDispose g mFor enumv.Type enume))) |> addForDebugPoint ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction | SeqTryFinally g (e1, compensation, spTry, spFinally, m) -> - let innerDisposeContinuationLabel = generateCodeLabel() - let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 + let innerDisposeContinuationLabel = generateCodeLabel () + + let resBody = + ConvertSeqExprCode false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 + match resBody with - | Some res1 -> + | Some res1 -> let asyncVars = unionFreeVars res1.asyncVars (freeInExpr CollectLocals compensation) + let addTryDebugPoint e = match spTry with | DebugPointAtTry.Yes m -> Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, e) | _ -> e + let addFinallyDebugPoint e = match spFinally with | DebugPointAtFinally.Yes m -> Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, e) | _ -> e - Some { phase2 = (fun (pcVar, _currv, _, pcMap as ctxt) -> - let generate1, dispose1, checkDispose1 = res1.phase2 ctxt - let generate = - // copy the compensation expression - one copy for the success continuation and one for the exception - let compensation = copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated compensation - mkSequential m - // set the PC to the inner finally, so that if an exception happens we run the right finally - (mkSequential m - (mkValSet m pcVar (mkInt32 g m pcMap[innerDisposeContinuationLabel]) |> addTryDebugPoint) - generate1 ) - // set the PC past the try/finally before trying to run it, to make sure we only run it once - (mkLabelled m innerDisposeContinuationLabel - (mkCompGenSequential m - (mkValSet m pcVar (mkInt32 g m pcMap[currentDisposeContinuationLabel])) - compensation)) - let dispose = - // generate inner try/finallys, then outer try/finallys - mkSequential m - dispose1 - // set the PC past the try/finally before trying to run it, to make sure we only run it once - (mkLabelled m innerDisposeContinuationLabel - (mkSequential m - (mkValSet m pcVar (mkInt32 g m pcMap[currentDisposeContinuationLabel]) |> addFinallyDebugPoint) - (mkSequential m - compensation - (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m))))) - let checkDispose = - mkSequential m - checkDispose1 - (mkLabelled m innerDisposeContinuationLabel - (Expr.Op (TOp.Return, [], [mkTrue g m (* yes, we must dispose!!! *) ], m))) - generate, dispose, checkDispose) - entryPoints = innerDisposeContinuationLabel :: res1.entryPoints - stateVars = res1.stateVars - significantClose = true - asyncVars = asyncVars } - | _ -> - None + Some + { + phase2 = + (fun (pcVar, _currv, _, pcMap as ctxt) -> + let generate1, dispose1, checkDispose1 = res1.phase2 ctxt + + let generate = + // copy the compensation expression - one copy for the success continuation and one for the exception + let compensation = + copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated compensation + + mkSequential + m + // set the PC to the inner finally, so that if an exception happens we run the right finally + (mkSequential + m + (mkValSet m pcVar (mkInt32 g m pcMap[innerDisposeContinuationLabel]) + |> addTryDebugPoint) + generate1) + // set the PC past the try/finally before trying to run it, to make sure we only run it once + (mkLabelled + m + innerDisposeContinuationLabel + (mkCompGenSequential + m + (mkValSet m pcVar (mkInt32 g m pcMap[currentDisposeContinuationLabel])) + compensation)) + + let dispose = + // generate inner try/finallys, then outer try/finallys + mkSequential + m + dispose1 + // set the PC past the try/finally before trying to run it, to make sure we only run it once + (mkLabelled + m + innerDisposeContinuationLabel + (mkSequential + m + (mkValSet m pcVar (mkInt32 g m pcMap[currentDisposeContinuationLabel]) + |> addFinallyDebugPoint) + (mkSequential m compensation (Expr.Op(TOp.Goto currentDisposeContinuationLabel, [], [], m))))) + + let checkDispose = + mkSequential + m + checkDispose1 + (mkLabelled + m + innerDisposeContinuationLabel + (Expr.Op(TOp.Return, [], [ mkTrue g m (* yes, we must dispose!!! *) ], m))) + + generate, dispose, checkDispose) + entryPoints = innerDisposeContinuationLabel :: res1.entryPoints + stateVars = res1.stateVars + significantClose = true + asyncVars = asyncVars + } + | _ -> None | SeqEmpty g m -> // printfn "found Seq.empty" - Some { phase2 = (fun _ -> - let generate = mkUnit g m - let dispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) - let checkDispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) + Some + { + phase2 = + (fun _ -> + let generate = mkUnit g m + let dispose = Expr.Op(TOp.Goto currentDisposeContinuationLabel, [], [], m) + let checkDispose = Expr.Op(TOp.Goto currentDisposeContinuationLabel, [], [], m) generate, dispose, checkDispose) - entryPoints = [] - stateVars = [] - significantClose = false - asyncVars = emptyFreeVars } + entryPoints = [] + stateVars = [] + significantClose = false + asyncVars = emptyFreeVars + } - | Expr.Sequential (expr1, expr2, NormalSeq, m) -> + | Expr.Sequential(expr1, expr2, NormalSeq, m) -> match ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel expr2 with - | Some res2-> + | Some res2 -> // printfn "found sequential execution" - Some { res2 with - phase2 = (fun ctxt -> - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = Expr.Sequential (expr1, generate2, NormalSeq, m) - let dispose = dispose2 - let checkDispose = checkDispose2 - generate, dispose, checkDispose) } + Some + { res2 with + phase2 = + (fun ctxt -> + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + let generate = Expr.Sequential(expr1, generate2, NormalSeq, m) + let dispose = dispose2 + let checkDispose = checkDispose2 + generate, dispose, checkDispose) + } | None -> None - | Expr.Let (bind, bodyExpr, m, _) - // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported - when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericConstraints g bind.Var) -> + | Expr.Let(bind, bodyExpr, m, _) when + // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported + bind.Var.IsCompiledAsTopLevel + || not (IsGenericValWithGenericConstraints g bind.Var) + -> + + let resBodyOpt = + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr - let resBodyOpt = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr match resBodyOpt with | Some resBody -> if bind.Var.IsCompiledAsTopLevel then - Some (RepresentBindingsAsLifted (mkLetBind m bind) resBody) + Some(RepresentBindingsAsLifted (mkLetBind m bind) resBody) elif not (resBody.asyncVars.FreeLocals.Contains(bind.Var)) then // printfn "found state variable %s" bind.Var.DisplayName - Some (RepresentBindingAsLocal bind resBody m) + Some(RepresentBindingAsLocal bind resBody m) else // printfn "found state variable %s" bind.Var.DisplayName - Some (RepresentBindingAsStateMachineLocal bind resBody m) - | None -> - None + Some(RepresentBindingAsStateMachineLocal bind resBody m) + | None -> None -(* + (* | Expr.LetRec (binds, e2, m, _) when // Restriction: only limited forms of "let rec" in sequence expressions can be handled by assignment to state local values @@ -416,11 +512,12 @@ let ConvertSequenceExprToObject g amap overallExpr = // transferred to the r.h.s. are not yet compiled. // // TODO: remove this limitation - | Expr.Match (spBind, mExpr, pt, targets, m, ty) -> + | Expr.Match(spBind, mExpr, pt, targets, m, ty) -> // lower all the targets. abandon if any fail to lower let tglArray = targets - |> Array.map (fun (TTarget(_vs, targetExpr, _)) -> ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) + |> Array.map (fun (TTarget(_vs, targetExpr, _)) -> + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) if tglArray |> Array.forall Option.isSome then let tglArray = Array.map Option.get tglArray @@ -430,46 +527,77 @@ let ConvertSequenceExprToObject g amap overallExpr = let asyncVars = (emptyFreeVars, Array.zip targets tglArray) ||> Array.fold (fun fvs (TTarget(_vs, _, _), res) -> - if res.entryPoints.IsEmpty then fvs else unionFreeVars fvs res.asyncVars) + if res.entryPoints.IsEmpty then + fvs + else + unionFreeVars fvs res.asyncVars) + + let stateVars = + (targets, tglArray) + ||> Array.zip + |> Array.toList + |> List.collect (fun (TTarget(vs, _, _), res) -> + let stateVars = + vs + |> List.filter (fun v -> res.asyncVars.FreeLocals.Contains(v)) + |> List.map mkLocalValRef - let stateVars = - (targets, tglArray) ||> Array.zip |> Array.toList |> List.collect (fun (TTarget(vs, _, _), res) -> - let stateVars = vs |> List.filter (fun v -> res.asyncVars.FreeLocals.Contains(v)) |> List.map mkLocalValRef stateVars @ res.stateVars) let significantClose = tgl |> List.exists (fun res -> res.significantClose) - Some { phase2 = (fun ctxt -> - let gtgs, disposals, checkDisposes = - (Array.toList targets, tgl) - ||> List.map2 (fun (TTarget(vs, _, _)) res -> - let flags = vs |> List.map (fun v -> res.asyncVars.FreeLocals.Contains(v)) + Some + { + phase2 = + (fun ctxt -> + let gtgs, disposals, checkDisposes = + (Array.toList targets, tgl) + ||> List.map2 (fun (TTarget(vs, _, _)) res -> + let flags = vs |> List.map (fun v -> res.asyncVars.FreeLocals.Contains(v)) let generate, dispose, checkDispose = res.phase2 ctxt let gtg = TTarget(vs, generate, Some flags) gtg, dispose, checkDispose) - |> List.unzip3 - let generate = primMkMatch (spBind, mExpr, pt, Array.ofList gtgs, m, ty) - let dispose = if isNil disposals then mkUnit g m else List.reduce (mkSequential m) disposals - let checkDispose = if isNil checkDisposes then mkFalse g m else List.reduce (mkSequential m) checkDisposes - generate, dispose, checkDispose) - entryPoints=labs - stateVars = stateVars - significantClose = significantClose - asyncVars = asyncVars } + |> List.unzip3 + + let generate = primMkMatch (spBind, mExpr, pt, Array.ofList gtgs, m, ty) + + let dispose = + if isNil disposals then + mkUnit g m + else + List.reduce (mkSequential m) disposals + + let checkDispose = + if isNil checkDisposes then + mkFalse g m + else + List.reduce (mkSequential m) checkDisposes + + generate, dispose, checkDispose) + entryPoints = labs + stateVars = stateVars + significantClose = significantClose + asyncVars = asyncVars + } else None | Expr.DebugPoint(dp, innerExpr) -> - let resInnerExpr = ConvertSeqExprCode isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel innerExpr - match resInnerExpr with + let resInnerExpr = + ConvertSeqExprCode isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel innerExpr + + match resInnerExpr with | Some res2 -> - Some { res2 with - phase2 = (fun ctxt -> - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = Expr.DebugPoint (dp, generate2) - let dispose = dispose2 - let checkDispose = checkDispose2 - generate, dispose, checkDispose) } + Some + { res2 with + phase2 = + (fun ctxt -> + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + let generate = Expr.DebugPoint(dp, generate2) + let dispose = dispose2 + let checkDispose = checkDispose2 + generate, dispose, checkDispose) + } | None -> None // yield! e ---> (for x in e -> x) @@ -489,6 +617,7 @@ let ConvertSequenceExprToObject g amap overallExpr = | arbitrarySeqExpr -> let m = arbitrarySeqExpr.Range + if isWholeExpr then // printfn "FAILED - not worth compiling an unrecognized immediate yield! %s " (stringOfRange m) None @@ -497,43 +626,61 @@ let ConvertSequenceExprToObject g amap overallExpr = | SeqElemTy g amap m inpElemTy -> // printfn "found yield!" if isTailCall then - //this.pc <- NEXT - //nextEnumerator <- e - //return 2 - //NEXT: - let label = generateCodeLabel() - Some { phase2 = (fun (pcVar, _currv, nextVar, pcMap) -> - let generate = - mkSequential m - (mkValSet m pcVar (mkInt32 g m pcMap[label])) - (mkCompGenSequential m - (mkAddrSet m nextVar arbitrarySeqExpr) - (mkCompGenSequential m - (Expr.Op (TOp.Return, [], [mkTwo g m], m)) - (Expr.Op (TOp.Label label, [], [], m)))) - let dispose = - mkLabelled m label - (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m)) - let checkDispose = - mkLabelled m label - (Expr.Op (TOp.Return, [], [mkFalse g m], m)) - generate, dispose, checkDispose) - entryPoints=[label] - stateVars=[] - significantClose = false - asyncVars = emptyFreeVars } + //this.pc <- NEXT + //nextEnumerator <- e + //return 2 + //NEXT: + let label = generateCodeLabel () + + Some + { + phase2 = + (fun (pcVar, _currv, nextVar, pcMap) -> + let generate = + mkSequential + m + (mkValSet m pcVar (mkInt32 g m pcMap[label])) + (mkCompGenSequential + m + (mkAddrSet m nextVar arbitrarySeqExpr) + (mkCompGenSequential + m + (Expr.Op(TOp.Return, [], [ mkTwo g m ], m)) + (Expr.Op(TOp.Label label, [], [], m)))) + + let dispose = + mkLabelled m label (Expr.Op(TOp.Goto currentDisposeContinuationLabel, [], [], m)) + + let checkDispose = mkLabelled m label (Expr.Op(TOp.Return, [], [ mkFalse g m ], m)) + generate, dispose, checkDispose) + entryPoints = [ label ] + stateVars = [] + significantClose = false + asyncVars = emptyFreeVars + } else let v, ve = mkCompGenLocal m "v" inpElemTy - ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) - | _ -> None + ConvertSeqExprCode + false + isTailCall + noDisposeContinuationLabel + currentDisposeContinuationLabel + (mkCallSeqCollect + g + m + inpElemTy + inpElemTy + (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) + arbitrarySeqExpr) + | _ -> None match overallExpr with | Seq g (e, ty) -> // printfn "found seq { ... } or Seq.delay (fun () -> ...) in FSharp.Core.dll" let m = e.Range - let initLabel = generateCodeLabel() - let noDisposeContinuationLabel = generateCodeLabel() + let initLabel = generateCodeLabel () + let noDisposeContinuationLabel = generateCodeLabel () // Perform phase1 match ConvertSeqExprCode true true noDisposeContinuationLabel noDisposeContinuationLabel e with @@ -552,69 +699,80 @@ let ConvertSequenceExprToObject g amap overallExpr = let pcs = labs |> List.mapi (fun i _ -> i + 1) let pcDone = labs.Length + 1 let pcInit = 0 - let pc2lab = Map.ofList ((pcInit, initLabel) :: (pcDone, noDisposeContinuationLabel) :: List.zip pcs labs) - let lab2pc = Map.ofList ((initLabel, pcInit) :: (noDisposeContinuationLabel, pcDone) :: List.zip labs pcs) + + let pc2lab = + Map.ofList ((pcInit, initLabel) :: (pcDone, noDisposeContinuationLabel) :: List.zip pcs labs) + + let lab2pc = + Map.ofList ((initLabel, pcInit) :: (noDisposeContinuationLabel, pcDone) :: List.zip labs pcs) // Execute phase2, building the core of the GenerateNext, Dispose and CheckDispose methods let generateExprCore, disposalExprCore, checkDisposeExprCore = res.phase2 (pcVarRef, currVarRef, nextVarRef, lab2pc) - - // Add on the final label and cleanup to the GenerateNext method + + // Add on the final label and cleanup to the GenerateNext method // generateExpr; // pc <- PC_DONE - // noDispose: + // noDispose: // current <- null // return 0 let generateExprWithCleanup = - mkCompGenSequential m + mkCompGenSequential + m generateExprCore - (mkCompGenSequential m + (mkCompGenSequential + m // set the pc to "finished" (mkValSet m pcVarRef (mkInt32 g m pcDone)) - (mkLabelled m noDisposeContinuationLabel - (mkCompGenSequential m + (mkLabelled + m + noDisposeContinuationLabel + (mkCompGenSequential + m // zero out the current value to free up its memory (mkValSet m currVarRef (mkDefault (m, currVarRef.Type))) - (Expr.Op (TOp.Return, [], [mkZero g m], m))))) + (Expr.Op(TOp.Return, [], [ mkZero g m ], m))))) // Add on the final label to the 'CheckDispose' method // checkDisposeExprCore - // noDispose: + // noDispose: // return false let checkDisposeExprWithCleanup = - mkSequential m - checkDisposeExprCore - (mkLabelled m noDisposeContinuationLabel - (Expr.Op (TOp.Return, [], [mkFalse g m], m))) + mkSequential m checkDisposeExprCore (mkLabelled m noDisposeContinuationLabel (Expr.Op(TOp.Return, [], [ mkFalse g m ], m))) // A utility to add a jump table to the three generated methods let addJumpTable isDisposal expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let mkGotoLabelTarget lab = mbuilder.AddResultTarget(Expr.Op (TOp.Goto lab, [], [], m)) + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let mkGotoLabelTarget lab = + mbuilder.AddResultTarget(Expr.Op(TOp.Goto lab, [], [], m)) + let dtree = - TDSwitch( - pcExpr, - [ - // Add an empty disposal action for the initial state (pc = 0) - if isDisposal then - yield mkCase(DecisionTreeTest.Const(Const.Int32 pcInit), mkGotoLabelTarget noDisposeContinuationLabel) - - // Yield one target for each PC, where the action of the target is to goto the appropriate label - for pc in pcs do - yield mkCase(DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab[pc]) - - // Yield one target for the 'done' program counter, where the action of the target is to continuation label - yield mkCase(DecisionTreeTest.Const(Const.Int32 pcDone), mkGotoLabelTarget noDisposeContinuationLabel) ], - Some(mkGotoLabelTarget pc2lab[pcInit]), - m) + TDSwitch( + pcExpr, + [ + // Add an empty disposal action for the initial state (pc = 0) + if isDisposal then + yield mkCase (DecisionTreeTest.Const(Const.Int32 pcInit), mkGotoLabelTarget noDisposeContinuationLabel) + + // Yield one target for each PC, where the action of the target is to goto the appropriate label + for pc in pcs do + yield mkCase (DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab[pc]) + + // Yield one target for the 'done' program counter, where the action of the target is to continuation label + yield mkCase (DecisionTreeTest.Const(Const.Int32 pcDone), mkGotoLabelTarget noDisposeContinuationLabel) + ], + Some(mkGotoLabelTarget pc2lab[pcInit]), + m + ) let table = mbuilder.Close(dtree, m, g.int_ty) mkCompGenSequential m table (mkLabelled m initLabel expr) - // A utility to handle the cases where exceptions are raised by the disposal logic. + // A utility to handle the cases where exceptions are raised by the disposal logic. // We wrap the disposal state machine in a loop that repeatedly drives the disposal logic of the // state machine through each disposal state, then re-raise the last exception raised. - // + // // let mutable exn : exn = null // while(this.pc <> END_STATE) do // try @@ -624,25 +782,31 @@ let ConvertSequenceExprToObject g amap overallExpr = let handleExceptionsInDispose disposalExpr = let exnV, exnE = mkMutableCompGenLocal m "exn" g.exn_ty let exnVref = mkLocalValRef exnV - let startLabel = generateCodeLabel() + let startLabel = generateCodeLabel () let doneDisposeLabel = generateCodeLabel () // try ``disposalExpr'' with e -> exn <- e let eV, eE = mkLocal m "e" g.exn_ty let efV, _ = mkLocal m "ef" g.exn_ty // exn <- e - let assignToExn = Expr.Op (TOp.LValueOp (LValueOperation.LSet, exnVref), [], [eE], m) + let assignToExn = + Expr.Op(TOp.LValueOp(LValueOperation.LSet, exnVref), [], [ eE ], m) // try // ``disposalExpr`` // with e -> exn <- e let exceptionCatcher = - mkTryWith g + mkTryWith + g (disposalExpr, - efV, Expr.Const ((Const.Bool true), m, g.bool_ty), - eV, assignToExn, - m, g.unit_ty, - DebugPointAtTry.No, DebugPointAtWith.No) + efV, + Expr.Const((Const.Bool true), m, g.bool_ty), + eV, + assignToExn, + m, + g.unit_ty, + DebugPointAtTry.No, + DebugPointAtWith.No) // Make the loop // @@ -659,66 +823,85 @@ let ConvertSequenceExprToObject g amap overallExpr = let whileLoop = let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) let addResultTarget e = mbuilder.AddResultTarget(e) + let dtree = TDSwitch( pcExpr, - [ mkCase((DecisionTreeTest.Const(Const.Int32 pcDone)), addResultTarget (Expr.Op (TOp.Goto doneDisposeLabel, [], [], m)) ) ], - Some (addResultTarget (mkUnit g m)), - m) + [ + mkCase ( + (DecisionTreeTest.Const(Const.Int32 pcDone)), + addResultTarget (Expr.Op(TOp.Goto doneDisposeLabel, [], [], m)) + ) + ], + Some(addResultTarget (mkUnit g m)), + m + ) + let pcIsEndStateComparison = mbuilder.Close(dtree, m, g.unit_ty) - mkLabelled m startLabel - (mkCompGenSequential m + + mkLabelled + m + startLabel + (mkCompGenSequential + m pcIsEndStateComparison - (mkCompGenSequential m + (mkCompGenSequential + m exceptionCatcher - (mkCompGenSequential m - (Expr.Op ((TOp.Goto startLabel), [], [], m)) - (Expr.Op ((TOp.Label doneDisposeLabel), [], [], m)) - ) - ) - ) + (mkCompGenSequential + m + (Expr.Op((TOp.Goto startLabel), [], [], m)) + (Expr.Op((TOp.Label doneDisposeLabel), [], [], m))))) // if exn != null then raise exn let doRaise = - mkNonNullCond g m g.unit_ty exnE (mkThrow m g.unit_ty exnE) (Expr.Const (Const.Unit, m, g.unit_ty)) + mkNonNullCond g m g.unit_ty exnE (mkThrow m g.unit_ty exnE) (Expr.Const(Const.Unit, m, g.unit_ty)) // let mutable exn = null // --loop-- // if exn != null then raise exn - mkLet - DebugPointAtBinding.NoneAtLet m exnV (Expr.Const (Const.Zero, m, g.exn_ty)) - (mkCompGenSequential m whileLoop doRaise) + mkLet DebugPointAtBinding.NoneAtLet m exnV (Expr.Const(Const.Zero, m, g.exn_ty)) (mkCompGenSequential m whileLoop doRaise) // Add the jump table to the GenerateNext method - let generateExprWithJumpTable = - addJumpTable false generateExprWithCleanup + let generateExprWithJumpTable = addJumpTable false generateExprWithCleanup // Add the jump table to the Dispose method let disposalExprWithJumpTable = if res.significantClose then let disposalExpr = - mkCompGenSequential m + mkCompGenSequential + m disposalExprCore - (mkLabelled m noDisposeContinuationLabel - (mkCompGenSequential m + (mkLabelled + m + noDisposeContinuationLabel + (mkCompGenSequential + m // set the pc to "finished" (mkValSet m pcVarRef (mkInt32 g m pcDone)) // zero out the current value to free up its memory (mkValSet m currVarRef (mkDefault (m, currVarRef.Type))))) - disposalExpr - |> addJumpTable true - |> handleExceptionsInDispose + + disposalExpr |> addJumpTable true |> handleExceptionsInDispose else mkValSet m pcVarRef (mkInt32 g m pcDone) // Add the jump table to the CheckDispose method - let checkDisposeExprWithJumpTable = - addJumpTable true checkDisposeExprWithCleanup + let checkDisposeExprWithJumpTable = addJumpTable true checkDisposeExprWithCleanup // all done, now return the results - Some (nextVarRef, pcVarRef, currVarRef, stateVars, generateExprWithJumpTable, disposalExprWithJumpTable, checkDisposeExprWithJumpTable, ty, m) + Some( + nextVarRef, + pcVarRef, + currVarRef, + stateVars, + generateExprWithJumpTable, + disposalExprWithJumpTable, + checkDisposeExprWithJumpTable, + ty, + m + ) | None -> // printfn "FAILED: no compilation found! %s" (stringOfRange m) None | _ -> None - diff --git a/src/Compiler/Optimize/LowerStateMachines.fs b/src/Compiler/Optimize/LowerStateMachines.fs index 7a6dd553f65..52c00fc9ae3 100644 --- a/src/Compiler/Optimize/LowerStateMachines.fs +++ b/src/Compiler/Optimize/LowerStateMachines.fs @@ -14,32 +14,37 @@ open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps -let LowerStateMachineStackGuardDepth = StackGuard.GetDepthOption "LowerStateMachines" +let LowerStateMachineStackGuardDepth = + StackGuard.GetDepthOption "LowerStateMachines" type StateMachineConversionFirstPhaseResult = - { - /// Represents the expanded expression prior to decisions about labels - phase1: Expr + { + /// Represents the expanded expression prior to decisions about labels + phase1: Expr - /// The second phase of the transformation. It is run after all code labels and their mapping to program counters have been determined - /// after the first phase. - phase2: Map -> Expr + /// The second phase of the transformation. It is run after all code labels and their mapping to program counters have been determined + /// after the first phase. + phase2: Map -> Expr - /// The labels allocated for this portion of the computation - entryPoints: int list + /// The labels allocated for this portion of the computation + entryPoints: int list - /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) - stateVars: ValRef list + /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) + stateVars: ValRef list - /// All this values get represented via the 'this' pointer - thisVars: ValRef list + /// All this values get represented via the 'this' pointer + thisVars: ValRef list - /// The vars captured by the non-synchronous resumable path - resumableVars: FreeVars - } + /// The vars captured by the non-synchronous resumable path + resumableVars: FreeVars + } #if DEBUG -let sm_verbose = try not (isNull(System.Environment.GetEnvironmentVariable "FSharp_StateMachineVerbose")) with _ -> false +let sm_verbose = + try + not (isNull (System.Environment.GetEnvironmentVariable "FSharp_StateMachineVerbose")) + with _ -> + false #else let sm_verbose = false #endif @@ -52,111 +57,124 @@ let rec (|OptionalResumeAtExpr|) g expr = /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsTopLevelOrLocal (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = - if sm_verbose then + if sm_verbose then printfn "LowerStateMachine: found local variable %s" bind.Var.DisplayName { res2 with - phase1 = mkLetBind m bind res2.phase1 - phase2 = (fun ctxt -> mkLetBind m bind (res2.phase2 ctxt)) } + phase1 = mkLetBind m bind res2.phase1 + phase2 = (fun ctxt -> mkLetBind m bind (res2.phase2 ctxt)) + } /// Implement a decision to represent a 'let' binding as the 'this' pointer of the state machine, /// because it is rebinding the 'this' variable let RepresentBindingAsThis (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) _m = - if sm_verbose then + if sm_verbose then printfn "LowerStateMachine: found local variable %s" bind.Var.DisplayName { res2 with thisVars = mkLocalValRef bind.Var :: res2.thisVars // Drop the let binding on the floor as it is only rebinding the 'this' variable - phase1 = res2.phase1 - phase2 = res2.phase2 } + phase1 = res2.phase1 + phase2 = res2.phase2 + } /// Implement a decision to represent a 'let' binding as a state machine variable let RepresentBindingAsStateVar g (bind: Binding) (resBody: StateMachineConversionFirstPhaseResult) m = - if sm_verbose then + if sm_verbose then printfn "LowerStateMachine: found state variable %s" bind.Var.DisplayName - + let (TBind(v, e, sp)) = bind + let addDebugPoint innerExpr = match sp with | DebugPointAtBinding.Yes m -> Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, innerExpr) | _ -> innerExpr + let vref = mkLocalValRef v + { resBody with phase1 = mkSequential m (mkValSet m vref e |> addDebugPoint) resBody.phase1 - phase2 = (fun ctxt -> - let generateBody = resBody.phase2 ctxt - let generate = - mkSequential m - (mkValSet m vref e |> addDebugPoint) - // Within all resumable code, a return value of 'true' indicates success/completion path, when we can clear - // state machine locals. - (if typeEquiv g (tyOfExpr g generateBody) g.bool_ty then - mkCond DebugPointAtBinding.NoneAtInvisible m g.bool_ty generateBody - (mkCompGenSequential m - (mkValSet m vref (mkDefault (m, vref.Type))) - (mkTrue g m)) - (mkFalse g m) - else - generateBody) - generate ) - stateVars = vref :: resBody.stateVars } - -let isExpandVar g (v: Val) = - isReturnsResumableCodeTy g v.TauType && - not v.IsCompiledAsTopLevel - -// We allow a prefix of bindings prior to the state machine, e.g. + phase2 = + (fun ctxt -> + let generateBody = resBody.phase2 ctxt + + let generate = + mkSequential + m + (mkValSet m vref e |> addDebugPoint) + // Within all resumable code, a return value of 'true' indicates success/completion path, when we can clear + // state machine locals. + (if typeEquiv g (tyOfExpr g generateBody) g.bool_ty then + mkCond + DebugPointAtBinding.NoneAtInvisible + m + g.bool_ty + generateBody + (mkCompGenSequential m (mkValSet m vref (mkDefault (m, vref.Type))) (mkTrue g m)) + (mkFalse g m) + else + generateBody) + + generate) + stateVars = vref :: resBody.stateVars + } + +let isExpandVar g (v: Val) = + isReturnsResumableCodeTy g v.TauType && not v.IsCompiledAsTopLevel + +// We allow a prefix of bindings prior to the state machine, e.g. // task { .. } // becomes // let builder@ = task // .... -let isStateMachineBindingVar g (v: Val) = - isExpandVar g v || - (let nm = v.LogicalName - (nm.StartsWithOrdinal("builder@") || v.IsMemberThisVal) && - not v.IsCompiledAsTopLevel) - -type env = - { - ResumableCodeDefns: ValMap - TemplateStructTy: TType option +let isStateMachineBindingVar g (v: Val) = + isExpandVar g v + || (let nm = v.LogicalName + + (nm.StartsWithOrdinal("builder@") || v.IsMemberThisVal) + && not v.IsCompiledAsTopLevel) + +type env = + { + ResumableCodeDefns: ValMap + TemplateStructTy: TType option } - static member Empty = - { ResumableCodeDefns = ValMap.Empty - TemplateStructTy = None + static member Empty = + { + ResumableCodeDefns = ValMap.Empty + TemplateStructTy = None } -/// Detect prefix of expanded, optimized state machine expressions -/// This is run on every expression during codegen -let rec IsStateMachineExpr g overallExpr = +/// Detect prefix of expanded, optimized state machine expressions +/// This is run on every expression during codegen +let rec IsStateMachineExpr g overallExpr = match overallExpr with // 'let' binding of initial code - | Expr.Let (defn, bodyExpr, m, _) when isStateMachineBindingVar g defn.Var -> + | Expr.Let(defn, bodyExpr, m, _) when isStateMachineBindingVar g defn.Var -> match IsStateMachineExpr g bodyExpr with | None -> None | Some altExpr as r -> - match altExpr with + match altExpr with | None -> r - | Some e -> Some (Some (mkLetBind m defn e)) + | Some e -> Some(Some(mkLetBind m defn e)) // Recognise 'if __useResumableCode ...' - | IfUseResumableStateMachinesExpr g (thenExpr, elseExpr) -> + | IfUseResumableStateMachinesExpr g (thenExpr, elseExpr) -> match IsStateMachineExpr g thenExpr with | None -> None - | Some _ -> Some (Some elseExpr) + | Some _ -> Some(Some elseExpr) | StructStateMachineExpr g _ -> Some None | _ -> None type LoweredStateMachine = - LoweredStateMachine of - templateStructTy: TType * - dataTy: TType * - stateVars: ValRef list * - thisVars: ValRef list * - moveNext: (Val * Expr) * - setStateMachine: (Val * Val * Expr) * - afterCode: (Val * Expr) + | LoweredStateMachine of + templateStructTy: TType * + dataTy: TType * + stateVars: ValRef list * + thisVars: ValRef list * + moveNext: (Val * Expr) * + setStateMachine: (Val * Val * Expr) * + afterCode: (Val * Expr) type LoweredStateMachineResult = /// A state machine was recognised and was compilable @@ -175,421 +193,555 @@ type LoweredStateMachineResult = type LowerStateMachine(g: TcGlobals) = let mutable pcCount = 0 - let genPC() = + + let genPC () = pcCount <- pcCount + 1 pcCount // Record definitions for any resumable code - let rec BindResumableCodeDefinitions (env: env) expr = + let rec BindResumableCodeDefinitions (env: env) expr = match expr with // Bind 'let __expand_ABC = bindExpr in bodyExpr' - | Expr.Let (defn, bodyExpr, _, _) when isStateMachineBindingVar g defn.Var -> - if sm_verbose then printfn "binding %A --> %A..." defn.Var defn.Expr - let envR = { env with ResumableCodeDefns = env.ResumableCodeDefns.Add defn.Var defn.Expr } + | Expr.Let(defn, bodyExpr, _, _) when isStateMachineBindingVar g defn.Var -> + if sm_verbose then + printfn "binding %A --> %A..." defn.Var defn.Expr + + let envR = + { env with + ResumableCodeDefns = env.ResumableCodeDefns.Add defn.Var defn.Expr + } + BindResumableCodeDefinitions envR bodyExpr - // Eliminate 'if __useResumableCode ...' - | IfUseResumableStateMachinesExpr g (thenExpr, _) -> - if sm_verbose then printfn "eliminating 'if __useResumableCode...'" + // Eliminate 'if __useResumableCode ...' + | IfUseResumableStateMachinesExpr g (thenExpr, _) -> + if sm_verbose then + printfn "eliminating 'if __useResumableCode...'" + BindResumableCodeDefinitions env thenExpr - | _ -> - (env, expr) - - let rec TryReduceApp (env: env) expr (args: Expr list) = - if isNil args then None else - match expr with - | Expr.TyLambda _ - | Expr.Lambda _ -> - let macroTypars, macroParamsCurried, macroBody, _rty = stripTopLambda (expr, tyOfExpr g expr) - let m = macroBody.Range - if not (isNil macroTypars) then - //warning(Error(FSComp.SR.stateMachineMacroTypars(), m)) - None - else - let macroParams = List.concat macroParamsCurried - let macroVal2 = mkLambdas g m macroTypars macroParams (macroBody, tyOfExpr g macroBody) - if args.Length < macroParams.Length then - //warning(Error(FSComp.SR.stateMachineMacroUnderapplied(), m)) + | _ -> (env, expr) + + let rec TryReduceApp (env: env) expr (args: Expr list) = + if isNil args then + None + else + match expr with + | Expr.TyLambda _ + | Expr.Lambda _ -> + let macroTypars, macroParamsCurried, macroBody, _rty = + stripTopLambda (expr, tyOfExpr g expr) + + let m = macroBody.Range + + if not (isNil macroTypars) then + //warning(Error(FSComp.SR.stateMachineMacroTypars(), m)) None else - let nowArgs, laterArgs = List.splitAt macroParams.Length args - let expandedExpr = MakeApplicationAndBetaReduce g (macroVal2, (tyOfExpr g macroVal2), [], nowArgs, m) - if sm_verbose then printfn "reduced application f = %A nowArgs= %A --> %A" macroVal2 nowArgs expandedExpr - if isNil laterArgs then - Some expandedExpr + let macroParams = List.concat macroParamsCurried + + let macroVal2 = + mkLambdas g m macroTypars macroParams (macroBody, tyOfExpr g macroBody) + + if args.Length < macroParams.Length then + //warning(Error(FSComp.SR.stateMachineMacroUnderapplied(), m)) + None else - if sm_verbose then printfn "application was partial, reducing further args %A" laterArgs - TryReduceApp env expandedExpr laterArgs + let nowArgs, laterArgs = List.splitAt macroParams.Length args - | NewDelegateExpr g (_, macroParams, macroBody, _, _) -> - let m = expr.Range - let macroVal2 = mkLambdas g m [] macroParams (macroBody, tyOfExpr g macroBody) - if args.Length < macroParams.Length then - //warning(Error(FSComp.SR.stateMachineMacroUnderapplied(), m)) - None - else - let nowArgs, laterArgs = List.splitAt macroParams.Length args - let expandedExpr = MakeApplicationAndBetaReduce g (macroVal2, (tyOfExpr g macroVal2), [], nowArgs, m) - if sm_verbose then printfn "reduced application f = %A nowArgs= %A --> %A" macroVal2 nowArgs expandedExpr - if isNil laterArgs then - Some expandedExpr + let expandedExpr = + MakeApplicationAndBetaReduce g (macroVal2, (tyOfExpr g macroVal2), [], nowArgs, m) + + if sm_verbose then + printfn "reduced application f = %A nowArgs= %A --> %A" macroVal2 nowArgs expandedExpr + + if isNil laterArgs then + Some expandedExpr + else + if sm_verbose then + printfn "application was partial, reducing further args %A" laterArgs + + TryReduceApp env expandedExpr laterArgs + + | NewDelegateExpr g (_, macroParams, macroBody, _, _) -> + let m = expr.Range + let macroVal2 = mkLambdas g m [] macroParams (macroBody, tyOfExpr g macroBody) + + if args.Length < macroParams.Length then + //warning(Error(FSComp.SR.stateMachineMacroUnderapplied(), m)) + None else - if sm_verbose then printfn "application was partial, reducing further args %A" laterArgs - TryReduceApp env expandedExpr laterArgs + let nowArgs, laterArgs = List.splitAt macroParams.Length args - | Expr.Let (bind, bodyExpr, m, _) -> - match TryReduceApp env bodyExpr args with - | Some bodyExpr2 -> Some (mkLetBind m bind bodyExpr2) - | None -> None + let expandedExpr = + MakeApplicationAndBetaReduce g (macroVal2, (tyOfExpr g macroVal2), [], nowArgs, m) - | Expr.LetRec (binds, bodyExpr, m, _) -> - match TryReduceApp env bodyExpr args with - | Some bodyExpr2 -> Some (mkLetRecBinds m binds bodyExpr2) - | None -> None + if sm_verbose then + printfn "reduced application f = %A nowArgs= %A --> %A" macroVal2 nowArgs expandedExpr - | Expr.Sequential (x1, bodyExpr, sp, m) -> - match TryReduceApp env bodyExpr args with - | Some bodyExpr2 -> Some (Expr.Sequential (x1, bodyExpr2, sp, m)) - | None -> None + if isNil laterArgs then + Some expandedExpr + else + if sm_verbose then + printfn "application was partial, reducing further args %A" laterArgs - // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match - | Expr.Const (Const.Zero, m, ty) -> - Some (Expr.Const (Const.Zero, m, ty)) - - | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> - let mutable newTyOpt = None - let targets2 = - targets |> Array.choose (fun (TTarget(vs, targetExpr, flags)) -> - // Incomplete exception matching expressions give rise to targets with I_throw. - // and System.Runtime.ExceptionServices.ExceptionDispatchInfo::Throw(...) - // - // Keep these in the residue. - // - // In theory the type of the expression should be adjusted but code generation doesn't record the - // type in the IL - let targetExpr2Opt = - match targetExpr, newTyOpt with - | Expr.Op (TOp.ILAsm ([ I_throw ], [_oldTy]), a, b, c), Some newTy -> - let targetExpr2 = Expr.Op (TOp.ILAsm ([ I_throw ], [newTy]), a, b, c) - Some targetExpr2 - | Expr.Sequential (DebugPoints((Expr.Op (TOp.ILCall ( _, _, _, _, _, _, _, ilMethodRef, _, _, _), _, _, _) as e1), rebuild1), Expr.Const (Const.Zero, m, _oldTy), a, c), Some newTy when ilMethodRef.Name = "Throw" -> - let targetExpr2 = Expr.Sequential (e1, rebuild1 (Expr.Const (Const.Zero, m, newTy)), a, c) - Some targetExpr2 - | _ -> - - match TryReduceApp env targetExpr args with - | Some targetExpr2 -> - newTyOpt <- Some (tyOfExpr g targetExpr2) - Some targetExpr2 - | None -> - None - match targetExpr2Opt with - | Some targetExpr2 -> Some (TTarget(vs, targetExpr2, flags)) - | None -> None) - if targets2.Length = targets.Length then - Some (Expr.Match (spBind, mExpr, dtree, targets2, m, ty)) - else - None + TryReduceApp env expandedExpr laterArgs - | WhileExpr (sp1, sp2, guardExpr, bodyExpr, m) -> - match TryReduceApp env bodyExpr args with - | Some bodyExpr2 -> Some (mkWhile g (sp1, sp2, guardExpr, bodyExpr2, m)) - | None -> None + | Expr.Let(bind, bodyExpr, m, _) -> + match TryReduceApp env bodyExpr args with + | Some bodyExpr2 -> Some(mkLetBind m bind bodyExpr2) + | None -> None + + | Expr.LetRec(binds, bodyExpr, m, _) -> + match TryReduceApp env bodyExpr args with + | Some bodyExpr2 -> Some(mkLetRecBinds m binds bodyExpr2) + | None -> None + + | Expr.Sequential(x1, bodyExpr, sp, m) -> + match TryReduceApp env bodyExpr args with + | Some bodyExpr2 -> Some(Expr.Sequential(x1, bodyExpr2, sp, m)) + | None -> None + + // This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match + | Expr.Const(Const.Zero, m, ty) -> Some(Expr.Const(Const.Zero, m, ty)) + + | Expr.Match(spBind, mExpr, dtree, targets, m, ty) -> + let mutable newTyOpt = None + + let targets2 = + targets + |> Array.choose (fun (TTarget(vs, targetExpr, flags)) -> + // Incomplete exception matching expressions give rise to targets with I_throw. + // and System.Runtime.ExceptionServices.ExceptionDispatchInfo::Throw(...) + // + // Keep these in the residue. + // + // In theory the type of the expression should be adjusted but code generation doesn't record the + // type in the IL + let targetExpr2Opt = + match targetExpr, newTyOpt with + | Expr.Op(TOp.ILAsm([ I_throw ], [ _oldTy ]), a, b, c), Some newTy -> + let targetExpr2 = Expr.Op(TOp.ILAsm([ I_throw ], [ newTy ]), a, b, c) + Some targetExpr2 + | Expr.Sequential(DebugPoints((Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethodRef, _, _, _), _, _, _) as e1), + rebuild1), + Expr.Const(Const.Zero, m, _oldTy), + a, + c), + Some newTy when ilMethodRef.Name = "Throw" -> + let targetExpr2 = + Expr.Sequential(e1, rebuild1 (Expr.Const(Const.Zero, m, newTy)), a, c) + + Some targetExpr2 + | _ -> + + match TryReduceApp env targetExpr args with + | Some targetExpr2 -> + newTyOpt <- Some(tyOfExpr g targetExpr2) + Some targetExpr2 + | None -> None + + match targetExpr2Opt with + | Some targetExpr2 -> Some(TTarget(vs, targetExpr2, flags)) + | None -> None) + + if targets2.Length = targets.Length then + Some(Expr.Match(spBind, mExpr, dtree, targets2, m, ty)) + else + None - | TryFinallyExpr (sp1, sp2, ty, bodyExpr, compensation, m) -> - match TryReduceApp env bodyExpr args with - | Some bodyExpr2 -> Some (mkTryFinally g (bodyExpr2, compensation, m, ty, sp1, sp2)) - | None -> None + | WhileExpr(sp1, sp2, guardExpr, bodyExpr, m) -> + match TryReduceApp env bodyExpr args with + | Some bodyExpr2 -> Some(mkWhile g (sp1, sp2, guardExpr, bodyExpr2, m)) + | None -> None - | TryWithExpr (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) -> - match TryReduceApp env bodyExpr args with - | Some bodyExpr2 -> Some (mkTryWith g (bodyExpr2, filterVar, filterExpr, handlerVar, handlerExpr, m, resTy, spTry, spWith)) - | None -> None + | TryFinallyExpr(sp1, sp2, ty, bodyExpr, compensation, m) -> + match TryReduceApp env bodyExpr args with + | Some bodyExpr2 -> Some(mkTryFinally g (bodyExpr2, compensation, m, ty, sp1, sp2)) + | None -> None - | Expr.DebugPoint (dp, innerExpr) -> - match TryReduceApp env innerExpr args with - | Some innerExpr2 -> Some (Expr.DebugPoint (dp, innerExpr2)) - | None -> None + | TryWithExpr(spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) -> + match TryReduceApp env bodyExpr args with + | Some bodyExpr2 -> Some(mkTryWith g (bodyExpr2, filterVar, filterExpr, handlerVar, handlerExpr, m, resTy, spTry, spWith)) + | None -> None - | _ -> - None + | Expr.DebugPoint(dp, innerExpr) -> + match TryReduceApp env innerExpr args with + | Some innerExpr2 -> Some(Expr.DebugPoint(dp, innerExpr2)) + | None -> None + + | _ -> None // Apply a single expansion of resumable code at the outermost position in an arbitrary expression - let rec TryReduceExpr (env: env) expr args remake = - if sm_verbose then printfn "expanding defns and reducing %A..." expr + let rec TryReduceExpr (env: env) expr args remake = + if sm_verbose then + printfn "expanding defns and reducing %A..." expr //if sm_verbose then printfn "checking %A for possible resumable code application..." expr match expr with // defn --> [expand_code] - | Expr.Val (defnRef, _, _) when env.ResumableCodeDefns.ContainsVal defnRef.Deref -> + | Expr.Val(defnRef, _, _) when env.ResumableCodeDefns.ContainsVal defnRef.Deref -> let defn = env.ResumableCodeDefns[defnRef.Deref] - if sm_verbose then printfn "found resumable code %A --> %A" defnRef defn + + if sm_verbose then + printfn "found resumable code %A --> %A" defnRef defn // Expand the resumable code definition - match TryReduceApp env defn args with - | Some expandedExpr -> - if sm_verbose then printfn "expanded resumable code %A --> %A..." defnRef expandedExpr + match TryReduceApp env defn args with + | Some expandedExpr -> + if sm_verbose then + printfn "expanded resumable code %A --> %A..." defnRef expandedExpr + Some expandedExpr - | None -> - Some (remake defn) + | None -> Some(remake defn) // defn.Invoke x --> let arg = x in [defn][arg/x] | ResumableCodeInvoke g (_, f, args2, _, rebuild) -> - if sm_verbose then printfn "found delegate invoke in possible reduction, f = %A, args now %A..." f (args2 @ args) + if sm_verbose then + printfn "found delegate invoke in possible reduction, f = %A, args now %A..." f (args2 @ args) + TryReduceExpr env f (args2 @ args) (fun f2 -> remake (rebuild (f2, args2))) - // defn x --> let arg = x in [defn][arg/x] - | Expr.App (f, _fty, _tyargs, args2, _m) -> - if sm_verbose then printfn "found function invoke in possible reduction, f = %A, args now %A..." f (args2 @ args) - TryReduceExpr env f (args2 @ args) (fun f2 -> remake (Expr.App (f2, _fty, _tyargs, args2, _m))) + // defn x --> let arg = x in [defn][arg/x] + | Expr.App(f, _fty, _tyargs, args2, _m) -> + if sm_verbose then + printfn "found function invoke in possible reduction, f = %A, args now %A..." f (args2 @ args) - | _ -> + TryReduceExpr env f (args2 @ args) (fun f2 -> remake (Expr.App(f2, _fty, _tyargs, args2, _m))) + + | _ -> //let (env, expr) = BindResumableCodeDefinitions env expr - match TryReduceApp env expr args with - | Some expandedExpr -> - if sm_verbose then printfn "reduction = %A, args = %A --> %A..." expr args expandedExpr + match TryReduceApp env expr args with + | Some expandedExpr -> + if sm_verbose then + printfn "reduction = %A, args = %A --> %A..." expr args expandedExpr + Some expandedExpr - | None -> - None + | None -> None // Repeated top-down rewrite - let makeRewriteEnv (env: env) = - { PreIntercept = Some (fun cont e -> match TryReduceExpr env e [] id with Some e2 -> Some (cont e2) | None -> None) - PostTransform = (fun _ -> None) - PreInterceptBinding = None - RewriteQuotations=true - StackGuard = StackGuard(LowerStateMachineStackGuardDepth, "LowerStateMachineStackGuardDepth") } - - let ConvertStateMachineLeafExpression (env: env) expr = - if sm_verbose then printfn "ConvertStateMachineLeafExpression for %A..." expr - expr |> RewriteExpr (makeRewriteEnv env) - - let ConvertStateMachineLeafDecisionTree (env: env) expr = - if sm_verbose then printfn "ConvertStateMachineLeafDecisionTree for %A..." expr - expr |> RewriteDecisionTree (makeRewriteEnv env) - - /// Repeatedly find outermost expansion definitions and apply outermost expansions - let rec RepeatBindAndApplyOuterDefinitions (env: env) expr = - if sm_verbose then printfn "RepeatBindAndApplyOuterDefinitions for %A..." expr + let makeRewriteEnv (env: env) = + { + PreIntercept = + Some(fun cont e -> + match TryReduceExpr env e [] id with + | Some e2 -> Some(cont e2) + | None -> None) + PostTransform = (fun _ -> None) + PreInterceptBinding = None + RewriteQuotations = true + StackGuard = StackGuard(LowerStateMachineStackGuardDepth, "LowerStateMachineStackGuardDepth") + } + + let ConvertStateMachineLeafExpression (env: env) expr = + if sm_verbose then + printfn "ConvertStateMachineLeafExpression for %A..." expr + + expr |> RewriteExpr(makeRewriteEnv env) + + let ConvertStateMachineLeafDecisionTree (env: env) expr = + if sm_verbose then + printfn "ConvertStateMachineLeafDecisionTree for %A..." expr + + expr |> RewriteDecisionTree(makeRewriteEnv env) + + /// Repeatedly find outermost expansion definitions and apply outermost expansions + let rec RepeatBindAndApplyOuterDefinitions (env: env) expr = + if sm_verbose then + printfn "RepeatBindAndApplyOuterDefinitions for %A..." expr + let env2, expr2 = BindResumableCodeDefinitions env expr - match TryReduceExpr env2 expr2 [] id with + + match TryReduceExpr env2 expr2 [] id with | Some res -> RepeatBindAndApplyOuterDefinitions env2 res | None -> env2, expr2 // Detect a state machine with a single method override [] - let (|ExpandedStateMachineInContext|_|) inputExpr = + let (|ExpandedStateMachineInContext|_|) inputExpr = // All expanded resumable code state machines e.g. 'task { .. }' begin with a bind of @builder or 'defn' - let env, expr = BindResumableCodeDefinitions env.Empty inputExpr + let env, expr = BindResumableCodeDefinitions env.Empty inputExpr + match expr with - | StructStateMachineExpr g - (dataTy, - (moveNextThisVar, moveNextBody), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), - (afterCodeThisVar, afterCodeBody)) -> + | StructStateMachineExpr g (dataTy, + (moveNextThisVar, moveNextBody), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), + (afterCodeThisVar, afterCodeBody)) -> let templateStructTy = g.mk_ResumableStateMachine_ty dataTy - let env = { env with TemplateStructTy = Some templateStructTy } - if sm_verbose then printfn "Found struct machine..." - if sm_verbose then printfn "Found struct machine jump table call..." + + let env = + { env with + TemplateStructTy = Some templateStructTy + } + + if sm_verbose then + printfn "Found struct machine..." + + if sm_verbose then + printfn "Found struct machine jump table call..." + let setStateMachineBodyR = ConvertStateMachineLeafExpression env setStateMachineBody let afterCodeBodyR = ConvertStateMachineLeafExpression env afterCodeBody - let remake2 (moveNextExprR, stateVars, thisVars) = - if sm_verbose then + + let remake2 (moveNextExprR, stateVars, thisVars) = + if sm_verbose then printfn "----------- AFTER REWRITE moveNextExprWithJumpTable ----------------------" printfn "%s" (DebugPrint.showExpr moveNextExprR) printfn "----------- AFTER REWRITE setStateMachineBodyR ----------------------" printfn "%s" (DebugPrint.showExpr setStateMachineBodyR) printfn "----------- AFTER REWRITE afterCodeBodyR ----------------------" printfn "%s" (DebugPrint.showExpr afterCodeBodyR) - LoweredStateMachine - (templateStructTy, dataTy, stateVars, thisVars, - (moveNextThisVar, moveNextExprR), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBodyR), - (afterCodeThisVar, afterCodeBodyR)) - ValueSome (env, remake2, moveNextBody) - | _ -> - ValueNone + + LoweredStateMachine( + templateStructTy, + dataTy, + stateVars, + thisVars, + (moveNextThisVar, moveNextExprR), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBodyR), + (afterCodeThisVar, afterCodeBodyR) + ) + + ValueSome(env, remake2, moveNextBody) + | _ -> ValueNone // A utility to add a jump table an expression - let addPcJumpTable m (pcs: int list) (pc2lab: Map) pcExpr expr = - if pcs.IsEmpty then + let addPcJumpTable m (pcs: int list) (pc2lab: Map) pcExpr expr = + if pcs.IsEmpty then expr else - let initLabel = generateCodeLabel() - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let mkGotoLabelTarget lab = mbuilder.AddResultTarget(Expr.Op (TOp.Goto lab, [], [], m)) + let initLabel = generateCodeLabel () + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let mkGotoLabelTarget lab = + mbuilder.AddResultTarget(Expr.Op(TOp.Goto lab, [], [], m)) + let dtree = TDSwitch( pcExpr, - [ // Yield one target for each PC, where the action of the target is to goto the appropriate label + [ // Yield one target for each PC, where the action of the target is to goto the appropriate label for pc in pcs do - yield mkCase(DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab[pc]) ], + yield mkCase (DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab[pc]) + ], // The default is to go to pcInit Some(mkGotoLabelTarget initLabel), - m) + m + ) let table = mbuilder.Close(dtree, m, g.int_ty) mkCompGenSequential m table (mkLabelled m initLabel expr) /// Detect constructs allowed in state machines - let rec ConvertResumableCode env (pcValInfo: ((Val * Expr) * Expr) option) expr : Result = - if sm_verbose then + let rec ConvertResumableCode + env + (pcValInfo: ((Val * Expr) * Expr) option) + expr + : Result = + if sm_verbose then printfn "---------ConvertResumableCode-------------------" printfn "%s" (DebugPrint.showExpr expr) printfn "---------" - + let env, expr = RepeatBindAndApplyOuterDefinitions env expr - - if sm_verbose then + + if sm_verbose then printfn "After RepeatBindAndApplyOuterDefinitions:\n%s" (DebugPrint.showExpr expr) printfn "---------" // Detect the different permitted constructs in the expanded state machine - let res = - match expr with - | ResumableCodeInvoke g (_, _, _, m, _) -> - Result.Error (FSComp.SR.reprResumableCodeInvokeNotReduced(!!m.ToString())) + let res = + match expr with + | ResumableCodeInvoke g (_, _, _, m, _) -> Result.Error(FSComp.SR.reprResumableCodeInvokeNotReduced (!!m.ToString())) - // Eliminate 'if __useResumableCode ...' within. - | IfUseResumableStateMachinesExpr g (thenExpr, _) -> - ConvertResumableCode env pcValInfo thenExpr + // Eliminate 'if __useResumableCode ...' within. + | IfUseResumableStateMachinesExpr g (thenExpr, _) -> ConvertResumableCode env pcValInfo thenExpr | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, _rebuild) -> ConvertResumableEntry env pcValInfo (noneBranchExpr, someVar, someBranchExpr, _rebuild) - | ResumeAtExpr g pcExpr -> - ConvertResumableResumeAt env (pcExpr, expr.Range) + | ResumeAtExpr g pcExpr -> ConvertResumableResumeAt env (pcExpr, expr.Range) // The expanded code for state machines may use sequential binding and sequential execution. // // let __stack_step = e1 in e2 // e1; e2 // - // A binding 'let .. = ... in ... ' is considered part of the state machine logic + // A binding 'let .. = ... in ... ' is considered part of the state machine logic // if it uses a binding variable starting with '__stack_*'. // If this case 'e1' becomes part of the state machine too. - | SequentialResumableCode g (e1, e2, _m, recreate) -> - ConvertResumableSequential env pcValInfo (e1, e2, _m, recreate) + | SequentialResumableCode g (e1, e2, _m, recreate) -> ConvertResumableSequential env pcValInfo (e1, e2, _m, recreate) // The expanded code for state machines may use while loops... - | WhileExpr (sp1, sp2, guardExpr, bodyExpr, m) -> - ConvertResumableWhile env pcValInfo (sp1, sp2, guardExpr, bodyExpr, m) + | WhileExpr(sp1, sp2, guardExpr, bodyExpr, m) -> ConvertResumableWhile env pcValInfo (sp1, sp2, guardExpr, bodyExpr, m) // The expanded code for state machines should not normally contain try/finally as any resumptions will repeatedly execute the finally. // However we include the synchronous version of the construct here for completeness. - | TryFinallyExpr (sp1, sp2, ty, e1, e2, m) -> - ConvertResumableTryFinally env pcValInfo (sp1, sp2, ty, e1, e2, m) + | TryFinallyExpr(sp1, sp2, ty, e1, e2, m) -> ConvertResumableTryFinally env pcValInfo (sp1, sp2, ty, e1, e2, m) // The expanded code for state machines may use for loops, however the // body must be synchronous. - | IntegerForLoopExpr (sp1, sp2, style, e1, e2, v, e3, m) -> + | IntegerForLoopExpr(sp1, sp2, style, e1, e2, v, e3, m) -> ConvertResumableIntegerForLoop env pcValInfo (sp1, sp2, style, e1, e2, v, e3, m) // The expanded code for state machines may use try/with.... - | TryWithExpr (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) -> + | TryWithExpr(spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) -> ConvertResumableTryWith env pcValInfo (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) // control-flow match - | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> - ConvertResumableMatch env pcValInfo (spBind, mExpr, dtree, targets, m, ty) + | Expr.Match(spBind, mExpr, dtree, targets, m, ty) -> ConvertResumableMatch env pcValInfo (spBind, mExpr, dtree, targets, m, ty) // Non-control-flow let binding can appear as part of state machine. The body is considered state-machine code, // the expression being bound is not. - | Expr.Let (bind, bodyExpr, m, _) -> + | Expr.Let(bind, bodyExpr, m, _) -> // Restriction: compilation of state machines containing non-toplevel constrained generic functions is not supported - if not bind.Var.IsCompiledAsTopLevel && IsGenericValWithGenericConstraints g bind.Var then - if sm_verbose then + if + not bind.Var.IsCompiledAsTopLevel + && IsGenericValWithGenericConstraints g bind.Var + then + if sm_verbose then printfn " --> Failing state machine compilation, state machine contains non-toplevel constrained generic function" - Result.Error (FSComp.SR.reprResumableCodeContainsConstrainedGenericLet()) + + Result.Error(FSComp.SR.reprResumableCodeContainsConstrainedGenericLet ()) else ConvertResumableLet env pcValInfo (bind, bodyExpr, m) - | Expr.LetRec _ -> - Result.Error (FSComp.SR.reprResumableCodeContainsLetRec()) + | Expr.LetRec _ -> Result.Error(FSComp.SR.reprResumableCodeContainsLetRec ()) - | Expr.DebugPoint(dp, innerExpr) -> - ConvertResumableDebugPoint env pcValInfo (dp, innerExpr) + | Expr.DebugPoint(dp, innerExpr) -> ConvertResumableDebugPoint env pcValInfo (dp, innerExpr) // Arbitrary expression - | _ -> + | _ -> let exprR = ConvertStateMachineLeafExpression env expr - { phase1 = exprR - phase2 = (fun _ctxt -> exprR) - entryPoints = [] - stateVars = [] - thisVars = [] - resumableVars = emptyFreeVars } + + { + phase1 = exprR + phase2 = (fun _ctxt -> exprR) + entryPoints = [] + stateVars = [] + thisVars = [] + resumableVars = emptyFreeVars + } |> Result.Ok - if sm_verbose then - match res with - | Result.Ok res -> + if sm_verbose then + match res with + | Result.Ok res -> printfn "-------------------" printfn "Phase 1 Done for %s" (DebugPrint.showExpr res.phase1) - printfn "Phase 1 Done, resumableVars = %A" (res.resumableVars.FreeLocals |> Zset.elements |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) |> String.concat ",") - printfn "Phase 1 Done, stateVars = %A" (res.stateVars |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) |> String.concat ",") - printfn "Phase 1 Done, thisVars = %A" (res.thisVars |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) |> String.concat ",") + + printfn + "Phase 1 Done, resumableVars = %A" + (res.resumableVars.FreeLocals + |> Zset.elements + |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) + |> String.concat ",") + + printfn + "Phase 1 Done, stateVars = %A" + (res.stateVars + |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) + |> String.concat ",") + + printfn + "Phase 1 Done, thisVars = %A" + (res.thisVars + |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) + |> String.concat ",") + printfn "-------------------" - | Result.Error msg-> + | Result.Error msg -> printfn "Phase 1 failed: %s" msg printfn "Phase 1 failed for %s" (DebugPrint.showExpr expr) + res and ConvertResumableEntry env pcValInfo (noneBranchExpr, someVar, someBranchExpr, _rebuild) = - if sm_verbose then printfn "ResumableEntryMatchExpr" + if sm_verbose then + printfn "ResumableEntryMatchExpr" // printfn "found sequential" - let reenterPC = genPC() - let envSome = { env with ResumableCodeDefns = env.ResumableCodeDefns.Add someVar (mkInt g someVar.Range reenterPC) } + let reenterPC = genPC () + + let envSome = + { env with + ResumableCodeDefns = env.ResumableCodeDefns.Add someVar (mkInt g someVar.Range reenterPC) + } + let resNone = ConvertResumableCode env pcValInfo noneBranchExpr let resSome = ConvertResumableCode envSome pcValInfo someBranchExpr - match resNone, resSome with + match resNone, resSome with | Result.Ok resNone, Result.Ok resSome -> - let resumableVars = unionFreeVars (freeInExpr CollectLocals resNone.phase1) resSome.resumableVars + let resumableVars = + unionFreeVars (freeInExpr CollectLocals resNone.phase1) resSome.resumableVars + let m = someBranchExpr.Range - let recreate reenterLabOpt e1 e2 = - let lab = (match reenterLabOpt with Some l -> l | _ -> generateCodeLabel()) + + let recreate reenterLabOpt e1 e2 = + let lab = + (match reenterLabOpt with + | Some l -> l + | _ -> generateCodeLabel ()) + mkCond DebugPointAtBinding.NoneAtSticky m (tyOfExpr g noneBranchExpr) (mkFalse g m) (mkLabelled m lab e1) e2 - { phase1 = recreate None resNone.phase1 resSome.phase1 - phase2 = (fun ctxt -> - let generate2 = resSome.phase2 ctxt - let generate1 = resNone.phase2 ctxt - let generate = recreate (Some ctxt[reenterPC]) generate1 generate2 - generate) - entryPoints= resSome.entryPoints @ [reenterPC] @ resNone.entryPoints - stateVars = resSome.stateVars @ resNone.stateVars - thisVars = resSome.thisVars @ resNone.thisVars - resumableVars = resumableVars } + + { + phase1 = recreate None resNone.phase1 resSome.phase1 + phase2 = + (fun ctxt -> + let generate2 = resSome.phase2 ctxt + let generate1 = resNone.phase2 ctxt + let generate = recreate (Some ctxt[reenterPC]) generate1 generate2 + generate) + entryPoints = resSome.entryPoints @ [ reenterPC ] @ resNone.entryPoints + stateVars = resSome.stateVars @ resNone.stateVars + thisVars = resSome.thisVars @ resNone.thisVars + resumableVars = resumableVars + } |> Result.Ok - | Result.Error err, _ | _, Result.Error err -> Result.Error err + | Result.Error err, _ + | _, Result.Error err -> Result.Error err - and ConvertResumableResumeAt env (pcExpr , m)= - if sm_verbose then printfn "ResumeAtExpr" + and ConvertResumableResumeAt env (pcExpr, m) = + if sm_verbose then + printfn "ResumeAtExpr" // Macro-evaluate the pcExpr let pcExprVal = ConvertStateMachineLeafExpression env pcExpr + match pcExprVal with | Int32Expr contIdPC -> let recreate contLabOpt = - Expr.Op (TOp.Goto (match contLabOpt with Some l -> l | _ -> generateCodeLabel()), [], [], m) - - { phase1 = recreate None - phase2 = (fun ctxt -> - let generate = recreate (Some ctxt[contIdPC]) - generate) - entryPoints = [] - stateVars = [] - thisVars = [] - resumableVars = emptyFreeVars } + Expr.Op( + TOp.Goto( + match contLabOpt with + | Some l -> l + | _ -> generateCodeLabel () + ), + [], + [], + m + ) + + { + phase1 = recreate None + phase2 = + (fun ctxt -> + let generate = recreate (Some ctxt[contIdPC]) + generate) + entryPoints = [] + stateVars = [] + thisVars = [] + resumableVars = emptyFreeVars + } |> Result.Ok - | _ -> - Result.Error(FSComp.SR.reprResumableCodeContainsDynamicResumeAtInBody()) + | _ -> Result.Error(FSComp.SR.reprResumableCodeContainsDynamicResumeAtInBody ()) and ConvertResumableSequential env pcValInfo (e1, e2, _m, recreate) = - if sm_verbose then printfn "SequentialResumableCode" + if sm_verbose then + printfn "SequentialResumableCode" // printfn "found sequential" let res1 = ConvertResumableCode env pcValInfo e1 let res2 = ConvertResumableCode env pcValInfo e2 - match res1, res2 with + + match res1, res2 with | Result.Ok res1, Result.Ok res2 -> let resumableVars = if res1.entryPoints.IsEmpty then @@ -599,331 +751,439 @@ type LowerStateMachine(g: TcGlobals) = // res1 is not synchronous. All of 'e2' is needed after resuming at any of the labels unionFreeVars res1.resumableVars (freeInExpr CollectLocals res2.phase1) - { phase1 = recreate res1.phase1 res2.phase1 - phase2 = (fun ctxt -> - let generate1 = res1.phase2 ctxt - let generate2 = res2.phase2 ctxt - let generate = recreate generate1 generate2 - generate) - entryPoints= res1.entryPoints @ res2.entryPoints - stateVars = res1.stateVars @ res2.stateVars - thisVars = res1.thisVars @ res2.thisVars - resumableVars = resumableVars } + { + phase1 = recreate res1.phase1 res2.phase1 + phase2 = + (fun ctxt -> + let generate1 = res1.phase2 ctxt + let generate2 = res2.phase2 ctxt + let generate = recreate generate1 generate2 + generate) + entryPoints = res1.entryPoints @ res2.entryPoints + stateVars = res1.stateVars @ res2.stateVars + thisVars = res1.thisVars @ res2.thisVars + resumableVars = resumableVars + } |> Result.Ok - | Result.Error err, _ | _, Result.Error err -> Result.Error err + | Result.Error err, _ + | _, Result.Error err -> Result.Error err and ConvertResumableDebugPoint env pcValInfo (dp, innerExpr) = let res1 = ConvertResumableCode env pcValInfo innerExpr - match res1 with + + match res1 with | Result.Ok res1 -> - { res1 with - phase1 = Expr.DebugPoint(dp, res1.phase1) - phase2 = (fun ctxt -> - let generate1 = res1.phase2 ctxt - Expr.DebugPoint(dp, generate1)) } + { res1 with + phase1 = Expr.DebugPoint(dp, res1.phase1) + phase2 = + (fun ctxt -> + let generate1 = res1.phase2 ctxt + Expr.DebugPoint(dp, generate1)) + } |> Result.Ok | Result.Error err -> Result.Error err and ConvertResumableWhile env pcValInfo (sp1, sp2, guardExpr, bodyExpr, m) = - if sm_verbose then printfn "WhileExpr" + if sm_verbose then + printfn "WhileExpr" let resg = ConvertResumableCode env pcValInfo guardExpr let resb = ConvertResumableCode env pcValInfo bodyExpr - match resg, resb with + + match resg, resb with | Result.Ok resg, Result.Ok resb -> let eps = resg.entryPoints @ resb.entryPoints // All free variables get captured if there are any entrypoints at all - let resumableVars = if eps.IsEmpty then emptyFreeVars else unionFreeVars (freeInExpr CollectLocals resg.phase1) (freeInExpr CollectLocals resb.phase1) - { phase1 = mkWhile g (sp1, sp2, resg.phase1, resb.phase1, m) - phase2 = (fun ctxt -> - let egR = resg.phase2 ctxt - let ebR = resb.phase2 ctxt - - // Clear the pcVal on backward branch, causing jump tables at entry to nested try-blocks to not activate - let ebR2 = - match pcValInfo with - | None -> ebR - | Some ((pcVal, _), _) -> - mkCompGenThenDoSequential m - ebR - (mkValSet m (mkLocalValRef pcVal) (mkZero g m)) - - mkWhile g (sp1, sp2, egR, ebR2, m)) - entryPoints= eps - stateVars = resg.stateVars @ resb.stateVars - thisVars = resg.thisVars @ resb.thisVars - resumableVars = resumableVars } + let resumableVars = + if eps.IsEmpty then + emptyFreeVars + else + unionFreeVars (freeInExpr CollectLocals resg.phase1) (freeInExpr CollectLocals resb.phase1) + + { + phase1 = mkWhile g (sp1, sp2, resg.phase1, resb.phase1, m) + phase2 = + (fun ctxt -> + let egR = resg.phase2 ctxt + let ebR = resb.phase2 ctxt + + // Clear the pcVal on backward branch, causing jump tables at entry to nested try-blocks to not activate + let ebR2 = + match pcValInfo with + | None -> ebR + | Some((pcVal, _), _) -> mkCompGenThenDoSequential m ebR (mkValSet m (mkLocalValRef pcVal) (mkZero g m)) + + mkWhile g (sp1, sp2, egR, ebR2, m)) + entryPoints = eps + stateVars = resg.stateVars @ resb.stateVars + thisVars = resg.thisVars @ resb.thisVars + resumableVars = resumableVars + } |> Result.Ok - | Result.Error err, _ | _, Result.Error err -> Result.Error err + | Result.Error err, _ + | _, Result.Error err -> Result.Error err and ConvertResumableTryFinally env pcValInfo (sp1, sp2, ty, e1, e2, m) = - if sm_verbose then printfn "TryFinallyExpr" + if sm_verbose then + printfn "TryFinallyExpr" + let res1 = ConvertResumableCode env pcValInfo e1 let res2 = ConvertResumableCode env pcValInfo e2 - match res1, res2 with + + match res1, res2 with | Result.Ok res1, Result.Ok res2 -> let eps = res1.entryPoints @ res2.entryPoints - if eps.Length > 0 then - Result.Error (FSComp.SR.reprResumableCodeContainsResumptionInTryFinally()) + + if eps.Length > 0 then + Result.Error(FSComp.SR.reprResumableCodeContainsResumptionInTryFinally ()) else - { phase1 = mkTryFinally g (res1.phase1, res2.phase1, m, ty, sp1, sp2) - phase2 = (fun ctxt -> - let egR = res1.phase2 ctxt - let ebR = res2.phase2 ctxt - mkTryFinally g (egR, ebR, m, ty, sp1, sp2)) - entryPoints= eps - stateVars = res1.stateVars @ res2.stateVars - thisVars = res1.thisVars @ res2.thisVars - resumableVars = emptyFreeVars (* eps is empty, hence synchronous, no capture *) } + { + phase1 = mkTryFinally g (res1.phase1, res2.phase1, m, ty, sp1, sp2) + phase2 = + (fun ctxt -> + let egR = res1.phase2 ctxt + let ebR = res2.phase2 ctxt + mkTryFinally g (egR, ebR, m, ty, sp1, sp2)) + entryPoints = eps + stateVars = res1.stateVars @ res2.stateVars + thisVars = res1.thisVars @ res2.thisVars + resumableVars = emptyFreeVars (* eps is empty, hence synchronous, no capture *) + } |> Result.Ok - | Result.Error err, _ | _, Result.Error err -> Result.Error err + | Result.Error err, _ + | _, Result.Error err -> Result.Error err and ConvertResumableIntegerForLoop env pcValInfo (spFor, spTo, style, e1, e2, v, e3, m) = - if sm_verbose then printfn "IntegerForLoopExpr" + if sm_verbose then + printfn "IntegerForLoopExpr" + let res1 = ConvertResumableCode env pcValInfo e1 let res2 = ConvertResumableCode env pcValInfo e2 let res3 = ConvertResumableCode env pcValInfo e3 - match res1, res2, res3 with + + match res1, res2, res3 with | Result.Ok res1, Result.Ok res2, Result.Ok res3 -> let eps = res1.entryPoints @ res2.entryPoints @ res3.entryPoints - if eps.Length > 0 then - Result.Error(FSComp.SR.reprResumableCodeContainsFastIntegerForLoop()) - else - { phase1 = mkIntegerForLoop g (spFor, spTo, v, res1.phase1, style, res2.phase1, res3.phase1, m) - phase2 = (fun ctxt -> - let e1R = res1.phase2 ctxt - let e2R = res2.phase2 ctxt - let e3R = res3.phase2 ctxt - // Clear the pcVal on backward branch, causing jump tables at entry to nested try-blocks to not activate - let e3R2 = - match pcValInfo with - | None -> e3R - | Some ((pcVal, _), _) -> - mkCompGenThenDoSequential m - e3R - (mkValSet m (mkLocalValRef pcVal) (mkZero g m)) - - mkIntegerForLoop g (spFor, spTo, v, e1R, style, e2R, e3R2, m)) - entryPoints= eps - stateVars = res1.stateVars @ res2.stateVars @ res3.stateVars - thisVars = res1.thisVars @ res2.thisVars @ res3.thisVars - resumableVars = emptyFreeVars (* eps is empty, hence synchronous, no capture *) } + if eps.Length > 0 then + Result.Error(FSComp.SR.reprResumableCodeContainsFastIntegerForLoop ()) + else + { + phase1 = mkIntegerForLoop g (spFor, spTo, v, res1.phase1, style, res2.phase1, res3.phase1, m) + phase2 = + (fun ctxt -> + let e1R = res1.phase2 ctxt + let e2R = res2.phase2 ctxt + let e3R = res3.phase2 ctxt + + // Clear the pcVal on backward branch, causing jump tables at entry to nested try-blocks to not activate + let e3R2 = + match pcValInfo with + | None -> e3R + | Some((pcVal, _), _) -> mkCompGenThenDoSequential m e3R (mkValSet m (mkLocalValRef pcVal) (mkZero g m)) + + mkIntegerForLoop g (spFor, spTo, v, e1R, style, e2R, e3R2, m)) + entryPoints = eps + stateVars = res1.stateVars @ res2.stateVars @ res3.stateVars + thisVars = res1.thisVars @ res2.thisVars @ res3.thisVars + resumableVars = emptyFreeVars (* eps is empty, hence synchronous, no capture *) + } |> Result.Ok - | Result.Error err, _, _ | _, Result.Error err, _ | _, _, Result.Error err -> Result.Error err + | Result.Error err, _, _ + | _, Result.Error err, _ + | _, _, Result.Error err -> Result.Error err and ConvertResumableTryWith env pcValInfo (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) = - if sm_verbose then printfn "TryWithExpr" + if sm_verbose then + printfn "TryWithExpr" + let resBody = ConvertResumableCode env pcValInfo bodyExpr let resFilter = ConvertResumableCode env pcValInfo filterExpr let resHandler = ConvertResumableCode env pcValInfo handlerExpr - match resBody, resFilter, resHandler with + + match resBody, resFilter, resHandler with | Result.Ok resBody, Result.Ok resFilter, Result.Ok resHandler -> - let epsNope = resFilter.entryPoints @ resHandler.entryPoints - if epsNope.Length > 0 then - Result.Error(FSComp.SR.reprResumableCodeContainsResumptionInHandlerOrFilter()) + let epsNope = resFilter.entryPoints @ resHandler.entryPoints + + if epsNope.Length > 0 then + Result.Error(FSComp.SR.reprResumableCodeContainsResumptionInHandlerOrFilter ()) else - { phase1 = mkTryWith g (resBody.phase1, filterVar, resFilter.phase1, handlerVar, resHandler.phase1, m, resTy, spTry, spWith) - phase2 = (fun ctxt -> - // We can't jump into a try/catch block. So we jump to the start of the try/catch and add a new jump table - let pcsAndLabs = ctxt |> Map.toList - let innerPcs = resBody.entryPoints - if innerPcs.IsEmpty then - let vBodyR = resBody.phase2 ctxt - let filterExprR = resFilter.phase2 ctxt - let handlerExprR = resHandler.phase2 ctxt - mkTryWith g (vBodyR, filterVar, filterExprR, handlerVar, handlerExprR, m, resTy, spTry, spWith) - else - let innerPcSet = innerPcs |> Set.ofList - let outerLabsForInnerPcs = pcsAndLabs |> List.filter (fun (pc, _outerLab) -> innerPcSet.Contains pc) |> List.map snd - // generate the inner labels - let pcsAndInnerLabs = pcsAndLabs |> List.map (fun (pc, l) -> (pc, if innerPcSet.Contains pc then generateCodeLabel() else l)) - let innerPc2Lab = Map.ofList pcsAndInnerLabs - - let vBodyR = resBody.phase2 innerPc2Lab - let filterExprR = resFilter.phase2 ctxt - let handlerExprR = resHandler.phase2 ctxt - - // Add a jump table at the entry to the try - let vBodyRWithJumpTable = - match pcValInfo with - | None -> vBodyR - | Some ((_, pcValExpr), _) -> addPcJumpTable m innerPcs innerPc2Lab pcValExpr vBodyR - let coreExpr = mkTryWith g (vBodyRWithJumpTable, filterVar, filterExprR, handlerVar, handlerExprR, m, resTy, spTry, spWith) - // Place all the outer labels just before the try - let labelledExpr = (coreExpr, outerLabsForInnerPcs) ||> List.fold (fun e l -> mkLabelled m l e) - - labelledExpr) - entryPoints= resBody.entryPoints @ resFilter.entryPoints @ resHandler.entryPoints - stateVars = resBody.stateVars @ resFilter.stateVars @ resHandler.stateVars - thisVars = resBody.thisVars @ resFilter.thisVars @ resHandler.thisVars - resumableVars = unionFreeVars resBody.resumableVars (unionFreeVars(freeInExpr CollectLocals resFilter.phase1) (freeInExpr CollectLocals resHandler.phase1)) } - |> Result.Ok - | Result.Error err, _, _ | _, Result.Error err, _ | _, _, Result.Error err -> Result.Error err + { + phase1 = + mkTryWith g (resBody.phase1, filterVar, resFilter.phase1, handlerVar, resHandler.phase1, m, resTy, spTry, spWith) + phase2 = + (fun ctxt -> + // We can't jump into a try/catch block. So we jump to the start of the try/catch and add a new jump table + let pcsAndLabs = ctxt |> Map.toList + let innerPcs = resBody.entryPoints + + if innerPcs.IsEmpty then + let vBodyR = resBody.phase2 ctxt + let filterExprR = resFilter.phase2 ctxt + let handlerExprR = resHandler.phase2 ctxt + mkTryWith g (vBodyR, filterVar, filterExprR, handlerVar, handlerExprR, m, resTy, spTry, spWith) + else + let innerPcSet = innerPcs |> Set.ofList + + let outerLabsForInnerPcs = + pcsAndLabs + |> List.filter (fun (pc, _outerLab) -> innerPcSet.Contains pc) + |> List.map snd + // generate the inner labels + let pcsAndInnerLabs = + pcsAndLabs + |> List.map (fun (pc, l) -> (pc, if innerPcSet.Contains pc then generateCodeLabel () else l)) + + let innerPc2Lab = Map.ofList pcsAndInnerLabs + + let vBodyR = resBody.phase2 innerPc2Lab + let filterExprR = resFilter.phase2 ctxt + let handlerExprR = resHandler.phase2 ctxt + + // Add a jump table at the entry to the try + let vBodyRWithJumpTable = + match pcValInfo with + | None -> vBodyR + | Some((_, pcValExpr), _) -> addPcJumpTable m innerPcs innerPc2Lab pcValExpr vBodyR + + let coreExpr = + mkTryWith + g + (vBodyRWithJumpTable, filterVar, filterExprR, handlerVar, handlerExprR, m, resTy, spTry, spWith) + // Place all the outer labels just before the try + let labelledExpr = + (coreExpr, outerLabsForInnerPcs) ||> List.fold (fun e l -> mkLabelled m l e) + + labelledExpr) + entryPoints = resBody.entryPoints @ resFilter.entryPoints @ resHandler.entryPoints + stateVars = resBody.stateVars @ resFilter.stateVars @ resHandler.stateVars + thisVars = resBody.thisVars @ resFilter.thisVars @ resHandler.thisVars + resumableVars = + unionFreeVars + resBody.resumableVars + (unionFreeVars (freeInExpr CollectLocals resFilter.phase1) (freeInExpr CollectLocals resHandler.phase1)) + } + |> Result.Ok + | Result.Error err, _, _ + | _, Result.Error err, _ + | _, _, Result.Error err -> Result.Error err and ConvertResumableMatch env pcValInfo (spBind, mExpr, dtree, targets, m, ty) = - if sm_verbose then printfn "MatchExpr" - // lower all the targets. - let dtreeR = ConvertStateMachineLeafDecisionTree env dtree - let tglArray = - targets |> Array.map (fun (TTarget(_vs, targetExpr, _)) -> - ConvertResumableCode env pcValInfo targetExpr) - - match (tglArray |> Array.forall (function Result.Ok _ -> true | Result.Error _ -> false)) with + if sm_verbose then + printfn "MatchExpr" + // lower all the targets. + let dtreeR = ConvertStateMachineLeafDecisionTree env dtree + + let tglArray = + targets + |> Array.map (fun (TTarget(_vs, targetExpr, _)) -> ConvertResumableCode env pcValInfo targetExpr) + + match + (tglArray + |> Array.forall (function + | Result.Ok _ -> true + | Result.Error _ -> false)) + with | true -> - let tglArray = tglArray |> Array.map (function Result.Ok v -> v | _ -> failwith "unreachable") - let tgl = tglArray |> Array.toList + let tglArray = + tglArray + |> Array.map (function + | Result.Ok v -> v + | _ -> failwith "unreachable") + + let tgl = tglArray |> Array.toList let entryPoints = tgl |> List.collect (fun res -> res.entryPoints) + let resumableVars = (emptyFreeVars, Array.zip targets tglArray) ||> Array.fold (fun fvs (TTarget(_vs, _, _), res) -> - if res.entryPoints.IsEmpty then fvs else unionFreeVars fvs res.resumableVars) - let stateVars = - (targets, tglArray) ||> Array.zip |> Array.toList |> List.collect (fun (TTarget(vs, _, _), res) -> - let stateVars = vs |> List.filter (fun v -> res.resumableVars.FreeLocals.Contains(v)) |> List.map mkLocalValRef + if res.entryPoints.IsEmpty then + fvs + else + unionFreeVars fvs res.resumableVars) + + let stateVars = + (targets, tglArray) + ||> Array.zip + |> Array.toList + |> List.collect (fun (TTarget(vs, _, _), res) -> + let stateVars = + vs + |> List.filter (fun v -> res.resumableVars.FreeLocals.Contains(v)) + |> List.map mkLocalValRef + stateVars @ res.stateVars) - let thisVars = tglArray |> Array.toList |> List.collect (fun res -> res.thisVars) - { phase1 = - let gtgs = - (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, _)) res -> - let flags = vs |> List.map (fun v -> res.resumableVars.FreeLocals.Contains(v)) - TTarget(vs, res.phase1, Some flags)) - primMkMatch (spBind, mExpr, dtreeR, gtgs, m, ty) - - phase2 = (fun ctxt -> - let gtgs = - (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, _)) res -> - let flags = vs |> List.map (fun v -> res.resumableVars.FreeLocals.Contains(v)) - TTarget(vs, res.phase2 ctxt, Some flags)) - let generate = primMkMatch (spBind, mExpr, dtreeR, gtgs, m, ty) - generate) - - entryPoints = entryPoints - stateVars = stateVars - resumableVars = resumableVars - thisVars = thisVars } + + let thisVars = tglArray |> Array.toList |> List.collect (fun res -> res.thisVars) + + { + phase1 = + let gtgs = + (targets, tglArray) + ||> Array.map2 (fun (TTarget(vs, _, _)) res -> + let flags = vs |> List.map (fun v -> res.resumableVars.FreeLocals.Contains(v)) + TTarget(vs, res.phase1, Some flags)) + + primMkMatch (spBind, mExpr, dtreeR, gtgs, m, ty) + + phase2 = + (fun ctxt -> + let gtgs = + (targets, tglArray) + ||> Array.map2 (fun (TTarget(vs, _, _)) res -> + let flags = vs |> List.map (fun v -> res.resumableVars.FreeLocals.Contains(v)) + TTarget(vs, res.phase2 ctxt, Some flags)) + + let generate = primMkMatch (spBind, mExpr, dtreeR, gtgs, m, ty) + generate) + + entryPoints = entryPoints + stateVars = stateVars + resumableVars = resumableVars + thisVars = thisVars + } |> Result.Ok - | _ -> tglArray |> Array.find (function Result.Ok _ -> false | Result.Error _ -> true) + | _ -> + tglArray + |> Array.find (function + | Result.Ok _ -> false + | Result.Error _ -> true) and ConvertResumableLet env pcValInfo (bind, bodyExpr, m) = // Non-control-flow let binding can appear as part of state machine. The body is considered state-machine code, // the expression being bound is not. - if sm_verbose then printfn "LetExpr (non-control-flow, rewrite rhs)" + if sm_verbose then + printfn "LetExpr (non-control-flow, rewrite rhs)" // Rewrite the expression on the r.h.s. of the binding let bindExpr = ConvertStateMachineLeafExpression env bind.Expr let bind = mkBind bind.DebugPoint bind.Var bindExpr - if sm_verbose then printfn "LetExpr (non-control-flow, body)" + + if sm_verbose then + printfn "LetExpr (non-control-flow, body)" let resBody = ConvertResumableCode env pcValInfo bodyExpr match resBody with | Result.Ok resBody -> - // The isByrefTy check is an adhoc check to avoid capturing the 'this' parameter of a struct state machine + // The isByrefTy check is an adhoc check to avoid capturing the 'this' parameter of a struct state machine // You might think we could do this: // // let sm = &this // ... await point ... // ... sm .... // However the 'sm' won't be set on that path. - if isByrefTy g bind.Var.Type && - (match env.TemplateStructTy with - | None -> false - | Some ty -> typeEquiv g ty (destByrefTy g bind.Var.Type)) then - RepresentBindingAsThis bind resBody m - |> Result.Ok - elif bind.Var.IsCompiledAsTopLevel || - not (resBody.resumableVars.FreeLocals.Contains(bind.Var)) || - bind.Var.LogicalName.StartsWithOrdinal(stackVarPrefix) then - if sm_verbose then printfn "LetExpr (non-control-flow, rewrite rhs, RepresentBindingAsTopLevelOrLocal)" - RepresentBindingAsTopLevelOrLocal bind resBody m - |> Result.Ok + if + isByrefTy g bind.Var.Type + && (match env.TemplateStructTy with + | None -> false + | Some ty -> typeEquiv g ty (destByrefTy g bind.Var.Type)) + then + RepresentBindingAsThis bind resBody m |> Result.Ok + elif + bind.Var.IsCompiledAsTopLevel + || not (resBody.resumableVars.FreeLocals.Contains(bind.Var)) + || bind.Var.LogicalName.StartsWithOrdinal(stackVarPrefix) + then + if sm_verbose then + printfn "LetExpr (non-control-flow, rewrite rhs, RepresentBindingAsTopLevelOrLocal)" + + RepresentBindingAsTopLevelOrLocal bind resBody m |> Result.Ok else - if sm_verbose then printfn "LetExpr (non-control-flow, rewrite rhs, RepresentBindingAsStateVar)" + if sm_verbose then + printfn "LetExpr (non-control-flow, rewrite rhs, RepresentBindingAsStateVar)" // printfn "found state variable %s" bind.Var.DisplayName - RepresentBindingAsStateVar g bind resBody m - |> Result.Ok - | Result.Error msg -> - Result.Error msg + RepresentBindingAsStateVar g bind resBody m |> Result.Ok + | Result.Error msg -> Result.Error msg member _.Apply(overallExpr, altExprOpt) = let fallback msg = - match altExprOpt with - | None -> - LoweredStateMachineResult.NoAlternative msg - | Some altExpr -> - LoweredStateMachineResult.UseAlternative (msg, altExpr) + match altExprOpt with + | None -> LoweredStateMachineResult.NoAlternative msg + | Some altExpr -> LoweredStateMachineResult.UseAlternative(msg, altExpr) match overallExpr with - | ExpandedStateMachineInContext (env, remake, moveNextExpr) -> + | ExpandedStateMachineInContext(env, remake, moveNextExpr) -> let m = moveNextExpr.Range - match moveNextExpr with - | OptionalResumeAtExpr g (pcExprOpt, codeExpr) -> - let env, codeExprR = RepeatBindAndApplyOuterDefinitions env codeExpr - let frees = (freeInExpr CollectLocals overallExpr).FreeLocals - if frees |> Zset.exists (isExpandVar g) then - let nonfree = frees |> Zset.elements |> List.filter (isExpandVar g) |> List.map (fun v -> v.DisplayName) |> String.concat "," - let msg = FSComp.SR.reprResumableCodeValueHasNoDefinition(nonfree) - fallback msg - else - let pcExprROpt = pcExprOpt |> Option.map (ConvertStateMachineLeafExpression env) - let pcValInfo = - match pcExprROpt with - | None -> None - | Some e -> Some (mkMutableCompGenLocal e.Range "pcVal" g.int32_ty, e) - - if sm_verbose then - printfn "Found state machine override method and code expression..." - printfn "----------- OVERALL EXPRESSION FOR STATE MACHINE CONVERSION ----------------------" - printfn "%s" (DebugPrint.showExpr overallExpr) - printfn "----------- INPUT TO STATE MACHINE CONVERSION ----------------------" - printfn "%s" (DebugPrint.showExpr codeExpr) - printfn "----------- START STATE MACHINE CONVERSION ----------------------" - - // Perform phase1 of the conversion - let phase1 = ConvertResumableCode env pcValInfo codeExprR - match phase1 with - | Result.Error msg -> + match moveNextExpr with + | OptionalResumeAtExpr g (pcExprOpt, codeExpr) -> + let env, codeExprR = RepeatBindAndApplyOuterDefinitions env codeExpr + let frees = (freeInExpr CollectLocals overallExpr).FreeLocals + + if frees |> Zset.exists (isExpandVar g) then + let nonfree = + frees + |> Zset.elements + |> List.filter (isExpandVar g) + |> List.map (fun v -> v.DisplayName) + |> String.concat "," + + let msg = FSComp.SR.reprResumableCodeValueHasNoDefinition (nonfree) fallback msg - | Result.Ok phase1 -> + else + let pcExprROpt = pcExprOpt |> Option.map (ConvertStateMachineLeafExpression env) + + let pcValInfo = + match pcExprROpt with + | None -> None + | Some e -> Some(mkMutableCompGenLocal e.Range "pcVal" g.int32_ty, e) + + if sm_verbose then + printfn "Found state machine override method and code expression..." + printfn "----------- OVERALL EXPRESSION FOR STATE MACHINE CONVERSION ----------------------" + printfn "%s" (DebugPrint.showExpr overallExpr) + printfn "----------- INPUT TO STATE MACHINE CONVERSION ----------------------" + printfn "%s" (DebugPrint.showExpr codeExpr) + printfn "----------- START STATE MACHINE CONVERSION ----------------------" - // Work out the initial mapping of pcs to labels - let pcs = [ 1 .. pcCount ] - let labs = pcs |> List.map (fun _ -> generateCodeLabel()) - let pc2lab = Map.ofList (List.zip pcs labs) + // Perform phase1 of the conversion + let phase1 = ConvertResumableCode env pcValInfo codeExprR - // Execute phase2, building the core of the method - if sm_verbose then printfn "----------- PHASE2 ----------------------" + match phase1 with + | Result.Error msg -> fallback msg + | Result.Ok phase1 -> - // Perform phase2 to build the final expression - let moveNextExprR = phase1.phase2 pc2lab + // Work out the initial mapping of pcs to labels + let pcs = [ 1..pcCount ] + let labs = pcs |> List.map (fun _ -> generateCodeLabel ()) + let pc2lab = Map.ofList (List.zip pcs labs) - if sm_verbose then printfn "----------- ADDING JUMP TABLE ----------------------" + // Execute phase2, building the core of the method + if sm_verbose then + printfn "----------- PHASE2 ----------------------" + + // Perform phase2 to build the final expression + let moveNextExprR = phase1.phase2 pc2lab + + if sm_verbose then + printfn "----------- ADDING JUMP TABLE ----------------------" + + // Add the jump table + let moveNextExprWithJumpTable = + match pcValInfo with + | None -> moveNextExprR + | Some((v, pcValExprR), pcExprR) -> + mkCompGenLet m v pcExprR (addPcJumpTable m pcs pc2lab pcValExprR moveNextExprR) - // Add the jump table - let moveNextExprWithJumpTable = - match pcValInfo with - | None -> moveNextExprR - | Some ((v,pcValExprR),pcExprR) -> mkCompGenLet m v pcExprR (addPcJumpTable m pcs pc2lab pcValExprR moveNextExprR) - - if sm_verbose then printfn "----------- REMAKE ----------------------" + if sm_verbose then + printfn "----------- REMAKE ----------------------" - // Build the result - let res = remake (moveNextExprWithJumpTable, phase1.stateVars, phase1.thisVars) - LoweredStateMachineResult.Lowered res + // Build the result + let res = remake (moveNextExprWithJumpTable, phase1.stateVars, phase1.thisVars) + LoweredStateMachineResult.Lowered res - | _ -> - let msg = FSComp.SR.reprStateMachineInvalidForm() + | _ -> + let msg = FSComp.SR.reprStateMachineInvalidForm () fallback msg let LowerStateMachineExpr g (overallExpr: Expr) : LoweredStateMachineResult = // Detect a state machine and convert it let stateMachine = IsStateMachineExpr g overallExpr - match stateMachine with + match stateMachine with | None -> LoweredStateMachineResult.NotAStateMachine | Some altExprOpt -> - LowerStateMachine(g).Apply(overallExpr, altExprOpt) + LowerStateMachine(g).Apply(overallExpr, altExprOpt) diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 52e404cea3e..a821e9a0062 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. /// The F# expression simplifier. The main aim is to inline simple, known functions -/// and constant values, and to eliminate non-side-affecting bindings that +/// and constant values, and to eliminate non-side-affecting bindings that /// are never used. module internal FSharp.Compiler.Optimizer @@ -23,7 +23,7 @@ open FSharp.Compiler.Text open FSharp.Compiler.Text.Layout open FSharp.Compiler.Text.LayoutRender open FSharp.Compiler.Text.TaggedText -open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TypedTreeOps.DebugPrint @@ -36,126 +36,145 @@ open System.Collections.ObjectModel let OptimizerStackGuardDepth = GetEnvInteger "FSHARP_Optimizer" 50 -let i_ldlen = [ I_ldlen; (AI_conv DT_I4) ] +let i_ldlen = [ I_ldlen; (AI_conv DT_I4) ] -/// size of a function call -let [] callSize = 1 +/// size of a function call +[] +let callSize = 1 /// size of a for/while loop -let [] forAndWhileLoopSize = 5 +[] +let forAndWhileLoopSize = 5 /// size of a try/with -let [] tryWithSize = 5 +[] +let tryWithSize = 5 /// size of a try/finally -let [] tryFinallySize = 5 +[] +let tryFinallySize = 5 /// Total cost of a closure. Each closure adds a class definition -let [] closureTotalSize = 10 +[] +let closureTotalSize = 10 /// Total cost of a method definition -let [] methodDefnTotalSize = 1 +[] +let methodDefnTotalSize = 1 -type TypeValueInfo = - | UnknownTypeValue +type TypeValueInfo = | UnknownTypeValue /// Partial information about an expression. /// -/// We store one of these for each value in the environment, including values -/// which we know little or nothing about. +/// We store one of these for each value in the environment, including values +/// which we know little or nothing about. type ExprValueInfo = - | UnknownValue + | UnknownValue - /// SizeValue(size, value) - /// - /// Records size info (maxDepth) for an ExprValueInfo - | SizeValue of size: int * ExprValueInfo + /// SizeValue(size, value) + /// + /// Records size info (maxDepth) for an ExprValueInfo + | SizeValue of size: int * ExprValueInfo + + /// ValValue(vref, value) + /// + /// Records that a value is equal to another value, along with additional + /// information. + | ValValue of ValRef * ExprValueInfo - /// ValValue(vref, value) - /// - /// Records that a value is equal to another value, along with additional - /// information. - | ValValue of ValRef * ExprValueInfo + | TupleValue of ExprValueInfo[] - | TupleValue of ExprValueInfo[] - - /// RecdValue(tycon, values) - /// - /// INVARIANT: values are in field definition order . - | RecdValue of TyconRef * ExprValueInfo[] + /// RecdValue(tycon, values) + /// + /// INVARIANT: values are in field definition order . + | RecdValue of TyconRef * ExprValueInfo[] - | UnionCaseValue of UnionCaseRef * ExprValueInfo[] + | UnionCaseValue of UnionCaseRef * ExprValueInfo[] - | ConstValue of Const * TType + | ConstValue of Const * TType - /// CurriedLambdaValue(id, arity, size, lambdaExpression, ty) - /// - /// arities: The number of bunches of untupled args and type args, and - /// the number of args in each bunch. NOTE: This include type arguments. - /// expr: The value, a lambda term. - /// ty: The type of lambda term - | CurriedLambdaValue of id: Unique * arity: int * size: int * lambdaExpr: Expr * lambdaExprTy: TType + /// CurriedLambdaValue(id, arity, size, lambdaExpression, ty) + /// + /// arities: The number of bunches of untupled args and type args, and + /// the number of args in each bunch. NOTE: This include type arguments. + /// expr: The value, a lambda term. + /// ty: The type of lambda term + | CurriedLambdaValue of id: Unique * arity: int * size: int * lambdaExpr: Expr * lambdaExprTy: TType - /// ConstExprValue(size, value) - | ConstExprValue of size: int * value: Expr + /// ConstExprValue(size, value) + | ConstExprValue of size: int * value: Expr type ValInfo = - { ValMakesNoCriticalTailcalls: bool + { + ValMakesNoCriticalTailcalls: bool - ValExprInfo: ExprValueInfo + ValExprInfo: ExprValueInfo } //------------------------------------------------------------------------- // Partial information about entire namespace fragments or modules // -// This is a somewhat nasty data structure since +// This is a somewhat nasty data structure since // (a) we need the lookups to be very efficient // (b) we need to be able to merge these efficiently while building up the overall data for a module // (c) we pickle these to the binary optimization data format -// (d) we don't want the process of unpickling the data structure to +// (d) we don't want the process of unpickling the data structure to // dereference/resolve all the ValRef's in the data structure, since // this would be slow on startup and a potential failure point should // any of the destination values not dereference correctly. // // It doesn't yet feel like we've got this data structure as good as it could be -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- /// Table of the values contained in one module type ValInfos(entries) = - let valInfoTable = - lazy (let t = ValHash.Create () - for vref: ValRef, x in entries do - t.Add (vref.Deref, (vref, x)) - t) + let valInfoTable = + lazy + (let t = ValHash.Create() + + for vref: ValRef, x in entries do + t.Add(vref.Deref, (vref, x)) + + t) - // The compiler's ValRef's in TcGlobals.fs that refer to things in FSharp.Core break certain invariants that hold elsewhere, + // The compiler's ValRef's in TcGlobals.fs that refer to things in FSharp.Core break certain invariants that hold elsewhere, // because they dereference to point to Val's from signatures rather than Val's from implementations. // Thus a backup alternative resolution technique is needed for these when processing the FSharp.Core implementation files // holding these items. This resolution must be able to distinguish between overloaded methods, so we use // XmlDocSigOfVal as a cheap hack to get a unique item of data for a value. - let valInfosForFslib = - LazyWithContext<_, TcGlobals>.Create ((fun g -> - let dict = - Dictionary - (HashIdentity.FromFunctions - (fun (_: ValRef, k: ValLinkageFullKey) -> hash k.PartialKey) - (fun (v1, k1) (v2, k2) -> - k1.PartialKey = k2.PartialKey && - // disambiguate overloads, somewhat low-perf but only use for a handful of overloads in FSharp.Core - match k1.TypeForLinkage, k2.TypeForLinkage with - | Some _, Some _ -> - let sig1 = XmlDocSigOfVal g true "" v1.Deref - let sig2 = XmlDocSigOfVal g true "" v2.Deref - (sig1 = sig2) - | None, None -> true - | _ -> false)) - for vref, _x as p in entries do - let vkey = (vref, vref.Deref.GetLinkageFullKey()) - if dict.ContainsKey vkey then - failwithf "dictionary already contains key %A" vkey - dict.Add(vkey, p) - ReadOnlyDictionary dict), id) + let valInfosForFslib = + LazyWithContext<_, TcGlobals> + .Create( + (fun g -> + let dict = + Dictionary( + HashIdentity.FromFunctions + (fun (_: ValRef, k: ValLinkageFullKey) -> hash k.PartialKey) + (fun (v1, k1) (v2, k2) -> + k1.PartialKey = k2.PartialKey + && + // disambiguate overloads, somewhat low-perf but only use for a handful of overloads in FSharp.Core + match k1.TypeForLinkage, k2.TypeForLinkage with + | Some _, Some _ -> + let sig1 = XmlDocSigOfVal g true "" v1.Deref + let sig2 = XmlDocSigOfVal g true "" v2.Deref + (sig1 = sig2) + | None, None -> true + | _ -> false) + ) + + for vref, _x as p in entries do + let vkey = (vref, vref.Deref.GetLinkageFullKey()) + + if dict.ContainsKey vkey then + failwithf "dictionary already contains key %A" vkey + + dict.Add(vkey, p) + + ReadOnlyDictionary dict), + id + ) member x.Entries = valInfoTable.Force().Values @@ -163,15 +182,17 @@ type ValInfos(entries) = member x.Filter f = ValInfos(Seq.filter f x.Entries) - member x.TryFind (v: ValRef) = valInfoTable.Force().TryFind v.Deref + member x.TryFind(v: ValRef) = valInfoTable.Force().TryFind v.Deref - member x.TryFindForFslib (g, vref: ValRef) = + member x.TryFindForFslib(g, vref: ValRef) = valInfosForFslib.Force(g).TryGetValue((vref, vref.Deref.GetLinkageFullKey())) -type ModuleInfo = - { ValInfos: ValInfos - ModuleOrNamespaceInfos: NameMap } - +type ModuleInfo = + { + ValInfos: ValInfos + ModuleOrNamespaceInfos: NameMap + } + and LazyModuleInfo = InterruptibleLazy type ImplFileOptimizationInfo = LazyModuleInfo @@ -179,216 +200,259 @@ type ImplFileOptimizationInfo = LazyModuleInfo type CcuOptimizationInfo = LazyModuleInfo #if DEBUG -let braceL x = leftL (tagText "{") ^^ x ^^ rightL (tagText "}") -let seqL xL xs = Seq.fold (fun z x -> z @@ xL x) emptyL xs -let namemapL xL xmap = NameMap.foldBack (fun nm x z -> xL nm x @@ z) xmap emptyL +let braceL x = + leftL (tagText "{") ^^ x ^^ rightL (tagText "}") + +let seqL xL xs = + Seq.fold (fun z x -> z @@ xL x) emptyL xs + +let namemapL xL xmap = + NameMap.foldBack (fun nm x z -> xL nm x @@ z) xmap emptyL let rec exprValueInfoL g exprVal = match exprVal with - | ConstValue (x, ty) -> NicePrint.layoutConst g ty x + | ConstValue(x, ty) -> NicePrint.layoutConst g ty x | UnknownValue -> wordL (tagText "?") - | SizeValue (_, vinfo) -> exprValueInfoL g vinfo - | ValValue (vr, vinfo) -> bracketL ((valRefL vr ^^ wordL (tagText "alias")) --- exprValueInfoL g vinfo) + | SizeValue(_, vinfo) -> exprValueInfoL g vinfo + | ValValue(vr, vinfo) -> bracketL ((valRefL vr ^^ wordL (tagText "alias")) --- exprValueInfoL g vinfo) | TupleValue vinfos -> bracketL (exprValueInfosL g vinfos) - | RecdValue (_, vinfos) -> braceL (exprValueInfosL g vinfos) - | UnionCaseValue (ucr, vinfos) -> unionCaseRefL ucr ^^ bracketL (exprValueInfosL g vinfos) - | CurriedLambdaValue(_lambdaId, _arities, _bsize, expr, _ety) -> wordL (tagText "lam") ++ exprL expr (* (sprintf "lam(size=%d)" bsize) *) - | ConstExprValue (_size, x) -> exprL x + | RecdValue(_, vinfos) -> braceL (exprValueInfosL g vinfos) + | UnionCaseValue(ucr, vinfos) -> unionCaseRefL ucr ^^ bracketL (exprValueInfosL g vinfos) + | CurriedLambdaValue(_lambdaId, _arities, _bsize, expr, _ety) -> + wordL (tagText "lam") ++ exprL expr (* (sprintf "lam(size=%d)" bsize) *) + | ConstExprValue(_size, x) -> exprL x -and exprValueInfosL g vinfos = commaListL (List.map (exprValueInfoL g) (Array.toList vinfos)) +and exprValueInfosL g vinfos = + commaListL (List.map (exprValueInfoL g) (Array.toList vinfos)) -and moduleInfoL g (x: LazyModuleInfo) = +and moduleInfoL g (x: LazyModuleInfo) = let x = x.Force() - braceL ((wordL (tagText "Modules: ") @@ (x.ModuleOrNamespaceInfos |> namemapL (fun nm x -> wordL (tagText nm) ^^ moduleInfoL g x) ) ) - @@ (wordL (tagText "Values:") @@ (x.ValInfos.Entries |> seqL (fun (vref, x) -> valRefL vref ^^ valInfoL g x) ))) -and valInfoL g (x: ValInfo) = - braceL ((wordL (tagText "ValExprInfo: ") @@ exprValueInfoL g x.ValExprInfo) - @@ (wordL (tagText "ValMakesNoCriticalTailcalls:") @@ wordL (tagText (if x.ValMakesNoCriticalTailcalls then "true" else "false")))) + braceL ( + (wordL (tagText "Modules: ") + @@ (x.ModuleOrNamespaceInfos + |> namemapL (fun nm x -> wordL (tagText nm) ^^ moduleInfoL g x))) + @@ (wordL (tagText "Values:") + @@ (x.ValInfos.Entries |> seqL (fun (vref, x) -> valRefL vref ^^ valInfoL g x))) + ) + +and valInfoL g (x: ValInfo) = + braceL ( + (wordL (tagText "ValExprInfo: ") @@ exprValueInfoL g x.ValExprInfo) + @@ (wordL (tagText "ValMakesNoCriticalTailcalls:") + @@ wordL (tagText (if x.ValMakesNoCriticalTailcalls then "true" else "false"))) + ) #endif type Summary<'Info> = - { Info: 'Info - - /// What's the contribution to the size of this function? - FunctionSize: int - - /// What's the total contribution to the size of the assembly, including closure classes etc.? - TotalSize: int - - /// Meaning: could mutate, could non-terminate, could raise exception - /// One use: an effect expr cannot be eliminated as dead code (e.g. sequencing) - /// One use: an effect=false expr cannot throw an exception? so try-with is removed. - HasEffect: bool - - /// Indicates that a function may make a useful tailcall, hence when called should itself be tailcalled - MightMakeCriticalTailcall: bool + { + Info: 'Info + + /// What's the contribution to the size of this function? + FunctionSize: int + + /// What's the total contribution to the size of the assembly, including closure classes etc.? + TotalSize: int + + /// Meaning: could mutate, could non-terminate, could raise exception + /// One use: an effect expr cannot be eliminated as dead code (e.g. sequencing) + /// One use: an effect=false expr cannot throw an exception? so try-with is removed. + HasEffect: bool + + /// Indicates that a function may make a useful tailcall, hence when called should itself be tailcalled + MightMakeCriticalTailcall: bool } //------------------------------------------------------------------------- // BoundValueInfoBySize // Note, this is a different notion of "size" to the one used for inlining heuristics -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- let SizeOfValueInfo valueInfo = let rec loop acc valueInfo = match valueInfo with - | SizeValue (vdepth, _v) -> assert (vdepth >= 0); acc + vdepth // terminate recursion at CACHED size nodes + | SizeValue(vdepth, _v) -> + assert (vdepth >= 0) + acc + vdepth // terminate recursion at CACHED size nodes | CurriedLambdaValue _ | ConstExprValue _ | ConstValue _ | UnknownValue -> acc + 1 | TupleValue vinfos - | RecdValue (_, vinfos) - | UnionCaseValue (_, vinfos) when vinfos.Length = 0 -> acc + 1 + | RecdValue(_, vinfos) + | UnionCaseValue(_, vinfos) when vinfos.Length = 0 -> acc + 1 | TupleValue vinfos - | RecdValue (_, vinfos) - | UnionCaseValue (_, vinfos) -> loop (acc + 1) vinfos[0] - | ValValue (_vr, vinfo) -> loop (acc + 1) vinfo + | RecdValue(_, vinfos) + | UnionCaseValue(_, vinfos) -> loop (acc + 1) vinfos[0] + | ValValue(_vr, vinfo) -> loop (acc + 1) vinfo loop 0 valueInfo -let [] minDepthForASizeNode = 5 // for small vinfos do not record size info, save space +[] +let minDepthForASizeNode = 5 // for small vinfos do not record size info, save space let rec MakeValueInfoWithCachedSize vdepth v = match v with | SizeValue(_, v) -> MakeValueInfoWithCachedSize vdepth v - | _ -> if vdepth > minDepthForASizeNode then SizeValue(vdepth, v) else v (* add nodes to stop recursion *) - + | _ -> + if vdepth > minDepthForASizeNode then + SizeValue(vdepth, v) + else + v (* add nodes to stop recursion *) + let MakeSizedValueInfo v = let vdepth = SizeOfValueInfo v MakeValueInfoWithCachedSize vdepth v let BoundValueInfoBySize vinfo = let rec bound depth x = - if depth < 0 then + if depth < 0 then UnknownValue else match x with - | SizeValue (vdepth, vinfo) -> if vdepth < depth then x else MakeSizedValueInfo (bound depth vinfo) - | ValValue (vr, vinfo) -> ValValue (vr, bound (depth-1) vinfo) - | TupleValue vinfos -> TupleValue (Array.map (bound (depth-1)) vinfos) - | RecdValue (tcref, vinfos) -> RecdValue (tcref, Array.map (bound (depth-1)) vinfos) - | UnionCaseValue (ucr, vinfos) -> UnionCaseValue (ucr, Array.map (bound (depth-1)) vinfos) + | SizeValue(vdepth, vinfo) -> + if vdepth < depth then + x + else + MakeSizedValueInfo(bound depth vinfo) + | ValValue(vr, vinfo) -> ValValue(vr, bound (depth - 1) vinfo) + | TupleValue vinfos -> TupleValue(Array.map (bound (depth - 1)) vinfos) + | RecdValue(tcref, vinfos) -> RecdValue(tcref, Array.map (bound (depth - 1)) vinfos) + | UnionCaseValue(ucr, vinfos) -> UnionCaseValue(ucr, Array.map (bound (depth - 1)) vinfos) | ConstValue _ -> x | UnknownValue -> x | CurriedLambdaValue _ -> x - | ConstExprValue (_size, _) -> x + | ConstExprValue(_size, _) -> x + let maxDepth = 6 (* beware huge constants! *) let trimDepth = 3 let vdepth = SizeOfValueInfo vinfo - if vdepth > maxDepth - then MakeSizedValueInfo (bound trimDepth vinfo) - else MakeValueInfoWithCachedSize vdepth vinfo + + if vdepth > maxDepth then + MakeSizedValueInfo(bound trimDepth vinfo) + else + MakeValueInfoWithCachedSize vdepth vinfo //------------------------------------------------------------------------- // Settings and optimizations -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let [] jitOptDefault = true +[] +let jitOptDefault = true -let [] localOptDefault = true +[] +let localOptDefault = true -let [] crossAssemblyOptimizationDefault = true +[] +let crossAssemblyOptimizationDefault = true -let [] debugPointsForPipeRightDefault = true +[] +let debugPointsForPipeRightDefault = true [] type OptimizationProcessingMode = | Sequential | Parallel -type OptimizationSettings = - { - abstractBigTargets : bool - - jitOptUser : bool option - - localOptUser : bool option - - debugPointsForPipeRight: bool option - - crossAssemblyOptimizationUser : bool option - - /// size after which we start chopping methods in two, though only at match targets - bigTargetSize : int - - /// size after which we start enforcing splitting sub-expressions to new methods, to avoid hitting .NET IL limitations - veryBigExprSize : int - - /// The size after which we don't inline - lambdaInlineThreshold : int - - /// For unit testing - reportingPhase : bool - - reportNoNeedToTailcall: bool - - reportFunctionSizes : bool - - reportHasEffect : bool - - reportTotalSizes : bool - - processingMode : OptimizationProcessingMode +type OptimizationSettings = + { + abstractBigTargets: bool + + jitOptUser: bool option + + localOptUser: bool option + + debugPointsForPipeRight: bool option + + crossAssemblyOptimizationUser: bool option + + /// size after which we start chopping methods in two, though only at match targets + bigTargetSize: int + + /// size after which we start enforcing splitting sub-expressions to new methods, to avoid hitting .NET IL limitations + veryBigExprSize: int + + /// The size after which we don't inline + lambdaInlineThreshold: int + + /// For unit testing + reportingPhase: bool + + reportNoNeedToTailcall: bool + + reportFunctionSizes: bool + + reportHasEffect: bool + + reportTotalSizes: bool + + processingMode: OptimizationProcessingMode } - static member Defaults = - { abstractBigTargets = false - jitOptUser = None - localOptUser = None - debugPointsForPipeRight = None - bigTargetSize = 100 - veryBigExprSize = 3000 - crossAssemblyOptimizationUser = None - lambdaInlineThreshold = 6 - reportingPhase = false - reportNoNeedToTailcall = false - reportFunctionSizes = false - reportHasEffect = false - reportTotalSizes = false - processingMode = OptimizationProcessingMode.Sequential + static member Defaults = + { + abstractBigTargets = false + jitOptUser = None + localOptUser = None + debugPointsForPipeRight = None + bigTargetSize = 100 + veryBigExprSize = 3000 + crossAssemblyOptimizationUser = None + lambdaInlineThreshold = 6 + reportingPhase = false + reportNoNeedToTailcall = false + reportFunctionSizes = false + reportHasEffect = false + reportTotalSizes = false + processingMode = OptimizationProcessingMode.Sequential } /// Determines if JIT optimizations are enabled - member x.JitOptimizationsEnabled = match x.jitOptUser with Some f -> f | None -> jitOptDefault + member x.JitOptimizationsEnabled = + match x.jitOptUser with + | Some f -> f + | None -> jitOptDefault /// Determines if intra-assembly optimization is enabled - member x.LocalOptimizationsEnabled = match x.localOptUser with Some f -> f | None -> localOptDefault + member x.LocalOptimizationsEnabled = + match x.localOptUser with + | Some f -> f + | None -> localOptDefault /// Determines if cross-assembly optimization is enabled - member x.crossAssemblyOpt () = - x.LocalOptimizationsEnabled && - x.crossAssemblyOptimizationUser |> Option.defaultValue crossAssemblyOptimizationDefault + member x.crossAssemblyOpt() = + x.LocalOptimizationsEnabled + && x.crossAssemblyOptimizationUser + |> Option.defaultValue crossAssemblyOptimizationDefault /// Determines if we should keep optimization values member x.KeepOptimizationValues = x.crossAssemblyOpt () /// Determines if we should inline calls - member x.InlineLambdas = x.LocalOptimizationsEnabled + member x.InlineLambdas = x.LocalOptimizationsEnabled - /// Determines if we should eliminate unused bindings with no effect - member x.EliminateUnusedBindings = x.LocalOptimizationsEnabled + /// Determines if we should eliminate unused bindings with no effect + member x.EliminateUnusedBindings = x.LocalOptimizationsEnabled /// Determines if we should arrange things so we debug points for pipelines x |> f1 |> f2 /// including locals "", "" and so on. /// On by default for debug code. member x.DebugPointsForPipeRight = - not x.LocalOptimizationsEnabled && - x.debugPointsForPipeRight |> Option.defaultValue debugPointsForPipeRightDefault + not x.LocalOptimizationsEnabled + && x.debugPointsForPipeRight |> Option.defaultValue debugPointsForPipeRightDefault - /// Determines if we should eliminate for-loops around an expr if it has no effect + /// Determines if we should eliminate for-loops around an expr if it has no effect /// /// This optimization is off by default, given tiny overhead of including try/with. See https://github.com/dotnet/fsharp/pull/376 member x.EliminateForLoop = x.LocalOptimizationsEnabled - /// Determines if we should eliminate try/with or try/finally around an expr if it has no effect + /// Determines if we should eliminate try/with or try/finally around an expr if it has no effect /// /// This optimization is off by default, given tiny overhead of including try/with. See https://github.com/dotnet/fsharp/pull/376 - member _.EliminateTryWithAndTryFinally = false + member _.EliminateTryWithAndTryFinally = false - /// Determines if we should eliminate first part of sequential expression if it has no effect - member x.EliminateSequential = x.LocalOptimizationsEnabled + /// Determines if we should eliminate first part of sequential expression if it has no effect + member x.EliminateSequential = x.LocalOptimizationsEnabled /// Determines if we should determine branches in pattern matching based on known information, e.g. /// eliminate a "if true then .. else ... " @@ -401,146 +465,171 @@ type OptimizationSettings = member x.EliminateTupleFieldGet = x.LocalOptimizationsEnabled /// Determines if we should eliminate gets on a union if the value is known to be that union case and the particular field has known info - member x.EliminateUnionCaseFieldGet () = x.LocalOptimizationsEnabled + member x.EliminateUnionCaseFieldGet() = x.LocalOptimizationsEnabled - /// Determines if we should eliminate non-compiler generated immediate bindings + /// Determines if we should eliminate non-compiler generated immediate bindings member x.EliminateImmediatelyConsumedLocals() = x.LocalOptimizationsEnabled - /// Determines if we should expand "let x = (exp1, exp2, ...)" bindings as prior tmps - /// Also if we should expand "let x = Some exp1" bindings as prior tmps + /// Determines if we should expand "let x = (exp1, exp2, ...)" bindings as prior tmps + /// Also if we should expand "let x = Some exp1" bindings as prior tmps member x.ExpandStructuralValues() = x.LocalOptimizationsEnabled - + /// Determines how to process optimization of multiple files and individual optimization phases member x.ProcessingMode() = x.processingMode type cenv = - { g: TcGlobals - - TcVal : ConstraintSolver.TcValF - - amap: Import.ImportMap - - optimizing: bool - - scope: CcuThunk - - localInternalVals: Dictionary - - settings: OptimizationSettings - - emitTailcalls: bool - - /// cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType - casApplied: Dictionary - - stackGuard: StackGuard - - realsig: bool + { + g: TcGlobals + + TcVal: ConstraintSolver.TcValF + + amap: Import.ImportMap + + optimizing: bool + + scope: CcuThunk + + localInternalVals: Dictionary + + settings: OptimizationSettings + + emitTailcalls: bool + + /// cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType + casApplied: Dictionary + + stackGuard: StackGuard + + realsig: bool } override x.ToString() = "" // environment for a method type MethodEnv = - { mutable pipelineCount: int } + { + mutable pipelineCount: int + } override x.ToString() = "" type IncrementalOptimizationEnv = - { /// An identifier to help with name generation - latestBoundId: Ident option + { + /// An identifier to help with name generation + latestBoundId: Ident option - /// The set of lambda IDs we've inlined to reach this point. Helps to prevent recursive inlining - dontInline: Zset + /// The set of lambda IDs we've inlined to reach this point. Helps to prevent recursive inlining + dontInline: Zset - /// Recursively bound vars. If an sub-expression that is a candidate for method splitting - /// contains any of these variables then don't split it, for fear of mucking up tailcalls. - /// See FSharp 1.0 bug 2892 - dontSplitVars: ValMap + /// Recursively bound vars. If an sub-expression that is a candidate for method splitting + /// contains any of these variables then don't split it, for fear of mucking up tailcalls. + /// See FSharp 1.0 bug 2892 + dontSplitVars: ValMap - /// Disable method splitting in loops - disableMethodSplitting: bool + /// Disable method splitting in loops + disableMethodSplitting: bool - /// The Val for the function binding being generated, if any. - functionVal: (Val * ValReprInfo) option + /// The Val for the function binding being generated, if any. + functionVal: (Val * ValReprInfo) option - typarInfos: (Typar * TypeValueInfo) list + typarInfos: (Typar * TypeValueInfo) list - localExternalVals: LayeredMap + localExternalVals: LayeredMap - methEnv: MethodEnv + methEnv: MethodEnv - globalModuleInfos: LayeredMap + globalModuleInfos: LayeredMap } - static member Empty = - { latestBoundId = None - dontInline = Zset.empty Int64.order - typarInfos = [] - functionVal = None - dontSplitVars = ValMap.Empty - disableMethodSplitting = false - localExternalVals = LayeredMap.Empty - globalModuleInfos = LayeredMap.Empty - methEnv = { pipelineCount = 0 } } + static member Empty = + { + latestBoundId = None + dontInline = Zset.empty Int64.order + typarInfos = [] + functionVal = None + dontSplitVars = ValMap.Empty + disableMethodSplitting = false + localExternalVals = LayeredMap.Empty + globalModuleInfos = LayeredMap.Empty + methEnv = { pipelineCount = 0 } + } override x.ToString() = "" //------------------------------------------------------------------------- // IsPartialExprVal - is the expr fully known? -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- /// IsPartialExprVal indicates the cases where we cant rebuild an expression let rec IsPartialExprVal x = match x with | UnknownValue -> true - | TupleValue args | RecdValue (_, args) | UnionCaseValue (_, args) -> Array.exists IsPartialExprVal args - | ConstValue _ | CurriedLambdaValue _ | ConstExprValue _ -> false - | ValValue (_, a) - | SizeValue (_, a) -> IsPartialExprVal a + | TupleValue args + | RecdValue(_, args) + | UnionCaseValue(_, args) -> Array.exists IsPartialExprVal args + | ConstValue _ + | CurriedLambdaValue _ + | ConstExprValue _ -> false + | ValValue(_, a) + | SizeValue(_, a) -> IsPartialExprVal a let CheckInlineValueIsComplete (v: Val) res = if v.ShouldInline && IsPartialExprVal res then - errorR(Error(FSComp.SR.optValueMarkedInlineButIncomplete(v.DisplayName), v.Range)) - //System.Diagnostics.Debug.Assert(false, sprintf "Break for incomplete inline value %s" v.DisplayName) + errorR (Error(FSComp.SR.optValueMarkedInlineButIncomplete (v.DisplayName), v.Range)) +//System.Diagnostics.Debug.Assert(false, sprintf "Break for incomplete inline value %s" v.DisplayName) let check (vref: ValRef) (res: ValInfo) = CheckInlineValueIsComplete vref.Deref res.ValExprInfo (vref, res) //------------------------------------------------------------------------- -// Bind information about values -//------------------------------------------------------------------------- - -let EmptyModuleInfo = - notlazy { ValInfos = ValInfos([]); ModuleOrNamespaceInfos = Map.empty } +// Bind information about values +//------------------------------------------------------------------------- -let rec UnionOptimizationInfos (minfos : seq) = +let EmptyModuleInfo = notlazy - { ValInfos = - ValInfos(seq { for minfo in minfos do yield! minfo.Force().ValInfos.Entries }) + { + ValInfos = ValInfos([]) + ModuleOrNamespaceInfos = Map.empty + } - ModuleOrNamespaceInfos = - minfos - |> Seq.map (fun m -> m.Force().ModuleOrNamespaceInfos) - |> NameMap.union UnionOptimizationInfos } +let rec UnionOptimizationInfos (minfos: seq) = + notlazy + { + ValInfos = + ValInfos( + seq { + for minfo in minfos do + yield! minfo.Force().ValInfos.Entries + } + ) + + ModuleOrNamespaceInfos = + minfos + |> Seq.map (fun m -> m.Force().ModuleOrNamespaceInfos) + |> NameMap.union UnionOptimizationInfos + } -let FindOrCreateModuleInfo n (ss: Map<_, _>) = - match ss.TryFind n with +let FindOrCreateModuleInfo n (ss: Map<_, _>) = + match ss.TryFind n with | Some res -> res | None -> EmptyModuleInfo -let FindOrCreateGlobalModuleInfo n (ss: LayeredMap<_, _>) = - match ss.TryFind n with +let FindOrCreateGlobalModuleInfo n (ss: LayeredMap<_, _>) = + match ss.TryFind n with | Some res -> res | None -> EmptyModuleInfo let rec BindValueInSubModuleFSharpCore (mp: string[]) i (v: Val) vval ss = - if i < mp.Length then - {ss with ModuleOrNamespaceInfos = BindValueInModuleForFslib mp[i] mp (i+1) v vval ss.ModuleOrNamespaceInfos } - else + if i < mp.Length then + { ss with + ModuleOrNamespaceInfos = BindValueInModuleForFslib mp[i] mp (i + 1) v vval ss.ModuleOrNamespaceInfos + } + else // REVIEW: this line looks quadratic for performance when compiling FSharp.Core - {ss with ValInfos = ValInfos(Seq.append ss.ValInfos.Entries (Seq.singleton (mkLocalValRef v, vval))) } + { ss with + ValInfos = ValInfos(Seq.append ss.ValInfos.Entries (Seq.singleton (mkLocalValRef v, vval))) + } and BindValueInModuleForFslib n mp i v vval (ss: NameMap<_>) = let old = FindOrCreateModuleInfo n ss @@ -550,150 +639,190 @@ and BindValueInGlobalModuleForFslib n mp i v vval (ss: LayeredMap<_, _>) = let old = FindOrCreateGlobalModuleInfo n ss ss.Add(n, notlazy (BindValueInSubModuleFSharpCore mp i v vval (old.Force()))) -let BindValueForFslib (nlvref : NonLocalValOrMemberRef) v vval env = - {env with globalModuleInfos = BindValueInGlobalModuleForFslib nlvref.AssemblyName nlvref.EnclosingEntity.nlr.Path 0 v vval env.globalModuleInfos } +let BindValueForFslib (nlvref: NonLocalValOrMemberRef) v vval env = + { env with + globalModuleInfos = + BindValueInGlobalModuleForFslib nlvref.AssemblyName nlvref.EnclosingEntity.nlr.Path 0 v vval env.globalModuleInfos + } -let UnknownValInfo = { ValExprInfo=UnknownValue; ValMakesNoCriticalTailcalls=false } +let UnknownValInfo = + { + ValExprInfo = UnknownValue + ValMakesNoCriticalTailcalls = false + } -let mkValInfo info (v: Val) = { ValExprInfo=info.Info; ValMakesNoCriticalTailcalls= v.MakesNoCriticalTailcalls } +let mkValInfo info (v: Val) = + { + ValExprInfo = info.Info + ValMakesNoCriticalTailcalls = v.MakesNoCriticalTailcalls + } (* Bind a value *) let BindInternalLocalVal cenv (v: Val) vval env = let vval = if v.IsMutable then UnknownValInfo else vval - match vval.ValExprInfo with + match vval.ValExprInfo with | UnknownValue -> env | _ -> cenv.localInternalVals[v.Stamp] <- vval env -let BindExternalLocalVal cenv (v: Val) vval env = +let BindExternalLocalVal cenv (v: Val) vval env = let g = cenv.g - let vval = if v.IsMutable then {vval with ValExprInfo=UnknownValue } else vval + let vval = + if v.IsMutable then + { vval with ValExprInfo = UnknownValue } + else + vval let env = - match vval.ValExprInfo with - | UnknownValue -> env + match vval.ValExprInfo with + | UnknownValue -> env | _ -> - { env with localExternalVals=env.localExternalVals.Add (v.Stamp, vval) } - // If we're compiling fslib then also bind the value as a non-local path to + { env with + localExternalVals = env.localExternalVals.Add(v.Stamp, vval) + } + // If we're compiling fslib then also bind the value as a non-local path to // allow us to resolve the compiler-non-local-references that arise from env.fs // // Do this by generating a fake "looking from the outside in" non-local value reference for // v, dereferencing it to find the corresponding signature Val, and adding an entry for the signature val. // // A similar code path exists in ilxgen.fs for the tables of "representations" for values - let env = - if g.compilingFSharpCore then + let env = + if g.compilingFSharpCore then // Passing an empty remap is sufficient for FSharp.Core.dll because it turns out the remapped type signature can // still be resolved. - match tryRescopeVal g.fslibCcu Remap.Empty v with - | ValueSome vref -> BindValueForFslib vref.nlr v vval env + match tryRescopeVal g.fslibCcu Remap.Empty v with + | ValueSome vref -> BindValueForFslib vref.nlr v vval env | _ -> env - else env + else + env + env let rec BindValsInModuleOrNamespace cenv (mval: LazyModuleInfo) env = let mval = mval.Force() // do all the sub modules - let env = (mval.ModuleOrNamespaceInfos, env) ||> NameMap.foldBackRange (BindValsInModuleOrNamespace cenv) - let env = (env, mval.ValInfos.Entries) ||> Seq.fold (fun env (v: ValRef, vval) -> BindExternalLocalVal cenv v.Deref vval env) + let env = + (mval.ModuleOrNamespaceInfos, env) + ||> NameMap.foldBackRange (BindValsInModuleOrNamespace cenv) + + let env = + (env, mval.ValInfos.Entries) + ||> Seq.fold (fun env (v: ValRef, vval) -> BindExternalLocalVal cenv v.Deref vval env) + env -let inline BindInternalValToUnknown cenv v env = - ignore cenv +let inline BindInternalValToUnknown cenv v env = + ignore cenv ignore v env -let inline BindInternalValsToUnknown cenv vs env = +let inline BindInternalValsToUnknown cenv vs env = ignore cenv ignore vs env -let BindTypar tyv typeinfo env = { env with typarInfos= (tyv, typeinfo) :: env.typarInfos } - -let BindTyparsToUnknown (tps: Typar list) env = - if isNil tps then env else - // The optimizer doesn't use the type values it could track. - // However here we mutate to provide better names for generalized type parameters - // The names chosen are 'a', 'b' etc. These are also the compiled names in the IL code - let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) (env.typarInfos |> List.map (fun (tp, _) -> tp.Name) ) tps - PrettyTypes.AssignPrettyTyparNames tps nms - List.fold (fun sofar arg -> BindTypar arg UnknownTypeValue sofar) env tps +let BindTypar tyv typeinfo env = + { env with + typarInfos = (tyv, typeinfo) :: env.typarInfos + } -let BindCcu (ccu: CcuThunk) mval env (_g: TcGlobals) = - { env with globalModuleInfos=env.globalModuleInfos.Add(ccu.AssemblyName, mval) } +let BindTyparsToUnknown (tps: Typar list) env = + if isNil tps then + env + else + // The optimizer doesn't use the type values it could track. + // However here we mutate to provide better names for generalized type parameters + // The names chosen are 'a', 'b' etc. These are also the compiled names in the IL code + let nms = + PrettyTypes.PrettyTyparNames (fun _ -> true) (env.typarInfos |> List.map (fun (tp, _) -> tp.Name)) tps + + PrettyTypes.AssignPrettyTyparNames tps nms + List.fold (fun sofar arg -> BindTypar arg UnknownTypeValue sofar) env tps + +let BindCcu (ccu: CcuThunk) mval env (_g: TcGlobals) = + { env with + globalModuleInfos = env.globalModuleInfos.Add(ccu.AssemblyName, mval) + } -/// Lookup information about values -let GetInfoForLocalValue cenv env (v: Val) m = - // Abstract slots do not have values - if v.IsDispatchSlot then UnknownValInfo +/// Lookup information about values +let GetInfoForLocalValue cenv env (v: Val) m = + // Abstract slots do not have values + if v.IsDispatchSlot then + UnknownValInfo else match cenv.localInternalVals.TryGetValue v.Stamp with | true, res -> res | _ -> - match env.localExternalVals.TryFind v.Stamp with + match env.localExternalVals.TryFind v.Stamp with | Some vval -> vval - | None -> + | None -> if v.ShouldInline then - errorR(Error(FSComp.SR.optValueMarkedInlineButWasNotBoundInTheOptEnv(fullDisplayTextOfValRef (mkLocalValRef v)), m)) - UnknownValInfo + errorR (Error(FSComp.SR.optValueMarkedInlineButWasNotBoundInTheOptEnv (fullDisplayTextOfValRef (mkLocalValRef v)), m)) -let TryGetInfoForCcu env (ccu: CcuThunk) = env.globalModuleInfos.TryFind(ccu.AssemblyName) + UnknownValInfo -let TryGetInfoForEntity sv n = - match sv.ModuleOrNamespaceInfos.TryFind n with - | Some info -> Some (info.Force()) - | None -> None +let TryGetInfoForCcu env (ccu: CcuThunk) = + env.globalModuleInfos.TryFind(ccu.AssemblyName) -let rec TryGetInfoForPath sv (p:_[]) i = - if i >= p.Length then Some sv else - match TryGetInfoForEntity sv p[i] with - | Some info -> TryGetInfoForPath info p (i+1) +let TryGetInfoForEntity sv n = + match sv.ModuleOrNamespaceInfos.TryFind n with + | Some info -> Some(info.Force()) | None -> None -let TryGetInfoForNonLocalEntityRef env (nleref: NonLocalEntityRef) = - match TryGetInfoForCcu env nleref.Ccu with +let rec TryGetInfoForPath sv (p: _[]) i = + if i >= p.Length then + Some sv + else + match TryGetInfoForEntity sv p[i] with + | Some info -> TryGetInfoForPath info p (i + 1) + | None -> None + +let TryGetInfoForNonLocalEntityRef env (nleref: NonLocalEntityRef) = + match TryGetInfoForCcu env nleref.Ccu with | Some ccuinfo -> TryGetInfoForPath (ccuinfo.Force()) nleref.Path 0 | None -> None - + let GetInfoForNonLocalVal cenv env (vref: ValRef) = let g = cenv.g - if vref.IsDispatchSlot then + if vref.IsDispatchSlot then UnknownValInfo - // REVIEW: optionally turn x-module on/off on per-module basis or - elif cenv.settings.crossAssemblyOpt () || vref.ShouldInline then + // REVIEW: optionally turn x-module on/off on per-module basis or + elif cenv.settings.crossAssemblyOpt () || vref.ShouldInline then match TryGetInfoForNonLocalEntityRef env vref.nlr.EnclosingEntity.nlr with | Some structInfo -> - match structInfo.ValInfos.TryFind vref with + match structInfo.ValInfos.TryFind vref with | Some ninfo -> snd ninfo - | None -> - //dprintn ("\n\n*** Optimization info for value "+n+" from module "+(full_name_of_nlpath smv)+" not found, module contains values: "+String.concat ", " (NameMap.domainL structInfo.ValInfos)) - //System.Diagnostics.Debug.Assert(false, sprintf "Break for module %s, value %s" (full_name_of_nlpath smv) n) - if g.compilingFSharpCore then - match structInfo.ValInfos.TryFindForFslib (g, vref) with - | true, ninfo -> snd ninfo - | _ -> UnknownValInfo - else - UnknownValInfo - | None -> - //dprintf "\n\n*** Optimization info for module %s from ccu %s not found." (full_name_of_nlpath smv) (ccu_of_nlpath smv).AssemblyName + | None -> + //dprintn ("\n\n*** Optimization info for value "+n+" from module "+(full_name_of_nlpath smv)+" not found, module contains values: "+String.concat ", " (NameMap.domainL structInfo.ValInfos)) + //System.Diagnostics.Debug.Assert(false, sprintf "Break for module %s, value %s" (full_name_of_nlpath smv) n) + if g.compilingFSharpCore then + match structInfo.ValInfos.TryFindForFslib(g, vref) with + | true, ninfo -> snd ninfo + | _ -> UnknownValInfo + else + UnknownValInfo + | None -> + //dprintf "\n\n*** Optimization info for module %s from ccu %s not found." (full_name_of_nlpath smv) (ccu_of_nlpath smv).AssemblyName //System.Diagnostics.Debug.Assert(false, sprintf "Break for module %s, ccu %s" (full_name_of_nlpath smv) (ccu_of_nlpath smv).AssemblyName) UnknownValInfo - else + else UnknownValInfo -let GetInfoForVal cenv env m (vref: ValRef) = - let res = +let GetInfoForVal cenv env m (vref: ValRef) = + let res = if vref.IsLocalRef then GetInfoForLocalValue cenv env vref.binding m else GetInfoForNonLocalVal cenv env vref + res -let GetInfoForValWithCheck cenv env m (vref: ValRef) = +let GetInfoForValWithCheck cenv env m (vref: ValRef) = let res = GetInfoForVal cenv env m vref check vref res |> ignore res @@ -701,51 +830,55 @@ let GetInfoForValWithCheck cenv env m (vref: ValRef) = let IsPartialExpr cenv env m x = let rec isPartialExpression x = match x with - | Expr.App (func, _, _, args, _) -> func :: args |> Seq.exists isPartialExpression - | Expr.Lambda (_, _, _, _, expr, _, _) -> expr |> isPartialExpression - | Expr.Let (TBind (_,expr,_), body, _, _) -> expr :: [body] |> List.exists isPartialExpression - | Expr.LetRec (bindings, body, _, _) -> body :: (bindings |> List.map (fun (TBind (_,expr,_)) -> expr)) |> List.exists isPartialExpression - | Expr.Sequential (expr1, expr2, _, _) -> [expr1; expr2] |> Seq.exists isPartialExpression - | Expr.Val (vr, _, _) when not vr.IsLocalRef -> ((GetInfoForVal cenv env m vr).ValExprInfo) |> IsPartialExprVal + | Expr.App(func, _, _, args, _) -> func :: args |> Seq.exists isPartialExpression + | Expr.Lambda(_, _, _, _, expr, _, _) -> expr |> isPartialExpression + | Expr.Let(TBind(_, expr, _), body, _, _) -> expr :: [ body ] |> List.exists isPartialExpression + | Expr.LetRec(bindings, body, _, _) -> + body :: (bindings |> List.map (fun (TBind(_, expr, _)) -> expr)) + |> List.exists isPartialExpression + | Expr.Sequential(expr1, expr2, _, _) -> [ expr1; expr2 ] |> Seq.exists isPartialExpression + | Expr.Val(vr, _, _) when not vr.IsLocalRef -> ((GetInfoForVal cenv env m vr).ValExprInfo) |> IsPartialExprVal | _ -> false + isPartialExpression x //------------------------------------------------------------------------- // Try to get information about values of particular types -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let rec stripValue = function - | ValValue(_, details) -> stripValue details (* step through ValValue "aliases" *) - | SizeValue(_, details) -> stripValue details (* step through SizeValue "aliases" *) - | vinfo -> vinfo +let rec stripValue = + function + | ValValue(_, details) -> stripValue details (* step through ValValue "aliases" *) + | SizeValue(_, details) -> stripValue details (* step through SizeValue "aliases" *) + | vinfo -> vinfo [] -let (|StripConstValue|_|) ev = - match stripValue ev with - | ConstValue(c, _) -> ValueSome c - | _ -> ValueNone +let (|StripConstValue|_|) ev = + match stripValue ev with + | ConstValue(c, _) -> ValueSome c + | _ -> ValueNone [] -let (|StripLambdaValue|_|) ev = - match stripValue ev with - | CurriedLambdaValue (id, arity, sz, expr, ty) -> ValueSome (id, arity, sz, expr, ty) - | _ -> ValueNone +let (|StripLambdaValue|_|) ev = + match stripValue ev with + | CurriedLambdaValue(id, arity, sz, expr, ty) -> ValueSome(id, arity, sz, expr, ty) + | _ -> ValueNone -let destTupleValue ev = - match stripValue ev with - | TupleValue info -> Some info - | _ -> None +let destTupleValue ev = + match stripValue ev with + | TupleValue info -> Some info + | _ -> None -let destRecdValue ev = - match stripValue ev with - | RecdValue (_tcref, info) -> Some info - | _ -> None +let destRecdValue ev = + match stripValue ev with + | RecdValue(_tcref, info) -> Some info + | _ -> None [] -let (|StripUnionCaseValue|_|) ev = - match stripValue ev with - | UnionCaseValue (c, info) -> ValueSome (c, info) - | _ -> ValueNone +let (|StripUnionCaseValue|_|) ev = + match stripValue ev with + | UnionCaseValue(c, info) -> ValueSome(c, info) + | _ -> ValueNone let mkBoolVal (g: TcGlobals) n = ConstValue(Const.Bool n, g.bool_ty) @@ -765,128 +898,173 @@ let mkUInt32Val (g: TcGlobals) n = ConstValue(Const.UInt32 n, g.uint32_ty) let mkUInt64Val (g: TcGlobals) n = ConstValue(Const.UInt64 n, g.uint64_ty) -let MakeValueInfoForValue g m vref vinfo = +let MakeValueInfoForValue g m vref vinfo = #if DEBUG - let rec check x = - match x with - | ValValue (vref2, detail) -> if valRefEq g vref vref2 then error(Error(FSComp.SR.optRecursiveValValue(showL(exprValueInfoL g vinfo)), m)) else check detail - | SizeValue (_n, detail) -> check detail + let rec check x = + match x with + | ValValue(vref2, detail) -> + if valRefEq g vref vref2 then + error (Error(FSComp.SR.optRecursiveValValue (showL (exprValueInfoL g vinfo)), m)) + else + check detail + | SizeValue(_n, detail) -> check detail | _ -> () + check vinfo #else - ignore g; ignore m + ignore g + ignore m #endif - ValValue (vref, vinfo) |> BoundValueInfoBySize + ValValue(vref, vinfo) |> BoundValueInfoBySize -let MakeValueInfoForRecord tcref argvals = - RecdValue (tcref, argvals) |> BoundValueInfoBySize +let MakeValueInfoForRecord tcref argvals = + RecdValue(tcref, argvals) |> BoundValueInfoBySize -let MakeValueInfoForTuple argvals = +let MakeValueInfoForTuple argvals = TupleValue argvals |> BoundValueInfoBySize let MakeValueInfoForUnionCase cspec argvals = - UnionCaseValue (cspec, argvals) |> BoundValueInfoBySize + UnionCaseValue(cspec, argvals) |> BoundValueInfoBySize let MakeValueInfoForConst c ty = ConstValue(c, ty) /// Helper to evaluate a unary integer operation over known values -let inline IntegerUnaryOp g f8 f16 f32 f64 fu8 fu16 fu32 fu64 a = - match a with - | StripConstValue c -> - match c with - | Const.Bool a -> Some(mkBoolVal g (f32 (if a then 1 else 0) <> 0)) - | Const.Int32 a -> Some(mkInt32Val g (f32 a)) - | Const.Int64 a -> Some(mkInt64Val g (f64 a)) - | Const.Int16 a -> Some(mkInt16Val g (f16 a)) - | Const.SByte a -> Some(mkInt8Val g (f8 a)) - | Const.Byte a -> Some(mkUInt8Val g (fu8 a)) - | Const.UInt32 a -> Some(mkUInt32Val g (fu32 a)) - | Const.UInt64 a -> Some(mkUInt64Val g (fu64 a)) - | Const.UInt16 a -> Some(mkUInt16Val g (fu16 a)) - | _ -> None - | _ -> None +let inline IntegerUnaryOp g f8 f16 f32 f64 fu8 fu16 fu32 fu64 a = + match a with + | StripConstValue c -> + match c with + | Const.Bool a -> Some(mkBoolVal g (f32 (if a then 1 else 0) <> 0)) + | Const.Int32 a -> Some(mkInt32Val g (f32 a)) + | Const.Int64 a -> Some(mkInt64Val g (f64 a)) + | Const.Int16 a -> Some(mkInt16Val g (f16 a)) + | Const.SByte a -> Some(mkInt8Val g (f8 a)) + | Const.Byte a -> Some(mkUInt8Val g (fu8 a)) + | Const.UInt32 a -> Some(mkUInt32Val g (fu32 a)) + | Const.UInt64 a -> Some(mkUInt64Val g (fu64 a)) + | Const.UInt16 a -> Some(mkUInt16Val g (fu16 a)) + | _ -> None + | _ -> None /// Helper to evaluate a unary signed integer operation over known values -let inline SignedIntegerUnaryOp g f8 f16 f32 f64 a = - match a with - | StripConstValue c -> - match c with - | Const.Int32 a -> Some(mkInt32Val g (f32 a)) - | Const.Int64 a -> Some(mkInt64Val g (f64 a)) - | Const.Int16 a -> Some(mkInt16Val g (f16 a)) - | Const.SByte a -> Some(mkInt8Val g (f8 a)) - | _ -> None - | _ -> None - +let inline SignedIntegerUnaryOp g f8 f16 f32 f64 a = + match a with + | StripConstValue c -> + match c with + | Const.Int32 a -> Some(mkInt32Val g (f32 a)) + | Const.Int64 a -> Some(mkInt64Val g (f64 a)) + | Const.Int16 a -> Some(mkInt16Val g (f16 a)) + | Const.SByte a -> Some(mkInt8Val g (f8 a)) + | _ -> None + | _ -> None + /// Helper to evaluate a binary integer operation over known values -let inline IntegerBinaryOp g f8 f16 f32 f64 fu8 fu16 fu32 fu64 a b = - match a, b with - | StripConstValue c1, StripConstValue c2 -> - match c1, c2 with - | Const.Bool a, Const.Bool b -> Some(mkBoolVal g (f32 (if a then 1 else 0) (if b then 1 else 0) <> 0)) - | Const.Int32 a, Const.Int32 b -> Some(mkInt32Val g (f32 a b)) - | Const.Int64 a, Const.Int64 b -> Some(mkInt64Val g (f64 a b)) - | Const.Int16 a, Const.Int16 b -> Some(mkInt16Val g (f16 a b)) - | Const.SByte a, Const.SByte b -> Some(mkInt8Val g (f8 a b)) - | Const.Byte a, Const.Byte b -> Some(mkUInt8Val g (fu8 a b)) - | Const.UInt16 a, Const.UInt16 b -> Some(mkUInt16Val g (fu16 a b)) - | Const.UInt32 a, Const.UInt32 b -> Some(mkUInt32Val g (fu32 a b)) - | Const.UInt64 a, Const.UInt64 b -> Some(mkUInt64Val g (fu64 a b)) - | _ -> None - | _ -> None +let inline IntegerBinaryOp g f8 f16 f32 f64 fu8 fu16 fu32 fu64 a b = + match a, b with + | StripConstValue c1, StripConstValue c2 -> + match c1, c2 with + | Const.Bool a, Const.Bool b -> Some(mkBoolVal g (f32 (if a then 1 else 0) (if b then 1 else 0) <> 0)) + | Const.Int32 a, Const.Int32 b -> Some(mkInt32Val g (f32 a b)) + | Const.Int64 a, Const.Int64 b -> Some(mkInt64Val g (f64 a b)) + | Const.Int16 a, Const.Int16 b -> Some(mkInt16Val g (f16 a b)) + | Const.SByte a, Const.SByte b -> Some(mkInt8Val g (f8 a b)) + | Const.Byte a, Const.Byte b -> Some(mkUInt8Val g (fu8 a b)) + | Const.UInt16 a, Const.UInt16 b -> Some(mkUInt16Val g (fu16 a b)) + | Const.UInt32 a, Const.UInt32 b -> Some(mkUInt32Val g (fu32 a b)) + | Const.UInt64 a, Const.UInt64 b -> Some(mkUInt64Val g (fu64 a b)) + | _ -> None + | _ -> None module Unchecked = Microsoft.FSharp.Core.Operators - -/// Evaluate primitives based on interpretation of IL instructions. + +/// Evaluate primitives based on interpretation of IL instructions. /// -/// The implementation utilizes F# arithmetic extensively, so a mistake in the implementation of F# arithmetic -/// in the core library used by the F# compiler will propagate to be a mistake in optimization. +/// The implementation utilizes F# arithmetic extensively, so a mistake in the implementation of F# arithmetic +/// in the core library used by the F# compiler will propagate to be a mistake in optimization. /// The IL instructions appear in the tree through inlining. let mkAssemblyCodeValueInfo g instrs argvals tys = match instrs, argvals, tys with - | [ AI_add ], [t1;t2], _ -> + | [ AI_add ], [ t1; t2 ], _ -> // Note: each use of Unchecked.(+) gets instantiated at a different type and inlined - match IntegerBinaryOp g Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) t1 t2 with + match + IntegerBinaryOp + g + Unchecked.(+) + Unchecked.(+) + Unchecked.(+) + Unchecked.(+) + Unchecked.(+) + Unchecked.(+) + Unchecked.(+) + Unchecked.(+) + t1 + t2 + with | Some res -> res | _ -> UnknownValue - | [ AI_sub ], [t1;t2], _ -> - // Note: each use of Unchecked.(+) gets instantiated at a different type and inlined - match IntegerBinaryOp g Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) t1 t2 with - | Some res -> res - | _ -> UnknownValue + | [ AI_sub ], [ t1; t2 ], _ -> + // Note: each use of Unchecked.(+) gets instantiated at a different type and inlined + match + IntegerBinaryOp + g + Unchecked.(-) + Unchecked.(-) + Unchecked.(-) + Unchecked.(-) + Unchecked.(-) + Unchecked.(-) + Unchecked.(-) + Unchecked.(-) + t1 + t2 + with + | Some res -> res + | _ -> UnknownValue - | [ AI_mul ], [a;b], _ -> - match IntegerBinaryOp g Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) a b with + | [ AI_mul ], [ a; b ], _ -> + match + IntegerBinaryOp + g + Unchecked.(*) + Unchecked.(*) + Unchecked.(*) + Unchecked.(*) + Unchecked.(*) + Unchecked.(*) + Unchecked.(*) + Unchecked.(*) + a + b + with | Some res -> res | None -> UnknownValue - | [ AI_and ], [a;b], _ -> + | [ AI_and ], [ a; b ], _ -> match IntegerBinaryOp g (&&&) (&&&) (&&&) (&&&) (&&&) (&&&) (&&&) (&&&) a b with | Some res -> res | None -> UnknownValue - | [ AI_or ], [a;b], _ -> + | [ AI_or ], [ a; b ], _ -> match IntegerBinaryOp g (|||) (|||) (|||) (|||) (|||) (|||) (|||) (|||) a b with | Some res -> res | None -> UnknownValue - | [ AI_xor ], [a;b], _ -> + | [ AI_xor ], [ a; b ], _ -> match IntegerBinaryOp g (^^^) (^^^) (^^^) (^^^) (^^^) (^^^) (^^^) (^^^) a b with | Some res -> res | None -> UnknownValue - | [ AI_not ], [a], _ -> + | [ AI_not ], [ a ], _ -> match IntegerUnaryOp g (~~~) (~~~) (~~~) (~~~) (~~~) (~~~) (~~~) (~~~) a with | Some res -> res | None -> UnknownValue - | [ AI_neg ], [a], _ -> + | [ AI_neg ], [ a ], _ -> match SignedIntegerUnaryOp g (~-) (~-) (~-) (~-) a with | Some res -> res | None -> UnknownValue - | [ AI_ceq ], [a;b], _ -> + | [ AI_ceq ], [ a; b ], _ -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkBoolVal g (a1 = a2) | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkBoolVal g (a1 = a2) @@ -900,7 +1078,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkBoolVal g (a1 = a2) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.bool_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.bool_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkBoolVal g (a1 < a2) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkBoolVal g (a1 < a2) @@ -908,7 +1086,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkBoolVal g (a1 < a2) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkBoolVal g (a1 < a2) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.int32_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.int32_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) @@ -916,7 +1094,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.uint32_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.uint32_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) @@ -924,7 +1102,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.int16_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.int16_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) @@ -932,32 +1110,32 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.uint16_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.uint16_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) - | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) - | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) - | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) - | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) + | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) + | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) + | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) + | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.sbyte_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.sbyte_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) - | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) - | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) - | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) - | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) + | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) + | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) + | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) + | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) | _ -> UnknownValue - | [ AI_clt ], [a;b], [ty] when typeEquiv g ty g.byte_ty -> + | [ AI_clt ], [ a; b ], [ ty ] when typeEquiv g ty g.byte_ty -> match stripValue a, stripValue b with | ConstValue(Const.Bool a1, _), ConstValue(Const.Bool a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) - | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) - | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) - | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) - | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) + | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) + | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) + | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) + | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) | _ -> UnknownValue - | [ AI_conv DT_U1 ], [a], [ty] when typeEquiv g ty g.byte_ty -> + | [ AI_conv DT_U1 ], [ a ], [ ty ] when typeEquiv g ty g.byte_ty -> match stripValue a with | ConstValue(Const.SByte a, _) -> mkUInt8Val g (Unchecked.byte a) | ConstValue(Const.Int16 a, _) -> mkUInt8Val g (Unchecked.byte a) @@ -969,7 +1147,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkUInt8Val g (Unchecked.byte a) | _ -> UnknownValue - | [ AI_conv DT_U2 ], [a], [ty] when typeEquiv g ty g.uint16_ty -> + | [ AI_conv DT_U2 ], [ a ], [ ty ] when typeEquiv g ty g.uint16_ty -> match stripValue a with | ConstValue(Const.SByte a, _) -> mkUInt16Val g (Unchecked.uint16 a) | ConstValue(Const.Int16 a, _) -> mkUInt16Val g (Unchecked.uint16 a) @@ -981,7 +1159,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkUInt16Val g (Unchecked.uint16 a) | _ -> UnknownValue - | [ AI_conv DT_U4 ], [a], [ty] when typeEquiv g ty g.uint32_ty -> + | [ AI_conv DT_U4 ], [ a ], [ ty ] when typeEquiv g ty g.uint32_ty -> match stripValue a with | ConstValue(Const.SByte a, _) -> mkUInt32Val g (Unchecked.uint32 a) | ConstValue(Const.Int16 a, _) -> mkUInt32Val g (Unchecked.uint32 a) @@ -993,7 +1171,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkUInt32Val g (Unchecked.uint32 a) | _ -> UnknownValue - | [ AI_conv DT_U8 ], [a], [ty] when typeEquiv g ty g.uint64_ty -> + | [ AI_conv DT_U8 ], [ a ], [ ty ] when typeEquiv g ty g.uint64_ty -> match stripValue a with | ConstValue(Const.SByte a, _) -> mkUInt64Val g (Unchecked.uint64 a) | ConstValue(Const.Int16 a, _) -> mkUInt64Val g (Unchecked.uint64 a) @@ -1005,7 +1183,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkUInt64Val g (Unchecked.uint64 a) | _ -> UnknownValue - | [ AI_conv DT_I1 ], [a], [ty] when typeEquiv g ty g.sbyte_ty -> + | [ AI_conv DT_I1 ], [ a ], [ ty ] when typeEquiv g ty g.sbyte_ty -> match stripValue a with | ConstValue(Const.SByte a, _) -> mkInt8Val g (Unchecked.sbyte a) | ConstValue(Const.Int16 a, _) -> mkInt8Val g (Unchecked.sbyte a) @@ -1017,7 +1195,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkInt8Val g (Unchecked.sbyte a) | _ -> UnknownValue - | [ AI_conv DT_I2 ], [a], [ty] when typeEquiv g ty g.int16_ty -> + | [ AI_conv DT_I2 ], [ a ], [ ty ] when typeEquiv g ty g.int16_ty -> match stripValue a with | ConstValue(Const.Int32 a, _) -> mkInt16Val g (Unchecked.int16 a) | ConstValue(Const.Int16 a, _) -> mkInt16Val g (Unchecked.int16 a) @@ -1029,7 +1207,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkInt16Val g (Unchecked.int16 a) | _ -> UnknownValue - | [ AI_conv DT_I4 ], [a], [ty] when typeEquiv g ty g.int32_ty -> + | [ AI_conv DT_I4 ], [ a ], [ ty ] when typeEquiv g ty g.int32_ty -> match stripValue a with | ConstValue(Const.Int32 a, _) -> mkInt32Val g (Unchecked.int32 a) | ConstValue(Const.Int16 a, _) -> mkInt32Val g (Unchecked.int32 a) @@ -1041,7 +1219,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkInt32Val g (Unchecked.int32 a) | _ -> UnknownValue - | [ AI_conv DT_I8 ], [a], [ty] when typeEquiv g ty g.int64_ty -> + | [ AI_conv DT_I8 ], [ a ], [ ty ] when typeEquiv g ty g.int64_ty -> match stripValue a with | ConstValue(Const.Int32 a, _) -> mkInt64Val g (Unchecked.int64 a) | ConstValue(Const.Int16 a, _) -> mkInt64Val g (Unchecked.int64 a) @@ -1053,7 +1231,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a, _) -> mkInt64Val g (Unchecked.int64 a) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.bool_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.bool_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkBoolVal g (a1 < a2) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkBoolVal g (a1 < a2) @@ -1061,7 +1239,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkBoolVal g (a1 < a2) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkBoolVal g (a1 < a2) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.int32_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.int32_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) @@ -1069,7 +1247,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkInt32Val g (if a1 < a2 then 1 else 0) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.uint32_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.uint32_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) @@ -1077,7 +1255,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkUInt32Val g (if a1 < a2 then 1u else 0u) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.int16_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.int16_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) @@ -1085,7 +1263,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkInt16Val g (if a1 < a2 then 1s else 0s) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.uint16_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.uint16_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) @@ -1093,7 +1271,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkUInt16Val g (if a1 < a2 then 1us else 0us) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.sbyte_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.sbyte_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) @@ -1101,7 +1279,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkInt8Val g (if a1 < a2 then 1y else 0y) | _ -> UnknownValue - | [ AI_clt_un ], [a;b], [ty] when typeEquiv g ty g.byte_ty -> + | [ AI_clt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.byte_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) @@ -1110,50 +1288,49 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkUInt8Val g (if a1 < a2 then 1uy else 0uy) | _ -> UnknownValue - - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.bool_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.bool_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkBoolVal g (a1 > a2) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkBoolVal g (a1 > a2) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkBoolVal g (a1 > a2) | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkBoolVal g (a1 > a2) | _ -> UnknownValue - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.int32_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.int32_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | _ -> UnknownValue - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.uint32_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.uint32_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | _ -> UnknownValue - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.int16_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.int16_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | _ -> UnknownValue - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.uint16_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.uint16_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | _ -> UnknownValue - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.sbyte_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.sbyte_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | ConstValue(Const.Int32 a1, _), ConstValue(Const.Int32 a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | _ -> UnknownValue - | [ AI_cgt ], [a;b], [ty] when typeEquiv g ty g.byte_ty -> + | [ AI_cgt ], [ a; b ], [ ty ] when typeEquiv g ty g.byte_ty -> match stripValue a, stripValue b with | ConstValue(Const.SByte a1, _), ConstValue(Const.SByte a2, _) -> mkUInt8Val g (if a1 > a2 then 1uy else 0uy) | ConstValue(Const.Int16 a1, _), ConstValue(Const.Int16 a2, _) -> mkUInt8Val g (if a1 > a2 then 1uy else 0uy) @@ -1161,7 +1338,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.Int64 a1, _), ConstValue(Const.Int64 a2, _) -> mkUInt8Val g (if a1 > a2 then 1uy else 0uy) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.bool_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.bool_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkBoolVal g (a1 > a2) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkBoolVal g (a1 > a2) @@ -1169,7 +1346,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkBoolVal g (a1 > a2) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkBoolVal g (a1 > a2) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.int32_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.int32_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) @@ -1177,7 +1354,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkInt32Val g (if a1 > a2 then 1 else 0) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.uint32_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.uint32_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) @@ -1185,7 +1362,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkUInt32Val g (if a1 > a2 then 1u else 0u) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.int16_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.int16_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) @@ -1193,7 +1370,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkInt16Val g (if a1 > a2 then 1s else 0s) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.uint16_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.uint16_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) @@ -1201,7 +1378,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkUInt16Val g (if a1 > a2 then 1us else 0us) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.sbyte_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.sbyte_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) @@ -1209,7 +1386,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt32 a1, _), ConstValue(Const.UInt32 a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkInt8Val g (if a1 > a2 then 1y else 0y) | _ -> UnknownValue - | [ AI_cgt_un ], [a;b], [ty] when typeEquiv g ty g.byte_ty -> + | [ AI_cgt_un ], [ a; b ], [ ty ] when typeEquiv g ty g.byte_ty -> match stripValue a, stripValue b with | ConstValue(Const.Char a1, _), ConstValue(Const.Char a2, _) -> mkUInt8Val g (if a1 > a2 then 1uy else 0uy) | ConstValue(Const.Byte a1, _), ConstValue(Const.Byte a2, _) -> mkUInt8Val g (if a1 > a2 then 1uy else 0uy) @@ -1218,8 +1395,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.UInt64 a1, _), ConstValue(Const.UInt64 a2, _) -> mkUInt8Val g (if a1 > a2 then 1uy else 0uy) | _ -> UnknownValue - - | [ AI_shl ], [a;n], _ -> + | [ AI_shl ], [ a; n ], _ -> match stripValue a, stripValue n with | ConstValue(Const.Int64 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 63 -> mkInt64Val g (a <<< n) | ConstValue(Const.Int32 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 31 -> mkInt32Val g (a <<< n) @@ -1231,7 +1407,7 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.Byte a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 7 -> mkUInt8Val g (a <<< n) | _ -> UnknownValue - | [ AI_shr ], [a;n], _ -> + | [ AI_shr ], [ a; n ], _ -> match stripValue a, stripValue n with | ConstValue(Const.SByte a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 7 -> mkInt8Val g (a >>> n) | ConstValue(Const.Int16 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 15 -> mkInt16Val g (a >>> n) @@ -1239,92 +1415,131 @@ let mkAssemblyCodeValueInfo g instrs argvals tys = | ConstValue(Const.Int64 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 63 -> mkInt64Val g (a >>> n) | _ -> UnknownValue - | [ AI_shr_un ], [a;n], _ -> + | [ AI_shr_un ], [ a; n ], _ -> match stripValue a, stripValue n with | ConstValue(Const.Byte a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 7 -> mkUInt8Val g (a >>> n) | ConstValue(Const.UInt16 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 15 -> mkUInt16Val g (a >>> n) | ConstValue(Const.UInt32 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 31 -> mkUInt32Val g (a >>> n) | ConstValue(Const.UInt64 a, _), ConstValue(Const.Int32 n, _) when n >= 0 && n <= 63 -> mkUInt64Val g (a >>> n) | _ -> UnknownValue - + // Retypings using IL asm "" are quite common in prim-types.fs // Sometimes these are only to get the primitives to pass the type checker. // Here we check for retypings from know values to known types. // We're conservative not to apply any actual data-changing conversions here. - | [ ], [v], [ty] -> + | [], [ v ], [ ty ] -> match stripValue v with | ConstValue(Const.Bool a, _) -> - if typeEquiv g ty g.bool_ty then v - elif typeEquiv g ty g.sbyte_ty then mkInt8Val g (if a then 1y else 0y) - elif typeEquiv g ty g.int16_ty then mkInt16Val g (if a then 1s else 0s) - elif typeEquiv g ty g.int32_ty then mkInt32Val g (if a then 1 else 0) - elif typeEquiv g ty g.byte_ty then mkUInt8Val g (if a then 1uy else 0uy) - elif typeEquiv g ty g.uint16_ty then mkUInt16Val g (if a then 1us else 0us) - elif typeEquiv g ty g.uint32_ty then mkUInt32Val g (if a then 1u else 0u) - else UnknownValue - | ConstValue(Const.SByte a, _) -> - if typeEquiv g ty g.sbyte_ty then v - elif typeEquiv g ty g.int16_ty then mkInt16Val g (Unchecked.int16 a) - elif typeEquiv g ty g.int32_ty then mkInt32Val g (Unchecked.int32 a) - else UnknownValue - | ConstValue(Const.Byte a, _) -> - if typeEquiv g ty g.byte_ty then v - elif typeEquiv g ty g.uint16_ty then mkUInt16Val g (Unchecked.uint16 a) - elif typeEquiv g ty g.uint32_ty then mkUInt32Val g (Unchecked.uint32 a) - else UnknownValue - | ConstValue(Const.Int16 a, _) -> - if typeEquiv g ty g.int16_ty then v - elif typeEquiv g ty g.int32_ty then mkInt32Val g (Unchecked.int32 a) - else UnknownValue - | ConstValue(Const.UInt16 a, _) -> - if typeEquiv g ty g.uint16_ty then v - elif typeEquiv g ty g.uint32_ty then mkUInt32Val g (Unchecked.uint32 a) - else UnknownValue - | ConstValue(Const.Int32 a, _) -> - if typeEquiv g ty g.int32_ty then v - elif typeEquiv g ty g.uint32_ty then mkUInt32Val g (Unchecked.uint32 a) - else UnknownValue - | ConstValue(Const.UInt32 a, _) -> - if typeEquiv g ty g.uint32_ty then v - elif typeEquiv g ty g.int32_ty then mkInt32Val g (Unchecked.int32 a) - else UnknownValue - | ConstValue(Const.Int64 a, _) -> - if typeEquiv g ty g.int64_ty then v - elif typeEquiv g ty g.uint64_ty then mkUInt64Val g (Unchecked.uint64 a) - else UnknownValue - | ConstValue(Const.UInt64 a, _) -> - if typeEquiv g ty g.uint64_ty then v - elif typeEquiv g ty g.int64_ty then mkInt64Val g (Unchecked.int64 a) - else UnknownValue - | _ -> UnknownValue + if typeEquiv g ty g.bool_ty then + v + elif typeEquiv g ty g.sbyte_ty then + mkInt8Val g (if a then 1y else 0y) + elif typeEquiv g ty g.int16_ty then + mkInt16Val g (if a then 1s else 0s) + elif typeEquiv g ty g.int32_ty then + mkInt32Val g (if a then 1 else 0) + elif typeEquiv g ty g.byte_ty then + mkUInt8Val g (if a then 1uy else 0uy) + elif typeEquiv g ty g.uint16_ty then + mkUInt16Val g (if a then 1us else 0us) + elif typeEquiv g ty g.uint32_ty then + mkUInt32Val g (if a then 1u else 0u) + else + UnknownValue + | ConstValue(Const.SByte a, _) -> + if typeEquiv g ty g.sbyte_ty then + v + elif typeEquiv g ty g.int16_ty then + mkInt16Val g (Unchecked.int16 a) + elif typeEquiv g ty g.int32_ty then + mkInt32Val g (Unchecked.int32 a) + else + UnknownValue + | ConstValue(Const.Byte a, _) -> + if typeEquiv g ty g.byte_ty then + v + elif typeEquiv g ty g.uint16_ty then + mkUInt16Val g (Unchecked.uint16 a) + elif typeEquiv g ty g.uint32_ty then + mkUInt32Val g (Unchecked.uint32 a) + else + UnknownValue + | ConstValue(Const.Int16 a, _) -> + if typeEquiv g ty g.int16_ty then + v + elif typeEquiv g ty g.int32_ty then + mkInt32Val g (Unchecked.int32 a) + else + UnknownValue + | ConstValue(Const.UInt16 a, _) -> + if typeEquiv g ty g.uint16_ty then + v + elif typeEquiv g ty g.uint32_ty then + mkUInt32Val g (Unchecked.uint32 a) + else + UnknownValue + | ConstValue(Const.Int32 a, _) -> + if typeEquiv g ty g.int32_ty then + v + elif typeEquiv g ty g.uint32_ty then + mkUInt32Val g (Unchecked.uint32 a) + else + UnknownValue + | ConstValue(Const.UInt32 a, _) -> + if typeEquiv g ty g.uint32_ty then + v + elif typeEquiv g ty g.int32_ty then + mkInt32Val g (Unchecked.int32 a) + else + UnknownValue + | ConstValue(Const.Int64 a, _) -> + if typeEquiv g ty g.int64_ty then + v + elif typeEquiv g ty g.uint64_ty then + mkUInt64Val g (Unchecked.uint64 a) + else + UnknownValue + | ConstValue(Const.UInt64 a, _) -> + if typeEquiv g ty g.uint64_ty then + v + elif typeEquiv g ty g.int64_ty then + mkInt64Val g (Unchecked.int64 a) + else + UnknownValue + | _ -> UnknownValue | _ -> UnknownValue //------------------------------------------------------------------------- // Size constants and combinators -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let [] localVarSize = 1 +[] +let localVarSize = 1 -let AddTotalSizes l = l |> List.sumBy (fun x -> x.TotalSize) +let AddTotalSizes l = l |> List.sumBy (fun x -> x.TotalSize) -let AddFunctionSizes l = l |> List.sumBy (fun x -> x.FunctionSize) +let AddFunctionSizes l = + l |> List.sumBy (fun x -> x.FunctionSize) /// list/array combinators - zipping (_, _) return type let OrEffects l = List.exists (fun x -> x.HasEffect) l -let OrTailcalls l = List.exists (fun x -> x.MightMakeCriticalTailcall) l - -let OptimizeList f l = l |> List.map f |> List.unzip +let OrTailcalls l = + List.exists (fun x -> x.MightMakeCriticalTailcall) l -let NoExprs : Expr list * Summary list = [], [] +let OptimizeList f l = l |> List.map f |> List.unzip + +let NoExprs: Expr list * Summary list = [], [] /// Common ways of building new value infos -let CombineValueInfos einfos res = - { TotalSize = AddTotalSizes einfos - FunctionSize = AddFunctionSizes einfos - HasEffect = OrEffects einfos - MightMakeCriticalTailcall = OrTailcalls einfos - Info = res } +let CombineValueInfos einfos res = + { + TotalSize = AddTotalSizes einfos + FunctionSize = AddFunctionSizes einfos + HasEffect = OrEffects einfos + MightMakeCriticalTailcall = OrTailcalls einfos + Info = res + } let CombineValueInfosUnknown einfos = CombineValueInfos einfos UnknownValue @@ -1334,80 +1549,103 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = // The freevars and FreeTyvars can indicate if the non-public (hidden) items have been used. // Under those checks, the further hidden* checks may be subsumed (meaning, not required anymore). - let hiddenTycon, hiddenTyconRepr, hiddenVal, hiddenRecdField, hiddenUnionCase = - Zset.memberOf mhi.HiddenTycons, - Zset.memberOf mhi.HiddenTyconReprs, - Zset.memberOf mhi.HiddenVals, - Zset.memberOf mhi.HiddenRecdFields, + let hiddenTycon, hiddenTyconRepr, hiddenVal, hiddenRecdField, hiddenUnionCase = + Zset.memberOf mhi.HiddenTycons, + Zset.memberOf mhi.HiddenTyconReprs, + Zset.memberOf mhi.HiddenVals, + Zset.memberOf mhi.HiddenRecdFields, Zset.memberOf mhi.HiddenUnionCases - let rec abstractExprInfo ivalue = - match ivalue with + let rec abstractExprInfo ivalue = + match ivalue with // Check for escaping value. Revert to old info if possible - | ValValue (vref2, detail) -> - let detailR = abstractExprInfo detail - let v2 = vref2.Deref - let tyvars = freeInVal CollectAll v2 - if - (isAssemblyBoundary && not (freeTyvarsAllPublic tyvars)) || - Zset.exists hiddenTycon tyvars.FreeTycons || - hiddenVal v2 - then detailR - else ValValue (vref2, detailR) - - // Check for escape in lambda - | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when + | ValValue(vref2, detail) -> + let detailR = abstractExprInfo detail + let v2 = vref2.Deref + let tyvars = freeInVal CollectAll v2 + + if + (isAssemblyBoundary && not (freeTyvarsAllPublic tyvars)) + || Zset.exists hiddenTycon tyvars.FreeTycons + || hiddenVal v2 + then + detailR + else + ValValue(vref2, detailR) + + // Check for escape in lambda + | CurriedLambdaValue(_, _, _, expr, _) + | ConstExprValue(_, expr) when (let fvs = freeInExpr CollectAll expr - (isAssemblyBoundary && not (freeVarsAllPublic fvs)) || - Zset.exists hiddenVal fvs.FreeLocals || - Zset.exists hiddenTycon fvs.FreeTyvars.FreeTycons || - Zset.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || - Zset.exists hiddenRecdField fvs.FreeRecdFields || - Zset.exists hiddenUnionCase fvs.FreeUnionCases ) -> - UnknownValue - // Check for escape in constant - | ConstValue(_, ty) when + (isAssemblyBoundary && not (freeVarsAllPublic fvs)) + || Zset.exists hiddenVal fvs.FreeLocals + || Zset.exists hiddenTycon fvs.FreeTyvars.FreeTycons + || Zset.exists hiddenTyconRepr fvs.FreeLocalTyconReprs + || Zset.exists hiddenRecdField fvs.FreeRecdFields + || Zset.exists hiddenUnionCase fvs.FreeUnionCases) + -> + UnknownValue + + // Check for escape in constant + | ConstValue(_, ty) when (let ftyvs = freeInType CollectAll ty - (isAssemblyBoundary && not (freeTyvarsAllPublic ftyvs)) || - Zset.exists hiddenTycon ftyvs.FreeTycons) -> - UnknownValue - | TupleValue vinfos -> - TupleValue (Array.map abstractExprInfo vinfos) + (isAssemblyBoundary && not (freeTyvarsAllPublic ftyvs)) + || Zset.exists hiddenTycon ftyvs.FreeTycons) + -> + UnknownValue + + | TupleValue vinfos -> TupleValue(Array.map abstractExprInfo vinfos) - | RecdValue (tcref, vinfos) -> - if hiddenTyconRepr tcref.Deref || Array.exists (tcref.MakeNestedRecdFieldRef >> hiddenRecdField) tcref.AllFieldsArray - then UnknownValue - else RecdValue (tcref, Array.map abstractExprInfo vinfos) + | RecdValue(tcref, vinfos) -> + if + hiddenTyconRepr tcref.Deref + || Array.exists (tcref.MakeNestedRecdFieldRef >> hiddenRecdField) tcref.AllFieldsArray + then + UnknownValue + else + RecdValue(tcref, Array.map abstractExprInfo vinfos) - | UnionCaseValue(ucref, vinfos) -> + | UnionCaseValue(ucref, vinfos) -> let tcref = ucref.TyconRef - if hiddenTyconRepr ucref.Tycon || tcref.UnionCasesArray |> Array.exists (tcref.MakeNestedUnionCaseRef >> hiddenUnionCase) - then UnknownValue - else UnionCaseValue (ucref, Array.map abstractExprInfo vinfos) - | SizeValue(_vdepth, vinfo) -> - MakeSizedValueInfo (abstractExprInfo vinfo) + if + hiddenTyconRepr ucref.Tycon + || tcref.UnionCasesArray + |> Array.exists (tcref.MakeNestedUnionCaseRef >> hiddenUnionCase) + then + UnknownValue + else + UnionCaseValue(ucref, Array.map abstractExprInfo vinfos) - | UnknownValue - | ConstExprValue _ - | CurriedLambdaValue _ + | SizeValue(_vdepth, vinfo) -> MakeSizedValueInfo(abstractExprInfo vinfo) + + | UnknownValue + | ConstExprValue _ + | CurriedLambdaValue _ | ConstValue _ -> ivalue - and abstractValInfo v = - { ValExprInfo=abstractExprInfo v.ValExprInfo - ValMakesNoCriticalTailcalls=v.ValMakesNoCriticalTailcalls } + and abstractValInfo v = + { + ValExprInfo = abstractExprInfo v.ValExprInfo + ValMakesNoCriticalTailcalls = v.ValMakesNoCriticalTailcalls + } and abstractModulInfo ss = - { ModuleOrNamespaceInfos = NameMap.map abstractLazyModulInfo ss.ModuleOrNamespaceInfos - ValInfos = - ValInfos(ss.ValInfos.Entries - |> Seq.filter (fun (vref, _) -> not (hiddenVal vref.Deref)) - |> Seq.map (fun (vref, e) -> check (* "its implementation uses a binding hidden by a signature" m *) vref (abstractValInfo e) )) } + { + ModuleOrNamespaceInfos = NameMap.map abstractLazyModulInfo ss.ModuleOrNamespaceInfos + ValInfos = + ValInfos( + ss.ValInfos.Entries + |> Seq.filter (fun (vref, _) -> not (hiddenVal vref.Deref)) + |> Seq.map (fun (vref, e) -> + check (* "its implementation uses a binding hidden by a signature" m *) vref (abstractValInfo e)) + ) + } - and abstractLazyModulInfo (ss: LazyModuleInfo) = - ss.Force() |> abstractModulInfo |> notlazy + and abstractLazyModulInfo (ss: LazyModuleInfo) = + ss.Force() |> abstractModulInfo |> notlazy abstractLazyModulInfo @@ -1415,111 +1653,138 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = let AbstractOptimizationInfoToEssentials = let rec abstractModulInfo (ss: ModuleInfo) = - { ModuleOrNamespaceInfos = NameMap.map (InterruptibleLazy.force >> abstractModulInfo >> notlazy) ss.ModuleOrNamespaceInfos - ValInfos = ss.ValInfos.Filter (fun (v, _) -> v.ShouldInline) } + { + ModuleOrNamespaceInfos = NameMap.map (InterruptibleLazy.force >> abstractModulInfo >> notlazy) ss.ModuleOrNamespaceInfos + ValInfos = ss.ValInfos.Filter(fun (v, _) -> v.ShouldInline) + } + + and abstractLazyModulInfo ss = + ss |> InterruptibleLazy.force |> abstractModulInfo |> notlazy - and abstractLazyModulInfo ss = ss |> InterruptibleLazy.force |> abstractModulInfo |> notlazy - abstractLazyModulInfo /// Hide information because of a "let ... in ..." or "let rec ... in ... " let AbstractExprInfoByVars (boundVars: Val list, boundTyVars) ivalue = - // Module and member bindings can be skipped when checking abstraction, since abstraction of these values has already been done when - // we hit the end of the module and called AbstractLazyModulInfoByHiding. If we don't skip these then we end up quadratically retraversing - // the inferred optimization data, i.e. at each binding all the way up a sequences of 'lets' in a module. + // Module and member bindings can be skipped when checking abstraction, since abstraction of these values has already been done when + // we hit the end of the module and called AbstractLazyModulInfoByHiding. If we don't skip these then we end up quadratically retraversing + // the inferred optimization data, i.e. at each binding all the way up a sequences of 'lets' in a module. let boundVars = boundVars |> List.filter (fun v -> not v.IsMemberOrModuleBinding) - match boundVars, boundTyVars with + match boundVars, boundTyVars with | [], [] -> ivalue - | _ -> - - let rec abstractExprInfo ivalue = - match ivalue with - // Check for escaping value. Revert to old info if possible - | ValValue (VRefLocal v2, detail) when - (not (isNil boundVars) && List.exists (valEq v2) boundVars) || - (not (isNil boundTyVars) && - let ftyvs = freeInVal CollectTypars v2 - List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars) -> - - // hiding value when used in expression - abstractExprInfo detail - - | ValValue (v2, detail) -> - let detailR = abstractExprInfo detail - ValValue (v2, detailR) - - // Check for escape in lambda - | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when - (let fvs = freeInExpr (if isNil boundTyVars then (CollectLocalsWithStackGuard()) else CollectTyparsAndLocals) expr - (not (isNil boundVars) && List.exists (Zset.memberOf fvs.FreeLocals) boundVars) || - (not (isNil boundTyVars) && List.exists (Zset.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) || - fvs.UsesMethodLocalConstructs) -> - - // Trimming lambda - UnknownValue - - // Check for escape in generic constant - | ConstValue(_, ty) when - (not (isNil boundTyVars) && - (let ftyvs = freeInType CollectTypars ty - List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars)) -> - UnknownValue - - // Otherwise check all sub-values - | TupleValue vinfos -> TupleValue (Array.map abstractExprInfo vinfos) - | RecdValue (tcref, vinfos) -> RecdValue (tcref, Array.map abstractExprInfo vinfos) - | UnionCaseValue (cspec, vinfos) -> UnionCaseValue(cspec, Array.map abstractExprInfo vinfos) - | CurriedLambdaValue _ - | ConstValue _ - | ConstExprValue _ - | UnknownValue -> ivalue - | SizeValue (_vdepth, vinfo) -> MakeSizedValueInfo (abstractExprInfo vinfo) - - let abstractValInfo v = - { ValExprInfo=abstractExprInfo v.ValExprInfo - ValMakesNoCriticalTailcalls=v.ValMakesNoCriticalTailcalls } - - let rec abstractModulInfo ss = - { ModuleOrNamespaceInfos = ss.ModuleOrNamespaceInfos |> NameMap.map (InterruptibleLazy.force >> abstractModulInfo >> notlazy) - ValInfos = ss.ValInfos.Map (fun (vref, e) -> - check vref (abstractValInfo e) ) } - - abstractExprInfo ivalue + | _ -> + + let rec abstractExprInfo ivalue = + match ivalue with + // Check for escaping value. Revert to old info if possible + | ValValue(VRefLocal v2, detail) when + (not (isNil boundVars) && List.exists (valEq v2) boundVars) + || (not (isNil boundTyVars) + && let ftyvs = freeInVal CollectTypars v2 in + List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars) + -> + + // hiding value when used in expression + abstractExprInfo detail + + | ValValue(v2, detail) -> + let detailR = abstractExprInfo detail + ValValue(v2, detailR) + + // Check for escape in lambda + | CurriedLambdaValue(_, _, _, expr, _) + | ConstExprValue(_, expr) when + (let fvs = + freeInExpr + (if isNil boundTyVars then + (CollectLocalsWithStackGuard()) + else + CollectTyparsAndLocals) + expr + + (not (isNil boundVars) && List.exists (Zset.memberOf fvs.FreeLocals) boundVars) + || (not (isNil boundTyVars) + && List.exists (Zset.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) + || fvs.UsesMethodLocalConstructs) + -> + + // Trimming lambda + UnknownValue + + // Check for escape in generic constant + | ConstValue(_, ty) when + (not (isNil boundTyVars) + && (let ftyvs = freeInType CollectTypars ty + List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars)) + -> + UnknownValue + + // Otherwise check all sub-values + | TupleValue vinfos -> TupleValue(Array.map abstractExprInfo vinfos) + | RecdValue(tcref, vinfos) -> RecdValue(tcref, Array.map abstractExprInfo vinfos) + | UnionCaseValue(cspec, vinfos) -> UnionCaseValue(cspec, Array.map abstractExprInfo vinfos) + | CurriedLambdaValue _ + | ConstValue _ + | ConstExprValue _ + | UnknownValue -> ivalue + | SizeValue(_vdepth, vinfo) -> MakeSizedValueInfo(abstractExprInfo vinfo) + + let abstractValInfo v = + { + ValExprInfo = abstractExprInfo v.ValExprInfo + ValMakesNoCriticalTailcalls = v.ValMakesNoCriticalTailcalls + } + + let rec abstractModulInfo ss = + { + ModuleOrNamespaceInfos = + ss.ModuleOrNamespaceInfos + |> NameMap.map (InterruptibleLazy.force >> abstractModulInfo >> notlazy) + ValInfos = ss.ValInfos.Map(fun (vref, e) -> check vref (abstractValInfo e)) + } + + abstractExprInfo ivalue /// Remap optimization information, e.g. to use public stable references so we can pickle it /// to disk. let RemapOptimizationInfo g tmenv = - let rec remapExprInfo ivalue = - match ivalue with - | ValValue (v, detail) -> ValValue (remapValRef tmenv v, remapExprInfo detail) - | TupleValue vinfos -> TupleValue (Array.map remapExprInfo vinfos) - | RecdValue (tcref, vinfos) -> RecdValue (remapTyconRef tmenv.tyconRefRemap tcref, Array.map remapExprInfo vinfos) - | UnionCaseValue(cspec, vinfos) -> UnionCaseValue (remapUnionCaseRef tmenv.tyconRefRemap cspec, Array.map remapExprInfo vinfos) - | SizeValue(_vdepth, vinfo) -> MakeSizedValueInfo (remapExprInfo vinfo) + let rec remapExprInfo ivalue = + match ivalue with + | ValValue(v, detail) -> ValValue(remapValRef tmenv v, remapExprInfo detail) + | TupleValue vinfos -> TupleValue(Array.map remapExprInfo vinfos) + | RecdValue(tcref, vinfos) -> RecdValue(remapTyconRef tmenv.tyconRefRemap tcref, Array.map remapExprInfo vinfos) + | UnionCaseValue(cspec, vinfos) -> UnionCaseValue(remapUnionCaseRef tmenv.tyconRefRemap cspec, Array.map remapExprInfo vinfos) + | SizeValue(_vdepth, vinfo) -> MakeSizedValueInfo(remapExprInfo vinfo) | UnknownValue -> UnknownValue - | CurriedLambdaValue (uniq, arity, sz, expr, ty) -> CurriedLambdaValue (uniq, arity, sz, remapExpr g CloneAll tmenv expr, remapPossibleForallTy g tmenv ty) - | ConstValue (c, ty) -> ConstValue (c, remapPossibleForallTy g tmenv ty) - | ConstExprValue (sz, expr) -> ConstExprValue (sz, remapExpr g CloneAll tmenv expr) - - let remapValInfo v = - { ValExprInfo=remapExprInfo v.ValExprInfo - ValMakesNoCriticalTailcalls=v.ValMakesNoCriticalTailcalls } + | CurriedLambdaValue(uniq, arity, sz, expr, ty) -> + CurriedLambdaValue(uniq, arity, sz, remapExpr g CloneAll tmenv expr, remapPossibleForallTy g tmenv ty) + | ConstValue(c, ty) -> ConstValue(c, remapPossibleForallTy g tmenv ty) + | ConstExprValue(sz, expr) -> ConstExprValue(sz, remapExpr g CloneAll tmenv expr) + + let remapValInfo v = + { + ValExprInfo = remapExprInfo v.ValExprInfo + ValMakesNoCriticalTailcalls = v.ValMakesNoCriticalTailcalls + } let rec remapModulInfo ss = - { ModuleOrNamespaceInfos = ss.ModuleOrNamespaceInfos |> NameMap.map remapLazyModulInfo - ValInfos = - ss.ValInfos.Map (fun (vref, vinfo) -> - let vrefR = remapValRef tmenv vref - let vinfo = remapValInfo vinfo - // Propagate any inferred ValMakesNoCriticalTailcalls flag from implementation to signature information - if vinfo.ValMakesNoCriticalTailcalls then vrefR.Deref.SetMakesNoCriticalTailcalls() - (vrefR, vinfo)) } + { + ModuleOrNamespaceInfos = ss.ModuleOrNamespaceInfos |> NameMap.map remapLazyModulInfo + ValInfos = + ss.ValInfos.Map(fun (vref, vinfo) -> + let vrefR = remapValRef tmenv vref + let vinfo = remapValInfo vinfo + // Propagate any inferred ValMakesNoCriticalTailcalls flag from implementation to signature information + if vinfo.ValMakesNoCriticalTailcalls then + vrefR.Deref.SetMakesNoCriticalTailcalls() + + (vrefR, vinfo)) + } and remapLazyModulInfo ss = - ss |> InterruptibleLazy.force |> remapModulInfo |> notlazy - + ss |> InterruptibleLazy.force |> remapModulInfo |> notlazy + remapLazyModulInfo /// Hide information when a value is no longer visible @@ -1531,112 +1796,116 @@ let AbstractAndRemapModulInfo g (repackage, hidden) info = //------------------------------------------------------------------------- // Misc helpers -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -/// Type applications of F# "type functions" may cause side effects, e.g. -/// let x<'a> = printfn "hello"; typeof<'a> -/// In this case do not treat them as constants. -let IsTyFuncValRefExpr = function - | Expr.Val (fv, _, _) -> fv.IsTypeFunction +/// Type applications of F# "type functions" may cause side effects, e.g. +/// let x<'a> = printfn "hello"; typeof<'a> +/// In this case do not treat them as constants. +let IsTyFuncValRefExpr = + function + | Expr.Val(fv, _, _) -> fv.IsTypeFunction | _ -> false -/// Type applications of existing functions are always simple constants, with the exception of F# 'type functions' +/// Type applications of existing functions are always simple constants, with the exception of F# 'type functions' let rec IsSmallConstExpr x = match stripDebugPoints x with - | Expr.Op (TOp.LValueOp (LAddrOf _, _), [], [], _) -> true // &x is always a constant - | Expr.Val (v, _, _m) -> not v.IsMutable - | Expr.App (fe, _, _tyargs, args, _) -> isNil args && not (IsTyFuncValRefExpr fe) && IsSmallConstExpr fe + | Expr.Op(TOp.LValueOp(LAddrOf _, _), [], [], _) -> true // &x is always a constant + | Expr.Val(v, _, _m) -> not v.IsMutable + | Expr.App(fe, _, _tyargs, args, _) -> isNil args && not (IsTyFuncValRefExpr fe) && IsSmallConstExpr fe | _ -> false -let ValueOfExpr expr = - if IsSmallConstExpr expr then +let ValueOfExpr expr = + if IsSmallConstExpr expr then ConstExprValue(0, expr) else UnknownValue let IsMutableStructuralBindingForTupleElement (vref: ValRef) = - vref.IsCompilerGenerated && - vref.LogicalName.EndsWithOrdinal suffixForTupleElementAssignmentTarget + vref.IsCompilerGenerated + && vref.LogicalName.EndsWithOrdinal suffixForTupleElementAssignmentTarget let IsMutableForOutArg (vref: ValRef) = - vref.IsCompilerGenerated && - vref.LogicalName.StartsWithOrdinal(outArgCompilerGeneratedName) + vref.IsCompilerGenerated + && vref.LogicalName.StartsWithOrdinal(outArgCompilerGeneratedName) let IsKnownOnlyMutableBeforeUse (vref: ValRef) = - IsMutableStructuralBindingForTupleElement vref || - IsMutableForOutArg vref + IsMutableStructuralBindingForTupleElement vref || IsMutableForOutArg vref //------------------------------------------------------------------------- -// Dead binding elimination -//------------------------------------------------------------------------- - +// Dead binding elimination +//------------------------------------------------------------------------- + // Allow discard of "let v = *byref" if "v" is unused anywhere. The read effect -// can be discarded because it is always assumed that reading byref pointers (without using +// can be discarded because it is always assumed that reading byref pointers (without using // the value of the read) doesn't raise exceptions or cause other "interesting" side effects. // // This allows discarding the implicit deref when matching on struct unions, e.g. -// +// // [] -// type SingleRec = +// type SingleRec = // | SingleUnion of int // member x.Next = let (SingleUnion i) = x in SingleUnion (i+1) // // See https://github.com/dotnet/fsharp/issues/5136 // // -// note: allocating an object with observable identity (i.e. a name) +// note: allocating an object with observable identity (i.e. a name) // or reading from a mutable field counts as an 'effect', i.e. -// this context 'effect' has it's usual meaning in the effect analysis literature of -// read-from-mutable -// write-to-mutable +// this context 'effect' has it's usual meaning in the effect analysis literature of +// read-from-mutable +// write-to-mutable // name-generation // arbitrary-side-effect (e.g. 'non-termination' or 'fire the missiles') -let IsDiscardableEffectExpr expr = - match stripDebugPoints expr with - | Expr.Op (TOp.LValueOp (LByrefGet, _), [], [], _) -> true +let IsDiscardableEffectExpr expr = + match stripDebugPoints expr with + | Expr.Op(TOp.LValueOp(LByrefGet, _), [], [], _) -> true | _ -> false /// Checks is a value binding is non-discardable let ValueIsUsedOrHasEffect cenv fvs (b: Binding, binfo) = let v = b.Var // No discarding for debug code, except InlineIfLambda - (not cenv.settings.EliminateUnusedBindings && not v.InlineIfLambda) || + (not cenv.settings.EliminateUnusedBindings && not v.InlineIfLambda) + || // No discarding for members - Option.isSome v.MemberInfo || + Option.isSome v.MemberInfo + || // No discarding for bindings that have an effect - (binfo.HasEffect && not (IsDiscardableEffectExpr b.Expr)) || + (binfo.HasEffect && not (IsDiscardableEffectExpr b.Expr)) + || // No discarding for 'fixed' - v.IsFixed || + v.IsFixed + || // No discarding for things that are used - Zset.contains v (fvs()) + Zset.contains v (fvs ()) -let SplitValuesByIsUsedOrHasEffect cenv fvs x = +let SplitValuesByIsUsedOrHasEffect cenv fvs x = x |> List.filter (ValueIsUsedOrHasEffect cenv fvs) |> List.unzip -let IlAssemblyCodeInstrHasEffect i = - match i with - | ( AI_nop | AI_ldc _ | AI_add | AI_sub | AI_mul | AI_xor | AI_and | AI_or - | AI_ceq | AI_cgt | AI_cgt_un | AI_clt | AI_clt_un | AI_conv _ | AI_shl - | AI_shr | AI_shr_un | AI_neg | AI_not | AI_ldnull ) - | I_ldstr _ | I_ldtoken _ -> false +let IlAssemblyCodeInstrHasEffect i = + match i with + | (AI_nop | AI_ldc _ | AI_add | AI_sub | AI_mul | AI_xor | AI_and | AI_or | AI_ceq | AI_cgt | AI_cgt_un | AI_clt | AI_clt_un | AI_conv _ | AI_shl | AI_shr | AI_shr_un | AI_neg | AI_not | AI_ldnull) + | I_ldstr _ + | I_ldtoken _ -> false | _ -> true - -let IlAssemblyCodeHasEffect instrs = List.exists IlAssemblyCodeInstrHasEffect instrs -let rec ExprHasEffect g expr = - match stripDebugPoints expr with - | Expr.Val (vref, _, _) -> vref.IsTypeFunction || vref.IsMutable - | Expr.Quote _ +let IlAssemblyCodeHasEffect instrs = + List.exists IlAssemblyCodeInstrHasEffect instrs + +let rec ExprHasEffect g expr = + match stripDebugPoints expr with + | Expr.Val(vref, _, _) -> vref.IsTypeFunction || vref.IsMutable + | Expr.Quote _ | Expr.Lambda _ - | Expr.TyLambda _ + | Expr.TyLambda _ | Expr.Const _ -> false // type applications do not have effects, with the exception of type functions - | Expr.App (f0, _, _, [], _) -> IsTyFuncValRefExpr f0 || ExprHasEffect g f0 - | Expr.Op (op, _, args, m) -> ExprsHaveEffect g args || OpHasEffect g m op - | Expr.LetRec (binds, body, _, _) -> BindingsHaveEffect g binds || ExprHasEffect g body - | Expr.Let (bind, body, _, _) -> BindingHasEffect g bind || ExprHasEffect g body - // REVIEW: could add Expr.Obj on an interface type - these are similar to records of lambda expressions + | Expr.App(f0, _, _, [], _) -> IsTyFuncValRefExpr f0 || ExprHasEffect g f0 + | Expr.Op(op, _, args, m) -> ExprsHaveEffect g args || OpHasEffect g m op + | Expr.LetRec(binds, body, _, _) -> BindingsHaveEffect g binds || ExprHasEffect g body + | Expr.Let(bind, body, _, _) -> BindingHasEffect g bind || ExprHasEffect g body + // REVIEW: could add Expr.Obj on an interface type - these are similar to records of lambda expressions | _ -> true and ExprsHaveEffect g exprs = List.exists (ExprHasEffect g) exprs @@ -1645,36 +1914,38 @@ and BindingsHaveEffect g binds = List.exists (BindingHasEffect g) binds and BindingHasEffect g bind = bind.Expr |> ExprHasEffect g -and OpHasEffect g m op = - match op with +and OpHasEffect g m op = + match op with | TOp.Tuple _ -> false | TOp.AnonRecd _ -> false - | TOp.Recd (ctor, tcref) -> - match ctor with + | TOp.Recd(ctor, tcref) -> + match ctor with | RecdExprIsObjInit -> true | RecdExpr -> not (isRecdOrStructTyconRefReadOnly g m tcref) | TOp.UnionCase ucref -> isRecdOrUnionOrStructTyconRefDefinitelyMutable ucref.TyconRef | TOp.ExnConstr ecref -> isExnDefinitelyMutable ecref - | TOp.Bytes _ | TOp.UInt16s _ | TOp.Array -> true // mutable + | TOp.Bytes _ + | TOp.UInt16s _ + | TOp.Array -> true // mutable | TOp.UnionCaseTagGet _ -> false | TOp.UnionCaseProof _ -> false - | TOp.UnionCaseFieldGet (ucref, n) -> isUnionCaseFieldMutable g ucref n - | TOp.ILAsm (instrs, _) -> IlAssemblyCodeHasEffect instrs + | TOp.UnionCaseFieldGet(ucref, n) -> isUnionCaseFieldMutable g ucref n + | TOp.ILAsm(instrs, _) -> IlAssemblyCodeHasEffect instrs | TOp.TupleFieldGet _ -> false - | TOp.ExnFieldGet (ecref, n) -> isExnFieldMutable ecref n + | TOp.ExnFieldGet(ecref, n) -> isExnFieldMutable ecref n | TOp.RefAddrGet _ -> false | TOp.AnonRecdGet _ -> true // conservative - | TOp.ValFieldGet rfref -> - rfref.RecdField.IsMutable + | TOp.ValFieldGet rfref -> + rfref.RecdField.IsMutable || (TryFindTyconRefBoolAttribute g range0 g.attrib_AllowNullLiteralAttribute rfref.TyconRef = Some true) - | TOp.ValFieldGetAddr (rfref, _readonly) -> rfref.RecdField.IsMutable + | TOp.ValFieldGetAddr(rfref, _readonly) -> rfref.RecdField.IsMutable | TOp.UnionCaseFieldGetAddr _ -> false // union case fields are immutable - | TOp.LValueOp (LAddrOf _, _) -> false // addresses of values are always constants + | TOp.LValueOp(LAddrOf _, _) -> false // addresses of values are always constants | TOp.UnionCaseFieldSet _ | TOp.ExnFieldSet _ | TOp.Coerce | TOp.Reraise - | TOp.IntegerForLoop _ + | TOp.IntegerForLoop _ | TOp.While _ | TOp.TryWith _ (* conservative *) | TOp.TryFinally _ (* conservative *) @@ -1686,110 +1957,152 @@ and OpHasEffect g m op = | TOp.LValueOp _ (* conservative *) | TOp.ValFieldSet _ -> true - let TryEliminateBinding cenv _env bind e2 _m = let g = cenv.g let (TBind(vspec1, e1, spBind)) = bind // don't eliminate bindings if we're not optimizing AND the binding is not a compiler generated variable - if not (cenv.optimizing && cenv.settings.EliminateImmediatelyConsumedLocals()) && - not vspec1.IsCompilerGenerated then - None - elif vspec1.IsFixed then None - elif vspec1.LogicalName.StartsWithOrdinal stackVarPrefix || - vspec1.LogicalName.Contains suffixForVariablesThatMayNotBeEliminated then None + if + not (cenv.optimizing && cenv.settings.EliminateImmediatelyConsumedLocals()) + && not vspec1.IsCompilerGenerated + then + None + elif vspec1.IsFixed then + None + elif + vspec1.LogicalName.StartsWithOrdinal stackVarPrefix + || vspec1.LogicalName.Contains suffixForVariablesThatMayNotBeEliminated + then + None else - // Peephole on immediate consumption of single bindings, e.g. "let x = e in x" --> "e" - // REVIEW: enhance this by general elimination of bindings to - // non-side-effecting expressions that are used only once. - // But note the cases below cover some instances of side-effecting expressions as well.... - let IsUniqueUse vspec2 args = - valEq vspec1 vspec2 - // REVIEW: this looks slow. Look only for one variable instead - && (let fvs = accFreeInExprs (CollectLocalsWithStackGuard()) args emptyFreeVars - not (Zset.contains vspec1 fvs.FreeLocals)) - - // Immediate consumption of value as 2nd or subsequent argument to a construction or projection operation - let rec GetImmediateUseContext rargsl argsr = - match argsr with - | Expr.Val (VRefLocal vspec2, _, _) :: argsr2 - when valEq vspec1 vspec2 && IsUniqueUse vspec2 (List.rev rargsl@argsr2) -> Some(List.rev rargsl, argsr2) - | argsrh :: argsrt when not (ExprHasEffect g argsrh) -> GetImmediateUseContext (argsrh :: rargsl) argsrt - | _ -> None + // Peephole on immediate consumption of single bindings, e.g. "let x = e in x" --> "e" + // REVIEW: enhance this by general elimination of bindings to + // non-side-effecting expressions that are used only once. + // But note the cases below cover some instances of side-effecting expressions as well.... + let IsUniqueUse vspec2 args = + valEq vspec1 vspec2 + // REVIEW: this looks slow. Look only for one variable instead + && (let fvs = accFreeInExprs (CollectLocalsWithStackGuard()) args emptyFreeVars + not (Zset.contains vspec1 fvs.FreeLocals)) + + // Immediate consumption of value as 2nd or subsequent argument to a construction or projection operation + let rec GetImmediateUseContext rargsl argsr = + match argsr with + | Expr.Val(VRefLocal vspec2, _, _) :: argsr2 when valEq vspec1 vspec2 && IsUniqueUse vspec2 (List.rev rargsl @ argsr2) -> + Some(List.rev rargsl, argsr2) + | argsrh :: argsrt when not (ExprHasEffect g argsrh) -> GetImmediateUseContext (argsrh :: rargsl) argsrt + | _ -> None let (DebugPoints(e2, recreate0)) = e2 - match e2 with - - // Immediate consumption of value as itself 'let x = e in x' - | Expr.Val (VRefLocal vspec2, _, _) - when IsUniqueUse vspec2 [] -> - Some (e1 |> recreate0) - - // Immediate consumption of function in an application in a sequential, e.g. 'let part1 = e in part1 arg; rest' - // See https://github.com/fsharp/fslang-design/blob/master/tooling/FST-1034-lambda-optimizations.md - | Expr.Sequential(DebugPoints(Expr.App(DebugPoints(Expr.Val (VRefLocal vspec2, _, _), recreate2), f0ty, c, args, d), recreate1), rest, NormalSeq, m) - when IsUniqueUse vspec2 (rest :: args) -> - Some (Expr.Sequential(recreate1(Expr.App(recreate2 e1, f0ty, c, args, d)), rest, NormalSeq, m) |> recreate0) - - // Immediate consumption of delegate via an application in a sequential, e.g. 'let part1 = e in part1.Invoke(args); rest' - // See https://github.com/fsharp/fslang-design/blob/master/tooling/FST-1034-lambda-optimizations.md - | Expr.Sequential(DebugPoints(DelegateInvokeExpr g (delInvokeRef, delInvokeTy, tyargs, DebugPoints (Expr.Val (VRefLocal vspec2, _, _), recreate2), delInvokeArg, _), recreate1), rest, NormalSeq, m) - when IsUniqueUse vspec2 [rest;delInvokeArg] -> - let invoke = MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, recreate2 e1, delInvokeTy, tyargs, delInvokeArg, m) - Some (Expr.Sequential(recreate1 invoke, rest, NormalSeq, m) |> recreate0) - - // Immediate consumption of value by a pattern match 'let x = e in match x with ...' - | Expr.Match (spMatch, _exprm, TDSwitch(DebugPoints(Expr.Val (VRefLocal vspec2, _, _), recreate1), cases, dflt, _), targets, m, ty2) - when (valEq vspec1 vspec2 && - let fvs = accFreeInTargets CollectLocals targets (accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars) - not (Zset.contains vspec1 fvs.FreeLocals)) -> - - let spMatch = spBind.Combine spMatch - Some (Expr.Match (spMatch, e1.Range, TDSwitch(recreate1 e1, cases, dflt, m), targets, m, ty2) |> recreate0) - - // Immediate use of value as part of an application. 'let f = e in f ...' and 'let x = e in f ... x ...' - // Note functions are evaluated before args - // Note: do not include functions with a single arg of unit type, introduced by abstractBigTargets - | Expr.App (f, f0ty, tyargs, args, m) -> - match GetImmediateUseContext [] (f :: args) with - | Some([], rargs) -> Some (MakeApplicationAndBetaReduce g (e1, f0ty, [tyargs], rargs, m) |> recreate0) - | Some(f :: largs, rargs) -> Some (MakeApplicationAndBetaReduce g (f, f0ty, [tyargs], largs @ (e1 :: rargs), m) |> recreate0) - | None -> None - - // Bug 6311: a special case of nested elimination of locals (which really should be handled more generally) - // 'let x = e in op[op[x;arg2];arg3]' --> op[op[e;arg2];arg3] - // 'let x = e in op[op[arg1;x];arg3]' --> op[op[arg1;e];arg3] when arg1 has no side effects etc. - // 'let x = e in op[op[arg1;arg2];x]' --> op[op[arg1;arg2];e] when arg1, arg2 have no side effects etc. - | Expr.Op (c1, tyargs1, [DebugPoints(Expr.Op (c2, tyargs2, [arg1;arg2], m2), recreate1);arg3], m1) -> - match GetImmediateUseContext [] [arg1;arg2;arg3] with - | Some([], [arg2;arg3]) -> Some (Expr.Op (c1, tyargs1, [Expr.Op (c2, tyargs2, [e1;arg2], m2) |> recreate1; arg3], m1) |> recreate0) - | Some([arg1], [arg3]) -> Some (Expr.Op (c1, tyargs1, [Expr.Op (c2, tyargs2, [arg1;e1], m2) |> recreate1; arg3], m1) |> recreate0) - | Some([arg1;arg2], []) -> Some (Expr.Op (c1, tyargs1, [Expr.Op (c2, tyargs2, [arg1;arg2], m2) |> recreate1; e1], m1) |> recreate0) - | Some _ -> error(InternalError("unexpected return pattern from GetImmediateUseContext", m1)) - | None -> None - - // Immediate consumption of value as first non-effectful argument to a construction or projection operation - // 'let x = e in op[x;....]' - | Expr.Op (c, tyargs, args, m) -> - match GetImmediateUseContext [] args with - | Some(largs, rargs) -> Some (Expr.Op (c, tyargs, (largs @ (e1 :: rargs)), m) |> recreate0) - | None -> None - - | _ -> - None -let TryEliminateLet cenv env bind e2 m = - match TryEliminateBinding cenv env bind e2 m with + match e2 with + + // Immediate consumption of value as itself 'let x = e in x' + | Expr.Val(VRefLocal vspec2, _, _) when IsUniqueUse vspec2 [] -> Some(e1 |> recreate0) + + // Immediate consumption of function in an application in a sequential, e.g. 'let part1 = e in part1 arg; rest' + // See https://github.com/fsharp/fslang-design/blob/master/tooling/FST-1034-lambda-optimizations.md + | Expr.Sequential(DebugPoints(Expr.App(DebugPoints(Expr.Val(VRefLocal vspec2, _, _), recreate2), f0ty, c, args, d), recreate1), + rest, + NormalSeq, + m) when IsUniqueUse vspec2 (rest :: args) -> + Some( + Expr.Sequential(recreate1 (Expr.App(recreate2 e1, f0ty, c, args, d)), rest, NormalSeq, m) + |> recreate0 + ) + + // Immediate consumption of delegate via an application in a sequential, e.g. 'let part1 = e in part1.Invoke(args); rest' + // See https://github.com/fsharp/fslang-design/blob/master/tooling/FST-1034-lambda-optimizations.md + | Expr.Sequential(DebugPoints(DelegateInvokeExpr g (delInvokeRef, + delInvokeTy, + tyargs, + DebugPoints(Expr.Val(VRefLocal vspec2, _, _), recreate2), + delInvokeArg, + _), + recreate1), + rest, + NormalSeq, + m) when IsUniqueUse vspec2 [ rest; delInvokeArg ] -> + let invoke = + MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, recreate2 e1, delInvokeTy, tyargs, delInvokeArg, m) + + Some(Expr.Sequential(recreate1 invoke, rest, NormalSeq, m) |> recreate0) + + // Immediate consumption of value by a pattern match 'let x = e in match x with ...' + | Expr.Match(spMatch, _exprm, TDSwitch(DebugPoints(Expr.Val(VRefLocal vspec2, _, _), recreate1), cases, dflt, _), targets, m, ty2) when + (valEq vspec1 vspec2 + && let fvs = + accFreeInTargets CollectLocals targets (accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars) in + + not (Zset.contains vspec1 fvs.FreeLocals)) + -> + + let spMatch = spBind.Combine spMatch + + Some( + Expr.Match(spMatch, e1.Range, TDSwitch(recreate1 e1, cases, dflt, m), targets, m, ty2) + |> recreate0 + ) + + // Immediate use of value as part of an application. 'let f = e in f ...' and 'let x = e in f ... x ...' + // Note functions are evaluated before args + // Note: do not include functions with a single arg of unit type, introduced by abstractBigTargets + | Expr.App(f, f0ty, tyargs, args, m) -> + match GetImmediateUseContext [] (f :: args) with + | Some([], rargs) -> Some(MakeApplicationAndBetaReduce g (e1, f0ty, [ tyargs ], rargs, m) |> recreate0) + | Some(f :: largs, rargs) -> + Some( + MakeApplicationAndBetaReduce g (f, f0ty, [ tyargs ], largs @ (e1 :: rargs), m) + |> recreate0 + ) + | None -> None + + // Bug 6311: a special case of nested elimination of locals (which really should be handled more generally) + // 'let x = e in op[op[x;arg2];arg3]' --> op[op[e;arg2];arg3] + // 'let x = e in op[op[arg1;x];arg3]' --> op[op[arg1;e];arg3] when arg1 has no side effects etc. + // 'let x = e in op[op[arg1;arg2];x]' --> op[op[arg1;arg2];e] when arg1, arg2 have no side effects etc. + | Expr.Op(c1, tyargs1, [ DebugPoints(Expr.Op(c2, tyargs2, [ arg1; arg2 ], m2), recreate1); arg3 ], m1) -> + match GetImmediateUseContext [] [ arg1; arg2; arg3 ] with + | Some([], [ arg2; arg3 ]) -> + Some( + Expr.Op(c1, tyargs1, [ Expr.Op(c2, tyargs2, [ e1; arg2 ], m2) |> recreate1; arg3 ], m1) + |> recreate0 + ) + | Some([ arg1 ], [ arg3 ]) -> + Some( + Expr.Op(c1, tyargs1, [ Expr.Op(c2, tyargs2, [ arg1; e1 ], m2) |> recreate1; arg3 ], m1) + |> recreate0 + ) + | Some([ arg1; arg2 ], []) -> + Some( + Expr.Op(c1, tyargs1, [ Expr.Op(c2, tyargs2, [ arg1; arg2 ], m2) |> recreate1; e1 ], m1) + |> recreate0 + ) + | Some _ -> error (InternalError("unexpected return pattern from GetImmediateUseContext", m1)) + | None -> None + + // Immediate consumption of value as first non-effectful argument to a construction or projection operation + // 'let x = e in op[x;....]' + | Expr.Op(c, tyargs, args, m) -> + match GetImmediateUseContext [] args with + | Some(largs, rargs) -> Some(Expr.Op(c, tyargs, (largs @ (e1 :: rargs)), m) |> recreate0) + | None -> None + + | _ -> None + +let TryEliminateLet cenv env bind e2 m = + match TryEliminateBinding cenv env bind e2 m with | Some e2R -> e2R, -localVarSize (* eliminated a let, hence reduce size estimate *) | None -> mkLetBind m bind e2, 0 /// Detect the application of a value to an arbitrary number of arguments [] -let rec (|KnownValApp|_|) expr = +let rec (|KnownValApp|_|) expr = match stripDebugPoints expr with - | Expr.Val (vref, _, _) -> ValueSome(vref, [], []) - | Expr.App (KnownValApp(vref, typeArgs1, otherArgs1), _, typeArgs2, otherArgs2, _) -> ValueSome(vref, typeArgs1@typeArgs2, otherArgs1@otherArgs2) + | Expr.Val(vref, _, _) -> ValueSome(vref, [], []) + | Expr.App(KnownValApp(vref, typeArgs1, otherArgs1), _, typeArgs2, otherArgs2, _) -> + ValueSome(vref, typeArgs1 @ typeArgs2, otherArgs1 @ otherArgs2) | _ -> ValueNone /// Matches boolean decision tree: @@ -1797,46 +2110,59 @@ let rec (|KnownValApp|_|) expr = [] let (|TDBoolSwitch|_|) dtree = match dtree with - | TDSwitch(expr, [TCase (DecisionTreeTest.Const(Const.Bool testBool), caseTree )], Some defaultTree, range) -> - ValueSome (expr, testBool, caseTree, defaultTree, range) - | _ -> - ValueNone + | TDSwitch(expr, [ TCase(DecisionTreeTest.Const(Const.Bool testBool), caseTree) ], Some defaultTree, range) -> + ValueSome(expr, testBool, caseTree, defaultTree, range) + | _ -> ValueNone /// Check target that have a constant bool value [] let (|ConstantBoolTarget|_|) target = match target with - | TTarget([], Expr.Const (Const.Bool b, _, _), _) -> ValueSome b + | TTarget([], Expr.Const(Const.Bool b, _, _), _) -> ValueSome b | _ -> ValueNone /// Is this a tree, where each decision is a two-way switch (to prevent later duplication of trees), and each branch returns or true/false, /// apart from one branch which defers to another expression let rec CountBoolLogicTree (targets: DecisionTreeTarget[], costOuterCaseTree, costOuterDefaultTree, testBool as data) tree = - match tree with - | TDSwitch (_expr, [case], Some defaultTree, _range) -> - let tc1,ec1 = CountBoolLogicTree data case.CaseTree - let tc2, ec2 = CountBoolLogicTree data defaultTree + match tree with + | TDSwitch(_expr, [ case ], Some defaultTree, _range) -> + let tc1, ec1 = CountBoolLogicTree data case.CaseTree + let tc2, ec2 = CountBoolLogicTree data defaultTree tc1 + tc2, ec1 + ec2 - | TDSuccess([], idx) -> + | TDSuccess([], idx) -> match targets[idx] with - | ConstantBoolTarget result -> (if result = testBool then costOuterCaseTree else costOuterDefaultTree), 0 + | ConstantBoolTarget result -> + (if result = testBool then + costOuterCaseTree + else + costOuterDefaultTree), + 0 | TTarget([], _exp, _) -> costOuterCaseTree + costOuterDefaultTree, 10 - | _ -> 100, 100 + | _ -> 100, 100 | _ -> 100, 100 /// Rewrite a decision tree for which CountBoolLogicTree returned a low number (see below). Produce a new decision /// tree where at each ConstantBoolSuccessTree tip we replace with either outerCaseTree or outerDefaultTree /// depending on whether the target result was true/false let rec RewriteBoolLogicTree (targets: DecisionTreeTarget[], outerCaseTree, outerDefaultTree, testBool as data) tree = - match tree with - | TDSwitch (expr, cases, defaultTree, range) -> + match tree with + | TDSwitch(expr, cases, defaultTree, range) -> let cases2 = cases |> List.map (RewriteBoolLogicCase data) let defaultTree2 = defaultTree |> Option.map (RewriteBoolLogicTree data) - TDSwitch (expr, cases2, defaultTree2, range) - | TDSuccess([], idx) -> - match targets[idx] with - | ConstantBoolTarget result -> if result = testBool then outerCaseTree else outerDefaultTree - | TTarget([], exp, _) -> mkBoolSwitch exp.Range exp (if testBool then outerCaseTree else outerDefaultTree) (if testBool then outerDefaultTree else outerCaseTree) + TDSwitch(expr, cases2, defaultTree2, range) + | TDSuccess([], idx) -> + match targets[idx] with + | ConstantBoolTarget result -> + if result = testBool then + outerCaseTree + else + outerDefaultTree + | TTarget([], exp, _) -> + mkBoolSwitch + exp.Range + exp + (if testBool then outerCaseTree else outerDefaultTree) + (if testBool then outerDefaultTree else outerCaseTree) | _ -> failwith "CountBoolLogicTree should exclude this case" | _ -> failwith "CountBoolLogicTree should exclude this case" @@ -1845,32 +2171,51 @@ and RewriteBoolLogicCase data (TCase(test, tree)) = /// Repeatedly combine switch-over-match decision trees, see https://github.com/dotnet/fsharp/issues/635. /// The outer decision tree is doing a switch over a boolean result, the inner match is producing only -/// constant boolean results in its targets. -let rec CombineBoolLogic expr = +/// constant boolean results in its targets. +let rec CombineBoolLogic expr = // try to find nested boolean switch match expr with - | Expr.Match (outerSP, outerMatchRange, - TDBoolSwitch( - DebugPoints(Expr.Match (_innerSP, _innerMatchRange, innerTree, innerTargets, _innerDefaultRange, _innerMatchTy), _), - outerTestBool, outerCaseTree, outerDefaultTree, _outerSwitchRange ), - outerTargets, outerDefaultRange, outerMatchTy) -> - - let costOuterCaseTree = match outerCaseTree with TDSuccess _ -> 0 | _ -> 1 - let costOuterDefaultTree = match outerDefaultTree with TDSuccess _ -> 0 | _ -> 1 - let tc, ec = CountBoolLogicTree (innerTargets, costOuterCaseTree, costOuterDefaultTree, outerTestBool) innerTree + | Expr.Match(outerSP, + outerMatchRange, + TDBoolSwitch(DebugPoints(Expr.Match(_innerSP, _innerMatchRange, innerTree, innerTargets, _innerDefaultRange, _innerMatchTy), + _), + outerTestBool, + outerCaseTree, + outerDefaultTree, + _outerSwitchRange), + outerTargets, + outerDefaultRange, + outerMatchTy) -> + + let costOuterCaseTree = + match outerCaseTree with + | TDSuccess _ -> 0 + | _ -> 1 + + let costOuterDefaultTree = + match outerDefaultTree with + | TDSuccess _ -> 0 + | _ -> 1 + + let tc, ec = + CountBoolLogicTree (innerTargets, costOuterCaseTree, costOuterDefaultTree, outerTestBool) innerTree // At most one expression, no overall duplication of TSwitch nodes - if tc <= costOuterCaseTree + costOuterDefaultTree && ec <= 10 then - let newExpr = - Expr.Match (outerSP, outerMatchRange, - RewriteBoolLogicTree (innerTargets, outerCaseTree, outerDefaultTree, outerTestBool) innerTree, - outerTargets, outerDefaultRange, outerMatchTy) + if tc <= costOuterCaseTree + costOuterDefaultTree && ec <= 10 then + let newExpr = + Expr.Match( + outerSP, + outerMatchRange, + RewriteBoolLogicTree (innerTargets, outerCaseTree, outerDefaultTree, outerTestBool) innerTree, + outerTargets, + outerDefaultRange, + outerMatchTy + ) CombineBoolLogic newExpr else expr - | _ -> - expr + | _ -> expr //------------------------------------------------------------------------- // ExpandStructuralBinding @@ -1881,15 +2226,18 @@ let rec CombineBoolLogic expr = // This transform encourages that by allowing projections to be simplified. // // Apply the same to 'Some(x)' constructions -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- let CanExpandStructuralBinding (v: Val) = - not v.IsCompiledAsTopLevel && - not v.IsMember && - not v.IsTypeFunction && - not v.IsMutable - -let ExprIsValue = function Expr.Val _ -> true | _ -> false + not v.IsCompiledAsTopLevel + && not v.IsMember + && not v.IsTypeFunction + && not v.IsMutable + +let ExprIsValue = + function + | Expr.Val _ -> true + | _ -> false let MakeStructuralBindingTempVal (v: Val) i (arg: Expr) argTy = let name = v.LogicalName + "_" + string i @@ -1910,17 +2258,16 @@ let ExpandStructuralBindingRaw cenv expr = assert cenv.settings.ExpandStructuralValues() match expr with - | Expr.Let (TBind(v, rhs, tgtSeqPtOpt), body, m, _) - when (isRefTupleExpr rhs && - CanExpandStructuralBinding v) -> - let args = tryDestRefTupleExpr rhs - if List.forall ExprIsValue args then - expr (* avoid re-expanding when recursion hits original binding *) - else - let argTys = destRefTupleTy g v.Type - let ves, binds = List.mapi2 (MakeStructuralBindingTemp v) args argTys |> List.unzip - let tuple = mkRefTupled g m ves argTys - mkLetsBind m binds (mkLet tgtSeqPtOpt m v tuple body) + | Expr.Let(TBind(v, rhs, tgtSeqPtOpt), body, m, _) when (isRefTupleExpr rhs && CanExpandStructuralBinding v) -> + let args = tryDestRefTupleExpr rhs + + if List.forall ExprIsValue args then + expr (* avoid re-expanding when recursion hits original binding *) + else + let argTys = destRefTupleTy g v.Type + let ves, binds = List.mapi2 (MakeStructuralBindingTemp v) args argTys |> List.unzip + let tuple = mkRefTupled g m ves argTys + mkLetsBind m binds (mkLet tgtSeqPtOpt m v tuple body) | expr -> expr // Moves outer tuple binding inside near the tupled expression: @@ -1929,28 +2276,27 @@ let ExpandStructuralBindingRaw cenv expr = // let a0=v0 in let a1=v1 in ... in let an=vn in (let t = e0, e1, ..., em in body) // // This way ExpandStructuralBinding can replace expressions in constants, t is directly bound -// to a tuple expression so that other optimizations such as OptimizeTupleFieldGet work, +// to a tuple expression so that other optimizations such as OptimizeTupleFieldGet work, // and the tuple allocation can be eliminated. // Most importantly, this successfully eliminates tuple allocations for implicitly returned // formal arguments in method calls. let rec RearrangeTupleBindings expr fin = match expr with - | Expr.Let (bind, body, m, _) -> + | Expr.Let(bind, body, m, _) -> match RearrangeTupleBindings body fin with - | Some b -> Some (mkLetBind m bind b) + | Some b -> Some(mkLetBind m bind b) | None -> None - | Expr.Op (TOp.Tuple tupInfo, _, _, _) when not (evalTupInfoIsStruct tupInfo) -> - Some (fin expr) + | Expr.Op(TOp.Tuple tupInfo, _, _, _) when not (evalTupInfoIsStruct tupInfo) -> Some(fin expr) - | Expr.Sequential (e1, e2, kind, m) -> + | Expr.Sequential(e1, e2, kind, m) -> match RearrangeTupleBindings e2 fin with - | Some b -> Some (Expr.Sequential (e1, b, kind, m)) + | Some b -> Some(Expr.Sequential(e1, b, kind, m)) | None -> None - | Expr.DebugPoint (dp, innerExpr) -> + | Expr.DebugPoint(dp, innerExpr) -> match RearrangeTupleBindings innerExpr fin with - | Some innerExprR -> Some (Expr.DebugPoint (dp, innerExprR)) + | Some innerExprR -> Some(Expr.DebugPoint(dp, innerExprR)) | None -> None | _ -> None @@ -1989,54 +2335,62 @@ let rec RearrangeTupleBindings expr fin = let TryRewriteBranchingTupleBinding g (v: Val) rhs tgtSeqPtOpt body m = let rec dive g m (requisites: Lazy<_>) expr = match expr with - | Expr.Match (sp, inputRange, decision, targets, fullRange, ty) -> + | Expr.Match(sp, inputRange, decision, targets, fullRange, ty) -> // Recurse down every if/match branch - let rewrittenTargets = targets |> Array.choose (fun (TTarget (vals, targetExpr, flags)) -> - match dive g m requisites targetExpr with - | Some rewritten -> TTarget (vals, rewritten, flags) |> Some - | _ -> None) + let rewrittenTargets = + targets + |> Array.choose (fun (TTarget(vals, targetExpr, flags)) -> + match dive g m requisites targetExpr with + | Some rewritten -> TTarget(vals, rewritten, flags) |> Some + | _ -> None) // If not all branches can be rewritten, keep the original expression as it is if rewrittenTargets.Length <> targets.Length then None else - Expr.Match (sp, inputRange, decision, rewrittenTargets, fullRange, ty) |> Some + Expr.Match(sp, inputRange, decision, rewrittenTargets, fullRange, ty) |> Some - | Expr.Op (TOp.Tuple tupInfo, _, tupleElements, m) when not (evalTupInfoIsStruct tupInfo) -> + | Expr.Op(TOp.Tuple tupInfo, _, tupleElements, m) when not (evalTupInfoIsStruct tupInfo) -> // Replace tuple allocation with mutations of locals let _, _, _, vrefs = requisites.Value - List.map2 (mkValSet m) vrefs tupleElements - |> mkSequentials g m - |> Some + List.map2 (mkValSet m) vrefs tupleElements |> mkSequentials g m |> Some - | Expr.Sequential (e1, e2, kind, m) -> + | Expr.Sequential(e1, e2, kind, m) -> match dive g m requisites e2 with - | Some rewritten -> Expr.Sequential (e1, rewritten, kind, m) |> Some + | Some rewritten -> Expr.Sequential(e1, rewritten, kind, m) |> Some | _ -> None - | Expr.DebugPoint (dp, innerExpr) -> + | Expr.DebugPoint(dp, innerExpr) -> match dive g m requisites innerExpr with - | Some innerExprR -> Expr.DebugPoint (dp, innerExprR) |> Some + | Some innerExprR -> Expr.DebugPoint(dp, innerExprR) |> Some | _ -> None - | Expr.Let (bind, body, m, _) -> + | Expr.Let(bind, body, m, _) -> match dive g m requisites body with | Some rewritten -> mkLetBind m bind rewritten |> Some | _ -> None | _ -> None - let requisites = lazy ( - let argTys = destRefTupleTy g v.Type - let inits = argTys |> List.map (mkNull m) - let ves, binds = List.mapi2 (MakeMutableStructuralBindingForTupleElement v) inits argTys |> List.unzip - let vrefs = binds |> List.map (fun (TBind (v, _, _)) -> mkLocalValRef v) - argTys, ves, binds, vrefs) + let requisites = + lazy + (let argTys = destRefTupleTy g v.Type + let inits = argTys |> List.map (mkNull m) + + let ves, binds = + List.mapi2 (MakeMutableStructuralBindingForTupleElement v) inits argTys + |> List.unzip + + let vrefs = binds |> List.map (fun (TBind(v, _, _)) -> mkLocalValRef v) + argTys, ves, binds, vrefs) match dive g m requisites rhs with | Some rewrittenRhs -> let argTys, ves, binds, _ = requisites.Value - let rhsAndTupleBinding = mkCompGenSequential m rewrittenRhs (mkLet tgtSeqPtOpt m v (mkRefTupled g m ves argTys) body) + + let rhsAndTupleBinding = + mkCompGenSequential m rewrittenRhs (mkLet tgtSeqPtOpt m v (mkRefTupled g m ves argTys) body) + mkLetsBind m binds rhsAndTupleBinding |> Some | _ -> None @@ -2046,10 +2400,11 @@ let ExpandStructuralBinding cenv expr = assert cenv.settings.ExpandStructuralValues() match expr with - | Expr.Let (TBind(v, rhs, tgtSeqPtOpt), body, m, _) - when (isRefTupleTy g v.Type && - not (isRefTupleExpr rhs) && - CanExpandStructuralBinding v) -> + | Expr.Let(TBind(v, rhs, tgtSeqPtOpt), body, m, _) when + (isRefTupleTy g v.Type + && not (isRefTupleExpr rhs) + && CanExpandStructuralBinding v) + -> match RearrangeTupleBindings rhs (fun top -> mkLet DebugPointAtBinding.NoneAtLet m v top body) with | Some e -> let e2 = ExpandStructuralBindingRaw cenv e @@ -2059,403 +2414,454 @@ let ExpandStructuralBinding cenv expr = | _ -> e2 | None -> // RearrangeTupleBindings could have failed because the rhs branches - TryRewriteBranchingTupleBinding g v rhs tgtSeqPtOpt body m |> Option.defaultValue expr + TryRewriteBranchingTupleBinding g v rhs tgtSeqPtOpt body m + |> Option.defaultValue expr // Expand 'let v = Some arg in ...' to 'let tmp = arg in let v = Some tp in ...' // Used to give names to values of optional arguments prior as we inline. - | Expr.Let (TBind(v, Expr.Op(TOp.UnionCase uc, _, [arg], _), tgtSeqPtOpt), body, m, _) - when isOptionTy g v.Type && - not (ExprIsValue arg) && - g.unionCaseRefEq uc (mkSomeCase g) && - CanExpandStructuralBinding v -> - let argTy = destOptionTy g v.Type - let vi, vie = MakeStructuralBindingTempVal v 0 arg argTy - let newExpr = mkSome g argTy vie m - mkLet tgtSeqPtOpt m vi arg (mkLet DebugPointAtBinding.NoneAtLet m v newExpr body) - - | e -> - ExpandStructuralBindingRaw cenv e + | Expr.Let(TBind(v, Expr.Op(TOp.UnionCase uc, _, [ arg ], _), tgtSeqPtOpt), body, m, _) when + isOptionTy g v.Type + && not (ExprIsValue arg) + && g.unionCaseRefEq uc (mkSomeCase g) + && CanExpandStructuralBinding v + -> + let argTy = destOptionTy g v.Type + let vi, vie = MakeStructuralBindingTempVal v 0 arg argTy + let newExpr = mkSome g argTy vie m + mkLet tgtSeqPtOpt m vi arg (mkLet DebugPointAtBinding.NoneAtLet m v newExpr body) + + | e -> ExpandStructuralBindingRaw cenv e /// Detect a query { ... } [] -let (|QueryRun|_|) g expr = +let (|QueryRun|_|) g expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _, _, [_builder; arg], _) when valRefEq g vref g.query_run_value_vref -> - ValueSome (arg, None) - | Expr.App (Expr.Val (vref, _, _), _, [ elemTy ], [_builder; arg], _) when valRefEq g vref g.query_run_enumerable_vref -> - ValueSome (arg, Some elemTy) - | _ -> - ValueNone + | Expr.App(Expr.Val(vref, _, _), _, _, [ _builder; arg ], _) when valRefEq g vref g.query_run_value_vref -> ValueSome(arg, None) + | Expr.App(Expr.Val(vref, _, _), _, [ elemTy ], [ _builder; arg ], _) when valRefEq g vref g.query_run_enumerable_vref -> + ValueSome(arg, Some elemTy) + | _ -> ValueNone -let (|MaybeRefTupled|) e = tryDestRefTupleExpr e +let (|MaybeRefTupled|) e = tryDestRefTupleExpr e [] -let (|AnyInstanceMethodApp|_|) e = - match e with - | Expr.App (Expr.Val (vref, _, _), _, tyargs, [obj; MaybeRefTupled args], _) -> ValueSome (vref, tyargs, obj, args) +let (|AnyInstanceMethodApp|_|) e = + match e with + | Expr.App(Expr.Val(vref, _, _), _, tyargs, [ obj; MaybeRefTupled args ], _) -> ValueSome(vref, tyargs, obj, args) | _ -> ValueNone [] -let (|InstanceMethodApp|_|) g (expectedValRef: ValRef) e = - match e with - | AnyInstanceMethodApp (vref, tyargs, obj, args) when valRefEq g vref expectedValRef -> ValueSome (tyargs, obj, args) +let (|InstanceMethodApp|_|) g (expectedValRef: ValRef) e = + match e with + | AnyInstanceMethodApp(vref, tyargs, obj, args) when valRefEq g vref expectedValRef -> ValueSome(tyargs, obj, args) | _ -> ValueNone [] -let (|QuerySourceEnumerable|_|) g = function - | InstanceMethodApp g g.query_source_vref ([resTy], _builder, [res]) -> ValueSome (resTy, res) +let (|QuerySourceEnumerable|_|) g = + function + | InstanceMethodApp g g.query_source_vref ([ resTy ], _builder, [ res ]) -> ValueSome(resTy, res) | _ -> ValueNone [] -let (|QueryFor|_|) g = function - | InstanceMethodApp g g.query_for_vref ([srcTy;qTy;resTy;_qInnerTy], _builder, [src;selector]) -> ValueSome (qTy, srcTy, resTy, src, selector) +let (|QueryFor|_|) g = + function + | InstanceMethodApp g g.query_for_vref ([ srcTy; qTy; resTy; _qInnerTy ], _builder, [ src; selector ]) -> + ValueSome(qTy, srcTy, resTy, src, selector) | _ -> ValueNone [] -let (|QueryYield|_|) g = function - | InstanceMethodApp g g.query_yield_vref ([resTy;qTy], _builder, [res]) -> ValueSome (qTy, resTy, res) +let (|QueryYield|_|) g = + function + | InstanceMethodApp g g.query_yield_vref ([ resTy; qTy ], _builder, [ res ]) -> ValueSome(qTy, resTy, res) | _ -> ValueNone [] -let (|QueryYieldFrom|_|) g = function - | InstanceMethodApp g g.query_yield_from_vref ([resTy;qTy], _builder, [res]) -> ValueSome (qTy, resTy, res) +let (|QueryYieldFrom|_|) g = + function + | InstanceMethodApp g g.query_yield_from_vref ([ resTy; qTy ], _builder, [ res ]) -> ValueSome(qTy, resTy, res) | _ -> ValueNone [] -let (|QuerySelect|_|) g = function - | InstanceMethodApp g g.query_select_vref ([srcTy;qTy;resTy], _builder, [src;selector]) -> ValueSome (qTy, srcTy, resTy, src, selector) +let (|QuerySelect|_|) g = + function + | InstanceMethodApp g g.query_select_vref ([ srcTy; qTy; resTy ], _builder, [ src; selector ]) -> + ValueSome(qTy, srcTy, resTy, src, selector) | _ -> ValueNone [] -let (|QueryZero|_|) g = function - | InstanceMethodApp g g.query_zero_vref ([resTy;qTy], _builder, _) -> ValueSome (qTy, resTy) +let (|QueryZero|_|) g = + function + | InstanceMethodApp g g.query_zero_vref ([ resTy; qTy ], _builder, _) -> ValueSome(qTy, resTy) | _ -> ValueNone /// Look for a possible tuple and transform -let (|AnyRefTupleTrans|) e = - match e with - | Expr.Op (TOp.Tuple tupInfo, tys, es, m) when not (evalTupInfoIsStruct tupInfo) -> (es, (fun es -> Expr.Op (TOp.Tuple tupInfo, tys, es, m))) - | _ -> [e], (function [e] -> e | _ -> assert false; failwith "unreachable") +let (|AnyRefTupleTrans|) e = + match e with + | Expr.Op(TOp.Tuple tupInfo, tys, es, m) when not (evalTupInfoIsStruct tupInfo) -> + (es, (fun es -> Expr.Op(TOp.Tuple tupInfo, tys, es, m))) + | _ -> + [ e ], + (function + | [ e ] -> e + | _ -> + assert false + failwith "unreachable") /// Look for any QueryBuilder.* operation and transform [] -let (|AnyQueryBuilderOpTrans|_|) g = function - | Expr.App (Expr.Val (vref, _, _) as v, vty, tyargs, [builder; AnyRefTupleTrans( src :: rest, replaceArgs) ], m) when - (match vref.ApparentEnclosingEntity with Parent tcref -> tyconRefEq g tcref g.query_builder_tcref | ParentNone -> false) -> - ValueSome (src, (fun newSource -> Expr.App (v, vty, tyargs, [builder; replaceArgs(newSource :: rest)], m))) +let (|AnyQueryBuilderOpTrans|_|) g = + function + | Expr.App(Expr.Val(vref, _, _) as v, vty, tyargs, [ builder; AnyRefTupleTrans(src :: rest, replaceArgs) ], m) when + (match vref.ApparentEnclosingEntity with + | Parent tcref -> tyconRefEq g tcref g.query_builder_tcref + | ParentNone -> false) + -> + ValueSome(src, (fun newSource -> Expr.App(v, vty, tyargs, [ builder; replaceArgs (newSource :: rest) ], m))) | _ -> ValueNone /// If this returns "Some" then the source is not IQueryable. -// := +// := // | query.Select(, ) --> Seq.map(qexprInner', ...) // | query.For(, ) --> IQueryable if qexprInner is IQueryable, otherwise Seq.collect(qexprInner', ...) // | query.Yield --> not IQueryable // | query.YieldFrom --> not IQueryable -// | query.Op(, ) --> IQueryable if qexprInner is IQueryable, otherwise query.Op(qexprInner', ) +// | query.Op(, ) --> IQueryable if qexprInner is IQueryable, otherwise query.Op(qexprInner', ) // | :> seq<_> --> IQueryable if qexprInner is IQueryable // -// := -// | query.Select(, ) --> IQueryable if qexprInner is IQueryable, otherwise seq { qexprInner' } -// | query.For(, ) --> IQueryable if qexprInner is IQueryable, otherwise seq { qexprInner' } -// | query.Yield --> not IQueryable, seq { } -// | query.YieldFrom --> not IQueryable, seq { yield! } -// | query.Op(, ) --> IQueryable if qexprOuter is IQueryable, otherwise query.Op(qexprOuter', ) -let rec tryRewriteToSeqCombinators g (e: Expr) = +// := +// | query.Select(, ) --> IQueryable if qexprInner is IQueryable, otherwise seq { qexprInner' } +// | query.For(, ) --> IQueryable if qexprInner is IQueryable, otherwise seq { qexprInner' } +// | query.Yield --> not IQueryable, seq { } +// | query.YieldFrom --> not IQueryable, seq { yield! } +// | query.Op(, ) --> IQueryable if qexprOuter is IQueryable, otherwise query.Op(qexprOuter', ) +let rec tryRewriteToSeqCombinators g (e: Expr) = let m = e.Range - match e with + + match e with // query.Yield --> Seq.singleton - | QueryYield g (_, resultElemTy, vExpr) -> Some (mkCallSeqSingleton g m resultElemTy vExpr) + | QueryYield g (_, resultElemTy, vExpr) -> Some(mkCallSeqSingleton g m resultElemTy vExpr) // query.YieldFrom (query.Source s) --> s | QueryYieldFrom g (_, _, QuerySourceEnumerable g (_, resExpr)) -> Some resExpr // query.Select --> Seq.map - | QuerySelect g (_qTy, sourceElemTy, resultElemTy, source, resultSelector) -> - - match tryRewriteToSeqCombinators g source with - | Some newSource -> Some (mkCallSeqMap g m sourceElemTy resultElemTy resultSelector newSource) + | QuerySelect g (_qTy, sourceElemTy, resultElemTy, source, resultSelector) -> + + match tryRewriteToSeqCombinators g source with + | Some newSource -> Some(mkCallSeqMap g m sourceElemTy resultElemTy resultSelector newSource) | None -> None // query.Zero -> Seq.empty - | QueryZero g (_qTy, sourceElemTy) -> - Some (mkCallSeqEmpty g m sourceElemTy) + | QueryZero g (_qTy, sourceElemTy) -> Some(mkCallSeqEmpty g m sourceElemTy) // query.For --> Seq.collect - | QueryFor g (_qTy, sourceElemTy, resultElemTy, QuerySourceEnumerable g (_, source), Expr.Lambda (_, _, _, [resultSelectorVar], resultSelector, mLambda, _)) -> + | QueryFor g (_qTy, + sourceElemTy, + resultElemTy, + QuerySourceEnumerable g (_, source), + Expr.Lambda(_, _, _, [ resultSelectorVar ], resultSelector, mLambda, _)) -> match tryRewriteToSeqCombinators g resultSelector with | Some newResultSelector -> - Some (mkCallSeqCollect g m sourceElemTy resultElemTy (mkLambda mLambda resultSelectorVar (newResultSelector, tyOfExpr g newResultSelector)) source) + Some( + mkCallSeqCollect + g + m + sourceElemTy + resultElemTy + (mkLambda mLambda resultSelectorVar (newResultSelector, tyOfExpr g newResultSelector)) + source + ) | _ -> None - // let --> let - | Expr.Let (bind, bodyExpr, m, _) -> - match tryRewriteToSeqCombinators g bodyExpr with - | Some newBodyExpr -> - Some (Expr.Let (bind, newBodyExpr, m, newCache())) + | Expr.Let(bind, bodyExpr, m, _) -> + match tryRewriteToSeqCombinators g bodyExpr with + | Some newBodyExpr -> Some(Expr.Let(bind, newBodyExpr, m, newCache ())) | None -> None // match --> match - | Expr.Match (spBind, mExpr, pt, targets, m, _ty) -> + | Expr.Match(spBind, mExpr, pt, targets, m, _ty) -> let targets = - targets |> Array.map (fun (TTarget(vs, e, flags)) -> + targets + |> Array.map (fun (TTarget(vs, e, flags)) -> match tryRewriteToSeqCombinators g e with | None -> None | Some e -> Some(TTarget(vs, e, flags))) - if targets |> Array.forall Option.isSome then + if targets |> Array.forall Option.isSome then let targets = targets |> Array.map Option.get let ty = targets |> Array.pick (fun (TTarget(_, e, _)) -> Some(tyOfExpr g e)) - Some (Expr.Match (spBind, mExpr, pt, targets, m, ty)) + Some(Expr.Match(spBind, mExpr, pt, targets, m, ty)) else None - | Expr.DebugPoint (dp, innerExpr) -> - match tryRewriteToSeqCombinators g innerExpr with - | Some innerExprR -> - Some (Expr.DebugPoint (dp, innerExprR)) + | Expr.DebugPoint(dp, innerExpr) -> + match tryRewriteToSeqCombinators g innerExpr with + | Some innerExprR -> Some(Expr.DebugPoint(dp, innerExprR)) | None -> None - | _ -> - None + | _ -> None - /// This detects forms arising from query expressions, i.e. -/// query.Run <@ query.Op(, ) @> +/// query.Run <@ query.Op(, ) @> /// /// We check if the combinators are marked with tag IEnumerable - if do, we optimize the "Run" and quotation away, since RunQueryAsEnumerable simply performs /// an eval. -let TryDetectQueryQuoteAndRun cenv (expr: Expr) = +let TryDetectQueryQuoteAndRun cenv (expr: Expr) = let g = cenv.g + match expr with - | QueryRun g (bodyOfRun, reqdResultInfo) -> + | QueryRun g (bodyOfRun, reqdResultInfo) -> //printfn "found Query.Run" - match stripDebugPoints bodyOfRun with - | Expr.Quote (quotedExpr, _, true, _, _) -> // true = isFromQueryExpression - + match stripDebugPoints bodyOfRun with + | Expr.Quote(quotedExpr, _, true, _, _) -> // true = isFromQueryExpression // This traverses uses of query operators like query.Where and query.AverageBy until we're left with something familiar. // All these operators take the input IEnumerable 'seqSource' as the first argument. // - // When we find the 'core' of the query expression, then if that is using IEnumerable execution, + // When we find the 'core' of the query expression, then if that is using IEnumerable execution, // try to rewrite the core into combinators approximating the compiled form of seq { ... }, which in turn // are eligible for state-machine representation. If that fails, we still rewrite to combinator form. - let rec loopOuter (e: Expr) = - match stripDebugPoints e with + let rec loopOuter (e: Expr) = + match stripDebugPoints e with - | QueryFor g (qTy, _, resultElemTy, _, _) - | QuerySelect g (qTy, _, resultElemTy, _, _) - | QueryYield g (qTy, resultElemTy, _) - | QueryYieldFrom g (qTy, resultElemTy, _) - when typeEquiv g qTy (mkWoNullAppTy g.tcref_System_Collections_IEnumerable []) -> + | QueryFor g (qTy, _, resultElemTy, _, _) + | QuerySelect g (qTy, _, resultElemTy, _, _) + | QueryYield g (qTy, resultElemTy, _) + | QueryYieldFrom g (qTy, resultElemTy, _) when typeEquiv g qTy (mkWoNullAppTy g.tcref_System_Collections_IEnumerable []) -> - match tryRewriteToSeqCombinators g e with - | Some newSource -> + match tryRewriteToSeqCombinators g e with + | Some newSource -> //printfn "Eliminating because source is not IQueryable" - Some (mkCallSeq g newSource.Range resultElemTy (mkCallSeqDelay g newSource.Range resultElemTy (mkUnitDelayLambda g newSource.Range newSource) ), - Some(resultElemTy, qTy) ) - | None -> + Some( + mkCallSeq + g + newSource.Range + resultElemTy + (mkCallSeqDelay g newSource.Range resultElemTy (mkUnitDelayLambda g newSource.Range newSource)), + Some(resultElemTy, qTy) + ) + | None -> //printfn "Not compiling to state machines, but still optimizing the use of quotations away" - Some (e, None) + Some(e, None) - | AnyQueryBuilderOpTrans g (seqSource, replace) -> + | AnyQueryBuilderOpTrans g (seqSource, replace) -> match loopOuter seqSource with - | Some (newSeqSource, newSeqSourceIsEnumerableInfo) -> - let newSeqSourceAsQuerySource = - match newSeqSourceIsEnumerableInfo with - | Some (resultElemTy, qTy) -> mkCallNewQuerySource g newSeqSource.Range resultElemTy qTy newSeqSource + | Some(newSeqSource, newSeqSourceIsEnumerableInfo) -> + let newSeqSourceAsQuerySource = + match newSeqSourceIsEnumerableInfo with + | Some(resultElemTy, qTy) -> mkCallNewQuerySource g newSeqSource.Range resultElemTy qTy newSeqSource | None -> newSeqSource - Some (replace newSeqSourceAsQuerySource, None) + + Some(replace newSeqSourceAsQuerySource, None) | None -> None - | _ -> - None + | _ -> None let resultExprInfo = loopOuter quotedExpr match resultExprInfo with - | Some (resultExpr, exprIsEnumerableInfo) -> - let resultExprAfterConvertToResultTy = - match reqdResultInfo, exprIsEnumerableInfo with - | Some _, Some _ | None, None -> resultExpr // the expression is a QuerySource, the result is a QuerySource, nothing to do + | Some(resultExpr, exprIsEnumerableInfo) -> + let resultExprAfterConvertToResultTy = + match reqdResultInfo, exprIsEnumerableInfo with + | Some _, Some _ + | None, None -> resultExpr // the expression is a QuerySource, the result is a QuerySource, nothing to do | Some resultElemTy, None -> - let enumerableTy = TType_app(g.tcref_System_Collections_IEnumerable, [], g.knownWithoutNull) + let enumerableTy = + TType_app(g.tcref_System_Collections_IEnumerable, [], g.knownWithoutNull) + mkCallGetQuerySourceAsEnumerable g expr.Range resultElemTy enumerableTy resultExpr - | None, Some (resultElemTy, qTy) -> - mkCallNewQuerySource g expr.Range resultElemTy qTy resultExpr + | None, Some(resultElemTy, qTy) -> mkCallNewQuerySource g expr.Range resultElemTy qTy resultExpr + Some resultExprAfterConvertToResultTy - | None -> - None - - - | _ -> + | None -> None + + | _ -> //printfn "Not eliminating because no Quote found" None - | _ -> + | _ -> //printfn "Not eliminating because no Run found" None let IsILMethodRefSystemStringConcat (mref: ILMethodRef) = - mref.Name = "Concat" && - mref.DeclaringTypeRef.Name = "System.String" && - (mref.ReturnType.IsNominal && mref.ReturnType.TypeRef.Name = "System.String") && - (mref.ArgCount >= 2 && mref.ArgCount <= 4 && - mref.ArgTypes - |> List.forall (fun ilTy -> - ilTy.IsNominal && ilTy.TypeRef.Name = "System.String")) + mref.Name = "Concat" + && mref.DeclaringTypeRef.Name = "System.String" + && (mref.ReturnType.IsNominal && mref.ReturnType.TypeRef.Name = "System.String") + && (mref.ArgCount >= 2 + && mref.ArgCount <= 4 + && mref.ArgTypes + |> List.forall (fun ilTy -> ilTy.IsNominal && ilTy.TypeRef.Name = "System.String")) let IsILMethodRefSystemStringConcatArray (mref: ILMethodRef) = - mref.Name = "Concat" && - mref.DeclaringTypeRef.Name = "System.String" && - (mref.ReturnType.IsNominal && mref.ReturnType.TypeRef.Name = "System.String") && - (mref.ArgCount = 1 && - mref.ArgTypes - |> List.forall (fun ilTy -> - match ilTy with - | ILType.Array (shape, ilTy) when shape = ILArrayShape.SingleDimensional && - ilTy.IsNominal && - ilTy.TypeRef.Name = "System.String" -> true - | _ -> false)) + mref.Name = "Concat" + && mref.DeclaringTypeRef.Name = "System.String" + && (mref.ReturnType.IsNominal && mref.ReturnType.TypeRef.Name = "System.String") + && (mref.ArgCount = 1 + && mref.ArgTypes + |> List.forall (fun ilTy -> + match ilTy with + | ILType.Array(shape, ilTy) when + shape = ILArrayShape.SingleDimensional + && ilTy.IsNominal + && ilTy.TypeRef.Name = "System.String" + -> + true + | _ -> false)) let rec IsDebugPipeRightExpr cenv expr = let g = cenv.g + match expr with - | Expr.DebugPoint (_, innerExpr) -> IsDebugPipeRightExpr cenv innerExpr - | Expr.App _ -> + | Expr.DebugPoint(_, innerExpr) -> IsDebugPipeRightExpr cenv innerExpr + | Expr.App _ -> if cenv.settings.DebugPointsForPipeRight then match expr with - | OpPipeRight g _ - | OpPipeRight2 g _ - | OpPipeRight3 g _ -> true + | OpPipeRight g _ + | OpPipeRight2 g _ + | OpPipeRight3 g _ -> true | _ -> false - else false + else + false | _ -> false let inline IsStateMachineExpr g overallExpr = //printfn "%s" (DebugPrint.showExpr overallExpr) match overallExpr with - | Expr.App(funcExpr = Expr.Val(valRef = valRef)) -> - isReturnsResumableCodeTy g valRef.TauType + | Expr.App(funcExpr = Expr.Val(valRef = valRef)) -> isReturnsResumableCodeTy g valRef.TauType | _ -> false /// Optimize/analyze an expression let rec OptimizeExpr cenv (env: IncrementalOptimizationEnv) expr = - cenv.stackGuard.Guard <| fun () -> + cenv.stackGuard.Guard + <| fun () -> - let g = cenv.g + let g = cenv.g - // Eliminate subsumption coercions for functions. This must be done post-typechecking because we need - // complete inference types. - let expr = NormalizeAndAdjustPossibleSubsumptionExprs g expr + // Eliminate subsumption coercions for functions. This must be done post-typechecking because we need + // complete inference types. + let expr = NormalizeAndAdjustPossibleSubsumptionExprs g expr - let expr = stripExpr expr + let expr = stripExpr expr - if IsDebugPipeRightExpr cenv expr then OptimizeDebugPipeRights cenv env expr else + if IsDebugPipeRightExpr cenv expr then + OptimizeDebugPipeRights cenv env expr + else - let isStateMachineE = IsStateMachineExpr g expr + let isStateMachineE = IsStateMachineExpr g expr - let env = { env with disableMethodSplitting = env.disableMethodSplitting || isStateMachineE } + let env = + { env with + disableMethodSplitting = env.disableMethodSplitting || isStateMachineE + } - match expr with - // treat the common linear cases to avoid stack overflows, using an explicit continuation - | LinearOpExpr _ - | LinearMatchExpr _ - | Expr.Sequential _ - | Expr.DebugPoint _ - | Expr.Let _ -> - OptimizeLinearExpr cenv env expr id - - | Expr.Const (c, m, ty) -> - OptimizeConst cenv env expr (c, m, ty) - - | Expr.Val (v, _vFlags, m) -> - OptimizeVal cenv env expr (v, m) - - - | Expr.Quote (ast, splices, isFromQueryExpression, m, ty) -> - let doData data = map3Of4 (List.map (OptimizeExpr cenv env >> fst)) data - let splices = - match splices.Value with - | Some (data1, data2opt) -> Some (doData data1, doData data2opt) - | None -> None - Expr.Quote (ast, ref splices, isFromQueryExpression, m, ty), - { TotalSize = 10 - FunctionSize = 1 - HasEffect = false - MightMakeCriticalTailcall=false - Info=UnknownValue } + match expr with + // treat the common linear cases to avoid stack overflows, using an explicit continuation + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Sequential _ + | Expr.DebugPoint _ + | Expr.Let _ -> OptimizeLinearExpr cenv env expr id - | Expr.Obj (_, ty, basev, createExpr, overrides, iimpls, m) -> - match expr with - | NewDelegateExpr g (lambdaId, vsl, body, _, remake) -> - OptimizeNewDelegateExpr cenv env (lambdaId, vsl, body, remake) - | _ -> - OptimizeObjectExpr cenv env (ty, basev, createExpr, overrides, iimpls, m) + | Expr.Const(c, m, ty) -> OptimizeConst cenv env expr (c, m, ty) - | Expr.Op (op, tyargs, args, m) -> - OptimizeExprOp cenv env (op, tyargs, args, m) + | Expr.Val(v, _vFlags, m) -> OptimizeVal cenv env expr (v, m) - | Expr.App (f, fty, tyargs, argsl, m) -> - match expr with - | DelegateInvokeExpr g (delInvokeRef, delInvokeTy, tyargs, delExpr, delInvokeArg, m) -> - OptimizeFSharpDelegateInvoke cenv env (delInvokeRef, delExpr, delInvokeTy, tyargs, delInvokeArg, m) - | _ -> - let attempt = - if IsDebugPipeRightExpr cenv expr then - Some (OptimizeDebugPipeRights cenv env expr) - else None - match attempt with - | Some res -> res - | None -> - // eliminate uses of query - match TryDetectQueryQuoteAndRun cenv expr with - | Some newExpr -> OptimizeExpr cenv env newExpr - | None -> OptimizeApplication cenv env (f, fty, tyargs, argsl, m) - - | Expr.Lambda (_lambdaId, _, _, argvs, _body, m, bodyTy) -> - let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal) - let ty = mkMultiLambdaTy g m argvs bodyTy - OptimizeLambdas None cenv env valReprInfo expr ty - - | Expr.TyLambda (_lambdaId, tps, _body, _m, bodyTy) -> - let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) - let ty = mkForallTyIfNeeded tps bodyTy - OptimizeLambdas None cenv env valReprInfo expr ty - - | Expr.TyChoose _ -> - OptimizeExpr cenv env (ChooseTyparSolutionsForFreeChoiceTypars g cenv.amap expr) - - | Expr.Match (spMatch, mExpr, dtree, targets, m, ty) -> - OptimizeMatch cenv env (spMatch, mExpr, dtree, targets, m, ty) - - | Expr.LetRec (binds, bodyExpr, m, _) -> - OptimizeLetRec cenv env (binds, bodyExpr, m) - - | Expr.StaticOptimization (staticConditions, expr2, expr3, m) -> - let d = DecideStaticOptimizations g staticConditions false - if d = StaticOptimizationAnswer.Yes then OptimizeExpr cenv env expr2 - elif d = StaticOptimizationAnswer.No then OptimizeExpr cenv env expr3 - else - let expr2R, e2info = OptimizeExpr cenv env expr2 - let expr3R, e3info = OptimizeExpr cenv env expr3 - Expr.StaticOptimization (staticConditions, expr2R, expr3R, m), - { TotalSize = min e2info.TotalSize e3info.TotalSize - FunctionSize = min e2info.FunctionSize e3info.FunctionSize - HasEffect = e2info.HasEffect || e3info.HasEffect - MightMakeCriticalTailcall=e2info.MightMakeCriticalTailcall || e3info.MightMakeCriticalTailcall // seems conservative - Info= UnknownValue } - - | Expr.Link _eref -> - assert ("unexpected reclink" = "") - failwith "Unexpected reclink" - - | Expr.WitnessArg _ -> - expr, - { TotalSize = 10 - FunctionSize = 1 - HasEffect = false - MightMakeCriticalTailcall=false - Info=UnknownValue } + | Expr.Quote(ast, splices, isFromQueryExpression, m, ty) -> + let doData data = + map3Of4 (List.map (OptimizeExpr cenv env >> fst)) data + + let splices = + match splices.Value with + | Some(data1, data2opt) -> Some(doData data1, doData data2opt) + | None -> None + + Expr.Quote(ast, ref splices, isFromQueryExpression, m, ty), + { + TotalSize = 10 + FunctionSize = 1 + HasEffect = false + MightMakeCriticalTailcall = false + Info = UnknownValue + } + + | Expr.Obj(_, ty, basev, createExpr, overrides, iimpls, m) -> + match expr with + | NewDelegateExpr g (lambdaId, vsl, body, _, remake) -> OptimizeNewDelegateExpr cenv env (lambdaId, vsl, body, remake) + | _ -> OptimizeObjectExpr cenv env (ty, basev, createExpr, overrides, iimpls, m) + + | Expr.Op(op, tyargs, args, m) -> OptimizeExprOp cenv env (op, tyargs, args, m) + + | Expr.App(f, fty, tyargs, argsl, m) -> + match expr with + | DelegateInvokeExpr g (delInvokeRef, delInvokeTy, tyargs, delExpr, delInvokeArg, m) -> + OptimizeFSharpDelegateInvoke cenv env (delInvokeRef, delExpr, delInvokeTy, tyargs, delInvokeArg, m) + | _ -> + let attempt = + if IsDebugPipeRightExpr cenv expr then + Some(OptimizeDebugPipeRights cenv env expr) + else + None + + match attempt with + | Some res -> res + | None -> + // eliminate uses of query + match TryDetectQueryQuoteAndRun cenv expr with + | Some newExpr -> OptimizeExpr cenv env newExpr + | None -> OptimizeApplication cenv env (f, fty, tyargs, argsl, m) + + | Expr.Lambda(_lambdaId, _, _, argvs, _body, m, bodyTy) -> + let valReprInfo = + ValReprInfo([], [ argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1) ], ValReprInfo.unnamedRetVal) + + let ty = mkMultiLambdaTy g m argvs bodyTy + OptimizeLambdas None cenv env valReprInfo expr ty + + | Expr.TyLambda(_lambdaId, tps, _body, _m, bodyTy) -> + let valReprInfo = + ValReprInfo(ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) + + let ty = mkForallTyIfNeeded tps bodyTy + OptimizeLambdas None cenv env valReprInfo expr ty + + | Expr.TyChoose _ -> OptimizeExpr cenv env (ChooseTyparSolutionsForFreeChoiceTypars g cenv.amap expr) + + | Expr.Match(spMatch, mExpr, dtree, targets, m, ty) -> OptimizeMatch cenv env (spMatch, mExpr, dtree, targets, m, ty) + + | Expr.LetRec(binds, bodyExpr, m, _) -> OptimizeLetRec cenv env (binds, bodyExpr, m) + + | Expr.StaticOptimization(staticConditions, expr2, expr3, m) -> + let d = DecideStaticOptimizations g staticConditions false + + if d = StaticOptimizationAnswer.Yes then + OptimizeExpr cenv env expr2 + elif d = StaticOptimizationAnswer.No then + OptimizeExpr cenv env expr3 + else + let expr2R, e2info = OptimizeExpr cenv env expr2 + let expr3R, e3info = OptimizeExpr cenv env expr3 + + Expr.StaticOptimization(staticConditions, expr2R, expr3R, m), + { + TotalSize = min e2info.TotalSize e3info.TotalSize + FunctionSize = min e2info.FunctionSize e3info.FunctionSize + HasEffect = e2info.HasEffect || e3info.HasEffect + MightMakeCriticalTailcall = e2info.MightMakeCriticalTailcall || e3info.MightMakeCriticalTailcall // seems conservative + Info = UnknownValue + } + + | Expr.Link _eref -> + assert ("unexpected reclink" = "") + failwith "Unexpected reclink" + + | Expr.WitnessArg _ -> + expr, + { + TotalSize = 10 + FunctionSize = 1 + HasEffect = false + MightMakeCriticalTailcall = false + Info = UnknownValue + } /// Optimize/analyze an object expression and OptimizeObjectExpr cenv env (ty, baseValOpt, basecall, overrides, iimpls, m) = @@ -2463,43 +2869,61 @@ and OptimizeObjectExpr cenv env (ty, baseValOpt, basecall, overrides, iimpls, m) let overridesR, overrideinfos = OptimizeMethods cenv env baseValOpt overrides let iimplsR, iimplsinfos = OptimizeInterfaceImpls cenv env baseValOpt iimpls let exprR = mkObjExpr (ty, baseValOpt, basecallR, overridesR, iimplsR, m) - exprR, { TotalSize=closureTotalSize + basecallinfo.TotalSize + AddTotalSizes overrideinfos + AddTotalSizes iimplsinfos - FunctionSize=1 (* a newobj *) - HasEffect=true - MightMakeCriticalTailcall=false // creating an object is not a useful tailcall - Info=UnknownValue} + + exprR, + { + TotalSize = + closureTotalSize + + basecallinfo.TotalSize + + AddTotalSizes overrideinfos + + AddTotalSizes iimplsinfos + FunctionSize = 1 (* a newobj *) + HasEffect = true + MightMakeCriticalTailcall = false // creating an object is not a useful tailcall + Info = UnknownValue + } /// Optimize/analyze the methods that make up an object expression -and OptimizeMethods cenv env baseValOpt methods = +and OptimizeMethods cenv env baseValOpt methods = OptimizeList (OptimizeMethod cenv env baseValOpt) methods -and OptimizeMethod cenv env baseValOpt (TObjExprMethod(slotsig, attribs, tps, vs, e, m) as tmethod) = - let env = {env with latestBoundId=Some tmethod.Id; functionVal = None} +and OptimizeMethod cenv env baseValOpt (TObjExprMethod(slotsig, attribs, tps, vs, e, m) as tmethod) = + let env = + { env with + latestBoundId = Some tmethod.Id + functionVal = None + } + let env = BindTyparsToUnknown tps env let env = BindInternalValsToUnknown cenv vs env let env = Option.foldBack (BindInternalValToUnknown cenv) baseValOpt env let eR, einfo = OptimizeExpr cenv env e // Note: if we ever change this from being UnknownValue then we should call AbstractExprInfoByVars - TObjExprMethod(slotsig, attribs, tps, vs, eR, m), - { TotalSize = einfo.TotalSize - FunctionSize = 0 - HasEffect = false - MightMakeCriticalTailcall=false - Info=UnknownValue} + TObjExprMethod(slotsig, attribs, tps, vs, eR, m), + { + TotalSize = einfo.TotalSize + FunctionSize = 0 + HasEffect = false + MightMakeCriticalTailcall = false + Info = UnknownValue + } /// Optimize/analyze the interface implementations that form part of an object expression -and OptimizeInterfaceImpls cenv env baseValOpt iimpls = +and OptimizeInterfaceImpls cenv env baseValOpt iimpls = OptimizeList (OptimizeInterfaceImpl cenv env baseValOpt) iimpls /// Optimize/analyze the interface implementations that form part of an object expression -and OptimizeInterfaceImpl cenv env baseValOpt (ty, overrides) = +and OptimizeInterfaceImpl cenv env baseValOpt (ty, overrides) = let overridesR, overridesinfos = OptimizeMethods cenv env baseValOpt overrides - (ty, overridesR), - { TotalSize = AddTotalSizes overridesinfos - FunctionSize = 1 - HasEffect = false - MightMakeCriticalTailcall=false - Info=UnknownValue} + + (ty, overridesR), + { + TotalSize = AddTotalSizes overridesinfos + FunctionSize = 1 + HasEffect = false + MightMakeCriticalTailcall = false + Info = UnknownValue + } /// Make and optimize String.Concat calls and MakeOptimizedSystemStringConcatCall cenv env m args = @@ -2507,115 +2931,134 @@ and MakeOptimizedSystemStringConcatCall cenv env m args = let rec optimizeArg argExpr accArgs = match argExpr, accArgs with - | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, [ Expr.Op(TOp.Array, _, args, _) ], _), _ - when IsILMethodRefSystemStringConcatArray ilMethRef -> + | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, [ Expr.Op(TOp.Array, _, args, _) ], _), _ when + IsILMethodRefSystemStringConcatArray ilMethRef + -> optimizeArgs args accArgs - | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, args, _), _ - when IsILMethodRefSystemStringConcat ilMethRef -> + | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, args, _), _ when IsILMethodRefSystemStringConcat ilMethRef -> optimizeArgs args accArgs | arg, _ -> arg :: accArgs and optimizeArgs args accArgs = - (args, accArgs) - ||> List.foldBack (optimizeArg) + (args, accArgs) ||> List.foldBack (optimizeArg) let args = optimizeArgs args [] let expr = match args with - | [ arg ] -> - arg - | [ arg1; arg2 ] -> - mkStaticCall_String_Concat2 g m arg1 arg2 - | [ arg1; arg2; arg3 ] -> - mkStaticCall_String_Concat3 g m arg1 arg2 arg3 - | [ arg1; arg2; arg3; arg4 ] -> - mkStaticCall_String_Concat4 g m arg1 arg2 arg3 arg4 + | [ arg ] -> arg + | [ arg1; arg2 ] -> mkStaticCall_String_Concat2 g m arg1 arg2 + | [ arg1; arg2; arg3 ] -> mkStaticCall_String_Concat3 g m arg1 arg2 arg3 + | [ arg1; arg2; arg3; arg4 ] -> mkStaticCall_String_Concat4 g m arg1 arg2 arg3 arg4 | args -> let arg = mkArray (g.string_ty, args, m) mkStaticCall_String_Concat_Array g m arg match expr with - | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _) as op, tyargs, args, m) - when IsILMethodRefSystemStringConcat ilMethRef || IsILMethodRefSystemStringConcatArray ilMethRef -> + | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _) as op, tyargs, args, m) when + IsILMethodRefSystemStringConcat ilMethRef + || IsILMethodRefSystemStringConcatArray ilMethRef + -> OptimizeExprOpReductions cenv env (op, tyargs, args, m) - | _ -> - OptimizeExpr cenv env expr + | _ -> OptimizeExpr cenv env expr /// Optimize/analyze an application of an intrinsic operator to arguments and OptimizeExprOp cenv env (op, tyargs, args, m) = let g = cenv.g - // Special cases - match op, tyargs, args with - | TOp.Coerce, [tgtTy; srcTy], [arg] -> + // Special cases + match op, tyargs, args with + | TOp.Coerce, [ tgtTy; srcTy ], [ arg ] -> let argR, einfo = OptimizeExpr cenv env arg - if typeEquiv g tgtTy srcTy then argR, einfo - else - mkCoerceExpr(argR, tgtTy, m, srcTy), - { TotalSize=einfo.TotalSize + 1 - FunctionSize=einfo.FunctionSize + 1 - HasEffect = true - MightMakeCriticalTailcall=false - Info=UnknownValue } - - // Handle address-of - | TOp.LValueOp (LAddrOf _ as lop, lv), _, _ -> + + if typeEquiv g tgtTy srcTy then + argR, einfo + else + mkCoerceExpr (argR, tgtTy, m, srcTy), + { + TotalSize = einfo.TotalSize + 1 + FunctionSize = einfo.FunctionSize + 1 + HasEffect = true + MightMakeCriticalTailcall = false + Info = UnknownValue + } + + // Handle address-of + | TOp.LValueOp(LAddrOf _ as lop, lv), _, _ -> let newVal, _ = OptimizeExpr cenv env (exprForValRef m lv) + let newOp = match newVal with // Do not optimize if it's a top level static binding. - | Expr.Val (v, _, _) when not v.IsCompiledAsTopLevel -> TOp.LValueOp (lop, v) + | Expr.Val(v, _, _) when not v.IsCompiledAsTopLevel -> TOp.LValueOp(lop, v) | _ -> op - let newExpr = Expr.Op (newOp, tyargs, args, m) - newExpr, - { TotalSize = 1 - FunctionSize = 1 - HasEffect = OpHasEffect g m newOp - MightMakeCriticalTailcall = false - Info = ValueOfExpr newExpr } - // Handle these as special cases since mutables are allowed inside their bodies - | TOp.While (spWhile, marker), _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)] -> - OptimizeWhileLoop cenv { env with disableMethodSplitting=true } (spWhile, marker, e1, e2, m) + let newExpr = Expr.Op(newOp, tyargs, args, m) - | TOp.IntegerForLoop (spFor, spTo, dir), _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [v], e3, _, _)] -> - OptimizeFastIntegerForLoop cenv { env with disableMethodSplitting=true } (spFor, spTo, v, e1, dir, e2, e3, m) + newExpr, + { + TotalSize = 1 + FunctionSize = 1 + HasEffect = OpHasEffect g m newOp + MightMakeCriticalTailcall = false + Info = ValueOfExpr newExpr + } - | TOp.TryFinally (spTry, spFinally), [resty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> + // Handle these as special cases since mutables are allowed inside their bodies + | TOp.While(spWhile, marker), _, [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ] -> + OptimizeWhileLoop + cenv + { env with + disableMethodSplitting = true + } + (spWhile, marker, e1, e2, m) + + | TOp.IntegerForLoop(spFor, spTo, dir), + _, + [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _); Expr.Lambda(_, _, _, [ v ], e3, _, _) ] -> + OptimizeFastIntegerForLoop + cenv + { env with + disableMethodSplitting = true + } + (spFor, spTo, v, e1, dir, e2, e3, m) + + | TOp.TryFinally(spTry, spFinally), [ resty ], [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ] -> OptimizeTryFinally cenv env (spTry, spFinally, e1, e2, m, resty) - | TOp.TryWith (spTry, spWith), [resty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [vf], ef, _, _); Expr.Lambda (_, _, _, [vh], eh, _, _)] -> + | TOp.TryWith(spTry, spWith), + [ resty ], + [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ vf ], ef, _, _); Expr.Lambda(_, _, _, [ vh ], eh, _, _) ] -> OptimizeTryWith cenv env (e1, vf, ef, vh, eh, m, resty, spTry, spWith) - | TOp.TraitCall traitInfo, [], args -> - OptimizeTraitCall cenv env (traitInfo, args, m) + | TOp.TraitCall traitInfo, [], args -> OptimizeTraitCall cenv env (traitInfo, args, m) - // This code hooks arr.Length. The idea is to ensure loops end up in the "same shape"as the forms of loops that the .NET JIT - // guarantees to optimize. - - | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, _, _, _), _, [arg] - when (ilMethRef.DeclaringTypeRef.Name = g.ilg.typ_Array.TypeRef.Name && - ilMethRef.Name = "get_Length" && - isArray1DTy g (tyOfExpr g arg)) -> - OptimizeExpr cenv env (Expr.Op (TOp.ILAsm (i_ldlen, [g.int_ty]), [], [arg], m)) + // This code hooks arr.Length. The idea is to ensure loops end up in the "same shape"as the forms of loops that the .NET JIT + // guarantees to optimize. - // Empty IL instruction lists are used as casts in prim-types.fs. But we can get rid of them - // if the types match up. - | TOp.ILAsm ([], [ty]), _, [a] when typeEquiv g (tyOfExpr g a) ty -> OptimizeExpr cenv env a + | TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, [ arg ] when + (ilMethRef.DeclaringTypeRef.Name = g.ilg.typ_Array.TypeRef.Name + && ilMethRef.Name = "get_Length" + && isArray1DTy g (tyOfExpr g arg)) + -> + OptimizeExpr cenv env (Expr.Op(TOp.ILAsm(i_ldlen, [ g.int_ty ]), [], [ arg ], m)) + + // Empty IL instruction lists are used as casts in prim-types.fs. But we can get rid of them + // if the types match up. + | TOp.ILAsm([], [ ty ]), _, [ a ] when typeEquiv g (tyOfExpr g a) ty -> OptimizeExpr cenv env a // Optimize calls when concatenating strings, e.g. "1" + "2" + "3" + "4" .. etc. - | TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, [ Expr.Op(TOp.Array, _, args, _) ] - when IsILMethodRefSystemStringConcatArray ilMethRef -> + | TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, [ Expr.Op(TOp.Array, _, args, _) ] when + IsILMethodRefSystemStringConcatArray ilMethRef + -> MakeOptimizedSystemStringConcatCall cenv env m args - | TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, args - when IsILMethodRefSystemStringConcat ilMethRef -> + | TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), _, args when IsILMethodRefSystemStringConcat ilMethRef -> MakeOptimizedSystemStringConcatCall cenv env m args - | _ -> + | _ -> // Reductions OptimizeExprOpReductions cenv env (op, tyargs, args, m) @@ -2624,15 +3067,16 @@ and OptimizeExprOpReductions cenv env (op, tyargs, args, m) = OptimizeExprOpReductionsAfter cenv env (op, tyargs, argsR, arginfos, m) and OptimizeExprOpReductionsAfter cenv env (op, tyargs, argsR, arginfos, m) = - let knownValue = - match op, arginfos with - | TOp.ValFieldGet rf, [e1info] -> TryOptimizeRecordFieldGet cenv env (e1info, rf, tyargs, m) - | TOp.TupleFieldGet (tupInfo, n), [e1info] -> TryOptimizeTupleFieldGet cenv env (tupInfo, e1info, tyargs, n, m) - | TOp.UnionCaseFieldGet (cspec, n), [e1info] -> TryOptimizeUnionCaseGet cenv env (e1info, cspec, tyargs, n, m) + let knownValue = + match op, arginfos with + | TOp.ValFieldGet rf, [ e1info ] -> TryOptimizeRecordFieldGet cenv env (e1info, rf, tyargs, m) + | TOp.TupleFieldGet(tupInfo, n), [ e1info ] -> TryOptimizeTupleFieldGet cenv env (tupInfo, e1info, tyargs, n, m) + | TOp.UnionCaseFieldGet(cspec, n), [ e1info ] -> TryOptimizeUnionCaseGet cenv env (e1info, cspec, tyargs, n, m) | _ -> None - match knownValue with - | Some value_ -> - match TryOptimizeVal cenv env (None, false, false, value_, m) with + + match knownValue with + | Some value_ -> + match TryOptimizeVal cenv env (None, false, false, value_, m) with | Some res -> OptimizeExpr cenv env res (* discard e1 since guard ensures it has no effects *) | None -> OptimizeExprOpFallback cenv env (op, tyargs, argsR, m) arginfos value_ | None -> OptimizeExprOpFallback cenv env (op, tyargs, argsR, m) arginfos UnknownValue @@ -2640,112 +3084,144 @@ and OptimizeExprOpReductionsAfter cenv env (op, tyargs, argsR, arginfos, m) = and OptimizeExprOpFallback cenv env (op, tyargs, argsR, m) arginfos value_ = let g = cenv.g - // The generic case - we may collect information, but the construction/projection doesn't disappear + // The generic case - we may collect information, but the construction/projection doesn't disappear let argsTSize = AddTotalSizes arginfos let argsFSize = AddFunctionSizes arginfos let argEffects = OrEffects arginfos let argValues = List.map (fun x -> x.Info) arginfos let effect = OpHasEffect g m op - let cost, value_ = - match op with - | TOp.UnionCase c -> 2, MakeValueInfoForUnionCase c (Array.ofList argValues) - | TOp.ExnConstr _ -> 2, value_ - - | TOp.Tuple tupInfo -> - let isStruct = evalTupInfoIsStruct tupInfo - if isStruct then 0, value_ - else 1,MakeValueInfoForTuple (Array.ofList argValues) - - | TOp.AnonRecd anonInfo -> - let isStruct = evalAnonInfoIsStruct anonInfo - if isStruct then 0, value_ - else 1, value_ - - | TOp.AnonRecdGet _ - | TOp.ValFieldGet _ - | TOp.TupleFieldGet _ - | TOp.UnionCaseFieldGet _ - | TOp.ExnFieldGet _ - | TOp.UnionCaseTagGet _ -> - // REVIEW: reduction possible here, and may be very effective - 1, value_ - - | TOp.UnionCaseProof _ -> - // We count the proof as size 0 - // We maintain the value of the source of the proof-cast if it is known to be a UnionCaseValue - let value_ = - match argValues[0] with - | StripUnionCaseValue (uc, info) -> UnionCaseValue(uc, info) - | _ -> value_ - 0, value_ - - | TOp.ILAsm (instrs, retTypes) -> - min instrs.Length 1, - mkAssemblyCodeValueInfo g instrs argValues retTypes - - | TOp.Bytes bytes -> bytes.Length/10, value_ - | TOp.UInt16s bytes -> bytes.Length/10, value_ - | TOp.ValFieldGetAddr _ - | TOp.Array | TOp.IntegerForLoop _ | TOp.While _ | TOp.TryWith _ | TOp.TryFinally _ - | TOp.ILCall _ | TOp.TraitCall _ | TOp.LValueOp _ | TOp.ValFieldSet _ - | TOp.UnionCaseFieldSet _ | TOp.RefAddrGet _ | TOp.Coerce | TOp.Reraise - | TOp.UnionCaseFieldGetAddr _ - | TOp.ExnFieldSet _ -> 1, value_ - - | TOp.Recd (ctorInfo, tcref) -> - let finfos = tcref.AllInstanceFieldsAsList - // REVIEW: this seems a little conservative: Allocating a record with a mutable field - // is not an effect - only reading or writing the field is. - let value_ = - match ctorInfo with - | RecdExprIsObjInit -> UnknownValue - | RecdExpr -> - if argValues.Length <> finfos.Length then value_ - else MakeValueInfoForRecord tcref (Array.ofList ((argValues, finfos) ||> List.map2 (fun x f -> if f.IsMutable then UnknownValue else x) )) - 2, value_ - | TOp.Goto _ | TOp.Label _ | TOp.Return -> assert false; error(InternalError("unexpected goto/label/return in optimization", m)) + + let cost, value_ = + match op with + | TOp.UnionCase c -> 2, MakeValueInfoForUnionCase c (Array.ofList argValues) + | TOp.ExnConstr _ -> 2, value_ + + | TOp.Tuple tupInfo -> + let isStruct = evalTupInfoIsStruct tupInfo + + if isStruct then + 0, value_ + else + 1, MakeValueInfoForTuple(Array.ofList argValues) + + | TOp.AnonRecd anonInfo -> + let isStruct = evalAnonInfoIsStruct anonInfo + if isStruct then 0, value_ else 1, value_ + + | TOp.AnonRecdGet _ + | TOp.ValFieldGet _ + | TOp.TupleFieldGet _ + | TOp.UnionCaseFieldGet _ + | TOp.ExnFieldGet _ + | TOp.UnionCaseTagGet _ -> + // REVIEW: reduction possible here, and may be very effective + 1, value_ + + | TOp.UnionCaseProof _ -> + // We count the proof as size 0 + // We maintain the value of the source of the proof-cast if it is known to be a UnionCaseValue + let value_ = + match argValues[0] with + | StripUnionCaseValue(uc, info) -> UnionCaseValue(uc, info) + | _ -> value_ + + 0, value_ + + | TOp.ILAsm(instrs, retTypes) -> min instrs.Length 1, mkAssemblyCodeValueInfo g instrs argValues retTypes + + | TOp.Bytes bytes -> bytes.Length / 10, value_ + | TOp.UInt16s bytes -> bytes.Length / 10, value_ + | TOp.ValFieldGetAddr _ + | TOp.Array + | TOp.IntegerForLoop _ + | TOp.While _ + | TOp.TryWith _ + | TOp.TryFinally _ + | TOp.ILCall _ + | TOp.TraitCall _ + | TOp.LValueOp _ + | TOp.ValFieldSet _ + | TOp.UnionCaseFieldSet _ + | TOp.RefAddrGet _ + | TOp.Coerce + | TOp.Reraise + | TOp.UnionCaseFieldGetAddr _ + | TOp.ExnFieldSet _ -> 1, value_ + + | TOp.Recd(ctorInfo, tcref) -> + let finfos = tcref.AllInstanceFieldsAsList + // REVIEW: this seems a little conservative: Allocating a record with a mutable field + // is not an effect - only reading or writing the field is. + let value_ = + match ctorInfo with + | RecdExprIsObjInit -> UnknownValue + | RecdExpr -> + if argValues.Length <> finfos.Length then + value_ + else + MakeValueInfoForRecord + tcref + (Array.ofList ( + (argValues, finfos) + ||> List.map2 (fun x f -> if f.IsMutable then UnknownValue else x) + )) + + 2, value_ + | TOp.Goto _ + | TOp.Label _ + | TOp.Return -> + assert false + error (InternalError("unexpected goto/label/return in optimization", m)) // Indirect calls to IL code are always taken as tailcalls - let mayBeCriticalTailcall = + let mayBeCriticalTailcall = match op with - | TOp.ILCall (isVirtual, _, isCtor, _, _, _, _, _, _, _, _) -> not isCtor && isVirtual + | TOp.ILCall(isVirtual, _, isCtor, _, _, _, _, _, _, _, _) -> not isCtor && isVirtual | _ -> false - - let vinfo = { TotalSize=argsTSize + cost - FunctionSize=argsFSize + cost - HasEffect=argEffects || effect - MightMakeCriticalTailcall= mayBeCriticalTailcall // discard tailcall info for args - these are not in tailcall position - Info=value_ } - - // Replace entire expression with known value? - match TryOptimizeValInfo cenv env m vinfo with + + let vinfo = + { + TotalSize = argsTSize + cost + FunctionSize = argsFSize + cost + HasEffect = argEffects || effect + MightMakeCriticalTailcall = mayBeCriticalTailcall // discard tailcall info for args - these are not in tailcall position + Info = value_ + } + + // Replace entire expression with known value? + match TryOptimizeValInfo cenv env m vinfo with | Some res -> res, vinfo | None -> - Expr.Op (op, tyargs, argsR, m), - { TotalSize=argsTSize + cost - FunctionSize=argsFSize + cost - HasEffect=argEffects || effect - MightMakeCriticalTailcall= mayBeCriticalTailcall // discard tailcall info for args - these are not in tailcall position - Info=value_ } + Expr.Op(op, tyargs, argsR, m), + { + TotalSize = argsTSize + cost + FunctionSize = argsFSize + cost + HasEffect = argEffects || effect + MightMakeCriticalTailcall = mayBeCriticalTailcall // discard tailcall info for args - these are not in tailcall position + Info = value_ + } /// Optimize/analyze a constant node -and OptimizeConst cenv env expr (c, m, ty) = +and OptimizeConst cenv env expr (c, m, ty) = let g = cenv.g - match TryEliminateDesugaredConstants g m c with - | Some e -> - OptimizeExpr cenv env e + match TryEliminateDesugaredConstants g m c with + | Some e -> OptimizeExpr cenv env e | None -> - expr, { TotalSize=(match c with - | Const.String b -> b.Length/10 - | _ -> 0) - FunctionSize=0 - HasEffect=false - MightMakeCriticalTailcall=false - Info=MakeValueInfoForConst c ty} - -/// Optimize/analyze a record lookup. -and TryOptimizeRecordFieldGet cenv _env (e1info, (RecdFieldRef (rtcref, _) as r), _tinst, m) = + expr, + { + TotalSize = + (match c with + | Const.String b -> b.Length / 10 + | _ -> 0) + FunctionSize = 0 + HasEffect = false + MightMakeCriticalTailcall = false + Info = MakeValueInfoForConst c ty + } + +/// Optimize/analyze a record lookup. +and TryOptimizeRecordFieldGet cenv _env (e1info, (RecdFieldRef(rtcref, _) as r), _tinst, m) = let g = cenv.g match destRecdValue e1info.Info with @@ -2754,24 +3230,39 @@ and TryOptimizeRecordFieldGet cenv _env (e1info, (RecdFieldRef (rtcref, _) as r) | Some _ -> None | None -> let n = r.Index - if n >= finfos.Length then errorR(InternalError( "TryOptimizeRecordFieldGet: term argument out of range", m)) + + if n >= finfos.Length then + errorR (InternalError("TryOptimizeRecordFieldGet: term argument out of range", m)) + Some finfos[n] | _ -> None - + and TryOptimizeTupleFieldGet cenv _env (_tupInfo, e1info, tys, n, m) = match destTupleValue e1info.Info with | Some tups when cenv.settings.EliminateTupleFieldGet && not e1info.HasEffect -> - let len = tups.Length - if len <> tys.Length then errorR(InternalError("error: tuple lengths don't match", m)) - if n >= len then errorR(InternalError("TryOptimizeTupleFieldGet: tuple index out of range", m)) + let len = tups.Length + + if len <> tys.Length then + errorR (InternalError("error: tuple lengths don't match", m)) + + if n >= len then + errorR (InternalError("TryOptimizeTupleFieldGet: tuple index out of range", m)) + Some tups[n] | _ -> None - + and TryOptimizeUnionCaseGet cenv _env (e1info, cspec, _tys, n, m) = let g = cenv.g + match e1info.Info with - | StripUnionCaseValue(cspec2, args) when cenv.settings.EliminateUnionCaseFieldGet() && not e1info.HasEffect && g.unionCaseRefEq cspec cspec2 -> - if n >= args.Length then errorR(InternalError( "TryOptimizeUnionCaseGet: term argument out of range", m)) + | StripUnionCaseValue(cspec2, args) when + cenv.settings.EliminateUnionCaseFieldGet() + && not e1info.HasEffect + && g.unionCaseRefEq cspec cspec2 + -> + if n >= args.Length then + errorR (InternalError("TryOptimizeUnionCaseGet: term argument out of range", m)) + Some args[n] | _ -> None @@ -2779,67 +3270,86 @@ and TryOptimizeUnionCaseGet cenv _env (e1info, cspec, _tys, n, m) = and OptimizeFastIntegerForLoop cenv env (spFor, spTo, v, e1, dir, e2, e3, m) = let g = cenv.g - let e1R, e1info = OptimizeExpr cenv env e1 - let e2R, e2info = OptimizeExpr cenv env e2 - let env = BindInternalValToUnknown cenv v env - let e3R, e3info = OptimizeExpr cenv env e3 + let e1R, e1info = OptimizeExpr cenv env e1 + let e2R, e2info = OptimizeExpr cenv env e2 + let env = BindInternalValToUnknown cenv v env + let e3R, e3info = OptimizeExpr cenv env e3 // Try to replace F#-style loops with C# style loops that recompute their bounds but which are compiled more efficiently by the JITs, e.g. // F# "for x = 0 to arr.Length - 1 do ..." --> C# "for (int x = 0; x < arr.Length; x++) { ... }" // F# "for x = 0 to 10 do ..." --> C# "for (int x = 0; x < 11; x++) { ... }" - let e2R, dir = - match dir, e2R with + let e2R, dir = + match dir, e2R with // detect upwards for loops with bounds of the form "arr.Length - 1" and convert them to a C#-style for loop - | FSharpForLoopUp, Expr.Op (TOp.ILAsm ([ (AI_sub | AI_sub_ovf)], _), _, [Expr.Op (TOp.ILAsm ([ I_ldlen; (AI_conv DT_I4)], _), _, [arre], _); Expr.Const (Const.Int32 1, _, _)], _) - when not (snd(OptimizeExpr cenv env arre)).HasEffect -> + | FSharpForLoopUp, + Expr.Op(TOp.ILAsm([ (AI_sub | AI_sub_ovf) ], _), + _, + [ Expr.Op(TOp.ILAsm([ I_ldlen; (AI_conv DT_I4) ], _), _, [ arre ], _); Expr.Const(Const.Int32 1, _, _) ], + _) when not (snd (OptimizeExpr cenv env arre)).HasEffect -> mkLdlen g e2R.Range arre, CSharpForLoopUp - | FSharpForLoopUp, Expr.Op (TOp.ILAsm ([ (AI_sub | AI_sub_ovf)], _), _, [Expr.Op (TOp.ILCall(_,_,_,_,_,_,_, mth, _,_,_), _, [arre], _) as lenOp; Expr.Const (Const.Int32 1, _, _)], _) - when - mth.Name = "get_Length" && (mth.DeclaringTypeRef.FullName = "System.Span`1" || mth.DeclaringTypeRef.FullName = "System.ReadOnlySpan`1") - && not (snd(OptimizeExpr cenv env arre)).HasEffect -> + | FSharpForLoopUp, + Expr.Op(TOp.ILAsm([ (AI_sub | AI_sub_ovf) ], _), + _, + [ Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, mth, _, _, _), _, [ arre ], _) as lenOp; Expr.Const(Const.Int32 1, _, _) ], + _) when + mth.Name = "get_Length" + && (mth.DeclaringTypeRef.FullName = "System.Span`1" + || mth.DeclaringTypeRef.FullName = "System.ReadOnlySpan`1") + && not (snd (OptimizeExpr cenv env arre)).HasEffect + -> lenOp, CSharpForLoopUp - // detect upwards for loops with constant bounds, but not MaxValue! - | FSharpForLoopUp, Expr.Const (Const.Int32 n, _, _) - when n < System.Int32.MaxValue -> - mkIncr g e2R.Range e2R, CSharpForLoopUp + | FSharpForLoopUp, Expr.Const(Const.Int32 n, _, _) when n < System.Int32.MaxValue -> mkIncr g e2R.Range e2R, CSharpForLoopUp - | _ -> - e2R, dir - - let einfos = [e1info;e2info;e3info] - let eff = OrEffects einfos + | _ -> e2R, dir + + let einfos = [ e1info; e2info; e3info ] + let eff = OrEffects einfos (* neither bounds nor body has an effect, and loops always terminate, hence eliminate the loop *) - if cenv.settings.EliminateForLoop && not eff then - mkUnit g m, { TotalSize=0; FunctionSize=0; HasEffect=false; MightMakeCriticalTailcall=false; Info=UnknownValue } + if cenv.settings.EliminateForLoop && not eff then + mkUnit g m, + { + TotalSize = 0 + FunctionSize = 0 + HasEffect = false + MightMakeCriticalTailcall = false + Info = UnknownValue + } else - let exprR = mkIntegerForLoop g (spFor, spTo, v, e1R, dir, e2R, e3R, m) - exprR, { TotalSize=AddTotalSizes einfos + forAndWhileLoopSize - FunctionSize=AddFunctionSizes einfos + forAndWhileLoopSize - HasEffect=eff - MightMakeCriticalTailcall=false - Info=UnknownValue } + let exprR = mkIntegerForLoop g (spFor, spTo, v, e1R, dir, e2R, e3R, m) + + exprR, + { + TotalSize = AddTotalSizes einfos + forAndWhileLoopSize + FunctionSize = AddFunctionSizes einfos + forAndWhileLoopSize + HasEffect = eff + MightMakeCriticalTailcall = false + Info = UnknownValue + } /// Optimize/analyze a set of recursive bindings and OptimizeLetRec cenv env (binds, bodyExpr, m) = - let vs = binds |> List.map (fun v -> v.Var) - let env = BindInternalValsToUnknown cenv vs env - let bindsR, env = OptimizeBindings cenv true env binds - let bodyExprR, einfo = OptimizeExpr cenv env bodyExpr - // REVIEW: graph analysis to determine which items are unused - // Eliminate any unused bindings, as in let case - let bindsRR, bindinfos = - let fvs0 = freeInExpr CollectLocals bodyExprR - let fvs = List.fold (fun acc x -> unionFreeVars acc (fst x |> freeInBindingRhs CollectLocals)) fvs0 bindsR + let vs = binds |> List.map (fun v -> v.Var) + let env = BindInternalValsToUnknown cenv vs env + let bindsR, env = OptimizeBindings cenv true env binds + let bodyExprR, einfo = OptimizeExpr cenv env bodyExpr + // REVIEW: graph analysis to determine which items are unused + // Eliminate any unused bindings, as in let case + let bindsRR, bindinfos = + let fvs0 = freeInExpr CollectLocals bodyExprR + + let fvs = + List.fold (fun acc x -> unionFreeVars acc (fst x |> freeInBindingRhs CollectLocals)) fvs0 bindsR + SplitValuesByIsUsedOrHasEffect cenv (fun () -> fvs.FreeLocals) bindsR - // Trim out any optimization info that involves escaping values - let evalueR = AbstractExprInfoByVars (vs, []) einfo.Info - // REVIEW: size of constructing new closures - should probably add #freevars + #recfixups here - let bodyExprR = Expr.LetRec (bindsRR, bodyExprR, m, Construct.NewFreeVarsCache()) - let info = CombineValueInfos (einfo :: bindinfos) evalueR + // Trim out any optimization info that involves escaping values + let evalueR = AbstractExprInfoByVars (vs, []) einfo.Info + // REVIEW: size of constructing new closures - should probably add #freevars + #recfixups here + let bodyExprR = Expr.LetRec(bindsRR, bodyExprR, m, Construct.NewFreeVarsCache()) + let info = CombineValueInfos (einfo :: bindinfos) evalueR bodyExprR, info /// Optimize/analyze a linear sequence of sequential execution or RletR bindings. @@ -2850,150 +3360,209 @@ and OptimizeLinearExpr cenv env expr contf = // Eliminate subsumption coercions for functions. This must be done post-typechecking because we need // complete inference types. let expr = DetectAndOptimizeForEachExpression g OptimizeAllForExpressions expr - let expr = if cenv.settings.ExpandStructuralValues() then ExpandStructuralBinding cenv expr else expr + + let expr = + if cenv.settings.ExpandStructuralValues() then + ExpandStructuralBinding cenv expr + else + expr + let expr = stripExpr expr - // Matching on 'match __resumableEntry() with ...` is really a first-class language construct which we + // Matching on 'match __resumableEntry() with ...` is really a first-class language construct which we // don't optimize separately - match expr with - | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, rebuild) -> - let noneBranchExprR, e1info = OptimizeExpr cenv env noneBranchExpr - let env = BindInternalValToUnknown cenv someVar env - let someBranchExprR, e2info = OptimizeExpr cenv env someBranchExpr + match expr with + | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, rebuild) -> + let noneBranchExprR, e1info = OptimizeExpr cenv env noneBranchExpr + let env = BindInternalValToUnknown cenv someVar env + let someBranchExprR, e2info = OptimizeExpr cenv env someBranchExpr let exprR = rebuild (noneBranchExprR, someBranchExprR) - let infoR = - { TotalSize = e1info.TotalSize + e2info.TotalSize - FunctionSize = e1info.FunctionSize + e2info.FunctionSize - HasEffect = true - MightMakeCriticalTailcall = false - Info = UnknownValue } + + let infoR = + { + TotalSize = e1info.TotalSize + e2info.TotalSize + FunctionSize = e1info.FunctionSize + e2info.FunctionSize + HasEffect = true + MightMakeCriticalTailcall = false + Info = UnknownValue + } + contf (exprR, infoR) - | _ -> - - match expr with - | Expr.Sequential (e1, e2, flag, m) -> - - let e1R, e1info = OptimizeExpr cenv env e1 - - OptimizeLinearExpr cenv env e2 (contf << (fun (e2R, e2info) -> - if (flag = NormalSeq) && - // Always eliminate '(); expr' sequences, even in debug code, to ensure that - // conditional method calls don't leave a dangling breakpoint (see FSharp 1.0 bug 6034) - (cenv.settings.EliminateSequential || (match stripDebugPoints e1R with Expr.Const (Const.Unit, _, _) -> true | _ -> false)) && - not e1info.HasEffect then - e2R, e2info - else - Expr.Sequential (e1R, e2R, flag, m), - { TotalSize = e1info.TotalSize + e2info.TotalSize - FunctionSize = e1info.FunctionSize + e2info.FunctionSize - HasEffect = flag <> NormalSeq || e1info.HasEffect || e2info.HasEffect - MightMakeCriticalTailcall = - (if flag = NormalSeq then e2info.MightMakeCriticalTailcall - else e1info.MightMakeCriticalTailcall || e2info.MightMakeCriticalTailcall) - // can't propagate value: must access result of computation for its effects - Info = UnknownValue })) - - | Expr.Let (bind, body, m, _) -> - - let (bindR, bindingInfo), env = OptimizeBinding cenv false env bind - - OptimizeLinearExpr cenv env body (contf << (fun (bodyR, bodyInfo) -> - // PERF: This call to ValueIsUsedOrHasEffect/freeInExpr amounts to 9% of all optimization time. - // Is it quadratic or quasi-quadratic? - if ValueIsUsedOrHasEffect cenv (fun () -> (freeInExpr (CollectLocalsWithStackGuard()) bodyR).FreeLocals) (bindR, bindingInfo) then - // Eliminate let bindings on the way back up - let exprR, adjust = TryEliminateLet cenv env bindR bodyR m - exprR, - { TotalSize = bindingInfo.TotalSize + bodyInfo.TotalSize + adjust - FunctionSize = bindingInfo.FunctionSize + bodyInfo.FunctionSize + adjust - HasEffect=bindingInfo.HasEffect || bodyInfo.HasEffect - MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall // discard tailcall info from binding - not in tailcall position - Info = UnknownValue } - else - // On the way back up: Trim out any optimization info that involves escaping values on the way back up - let evalueR = AbstractExprInfoByVars ([bindR.Var], []) bodyInfo.Info - - // Preserve the debug points for eliminated bindings that have debug points. - let bodyR = - match bindR.DebugPoint with - | DebugPointAtBinding.Yes m -> mkDebugPoint m bodyR - | _ -> bodyR - bodyR, - { TotalSize = bindingInfo.TotalSize + bodyInfo.TotalSize - localVarSize // eliminated a local var - FunctionSize = bindingInfo.FunctionSize + bodyInfo.FunctionSize - localVarSize (* eliminated a local var *) - HasEffect=bindingInfo.HasEffect || bodyInfo.HasEffect - MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall // discard tailcall info from binding - not in tailcall position - Info = evalueR } )) - - | LinearMatchExpr (spMatch, mExpr, dtree, tg1, e2, m, ty) -> - let dtreeR, dinfo = OptimizeDecisionTree cenv env m dtree - let tg1, tg1info = OptimizeDecisionTreeTarget cenv env m tg1 - // tailcall - OptimizeLinearExpr cenv env e2 (contf << (fun (e2, e2info) -> - // This ConsiderSplitToMethod is performed because it is present in OptimizeDecisionTreeTarget - let e2, e2info = ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (e2, e2info) - let tinfos = [tg1info; e2info] - let targetsR = [tg1; TTarget([], e2, None)] - OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty))) - - | LinearOpExpr (op, tyargs, argsHead, argLast, m) -> - let argsHeadR, argsHeadInfosR = OptimizeList (OptimizeExprThenConsiderSplit cenv env) argsHead - // tailcall - OptimizeLinearExpr cenv env argLast (contf << (fun (argLastR, argLastInfo) -> - OptimizeExprOpReductionsAfter cenv env (op, tyargs, argsHeadR @ [argLastR], argsHeadInfosR @ [argLastInfo], m))) - - | Expr.DebugPoint (m, innerExpr) when not (IsDebugPipeRightExpr cenv innerExpr)-> - OptimizeLinearExpr cenv env innerExpr (contf << (fun (innerExprR, einfo) -> - Expr.DebugPoint (m, innerExprR), einfo)) - - | _ -> contf (OptimizeExpr cenv env expr) + | _ -> + + match expr with + | Expr.Sequential(e1, e2, flag, m) -> + + let e1R, e1info = OptimizeExpr cenv env e1 + + OptimizeLinearExpr + cenv + env + e2 + (contf + << (fun (e2R, e2info) -> + if + (flag = NormalSeq) + && + // Always eliminate '(); expr' sequences, even in debug code, to ensure that + // conditional method calls don't leave a dangling breakpoint (see FSharp 1.0 bug 6034) + (cenv.settings.EliminateSequential + || (match stripDebugPoints e1R with + | Expr.Const(Const.Unit, _, _) -> true + | _ -> false)) + && not e1info.HasEffect + then + e2R, e2info + else + Expr.Sequential(e1R, e2R, flag, m), + { + TotalSize = e1info.TotalSize + e2info.TotalSize + FunctionSize = e1info.FunctionSize + e2info.FunctionSize + HasEffect = flag <> NormalSeq || e1info.HasEffect || e2info.HasEffect + MightMakeCriticalTailcall = + (if flag = NormalSeq then + e2info.MightMakeCriticalTailcall + else + e1info.MightMakeCriticalTailcall || e2info.MightMakeCriticalTailcall) + // can't propagate value: must access result of computation for its effects + Info = UnknownValue + })) + + | Expr.Let(bind, body, m, _) -> + + let (bindR, bindingInfo), env = OptimizeBinding cenv false env bind + + OptimizeLinearExpr + cenv + env + body + (contf + << (fun (bodyR, bodyInfo) -> + // PERF: This call to ValueIsUsedOrHasEffect/freeInExpr amounts to 9% of all optimization time. + // Is it quadratic or quasi-quadratic? + if + ValueIsUsedOrHasEffect + cenv + (fun () -> (freeInExpr (CollectLocalsWithStackGuard()) bodyR).FreeLocals) + (bindR, bindingInfo) + then + // Eliminate let bindings on the way back up + let exprR, adjust = TryEliminateLet cenv env bindR bodyR m + + exprR, + { + TotalSize = bindingInfo.TotalSize + bodyInfo.TotalSize + adjust + FunctionSize = bindingInfo.FunctionSize + bodyInfo.FunctionSize + adjust + HasEffect = bindingInfo.HasEffect || bodyInfo.HasEffect + MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall // discard tailcall info from binding - not in tailcall position + Info = UnknownValue + } + else + // On the way back up: Trim out any optimization info that involves escaping values on the way back up + let evalueR = AbstractExprInfoByVars ([ bindR.Var ], []) bodyInfo.Info + + // Preserve the debug points for eliminated bindings that have debug points. + let bodyR = + match bindR.DebugPoint with + | DebugPointAtBinding.Yes m -> mkDebugPoint m bodyR + | _ -> bodyR + + bodyR, + { + TotalSize = bindingInfo.TotalSize + bodyInfo.TotalSize - localVarSize // eliminated a local var + FunctionSize = bindingInfo.FunctionSize + bodyInfo.FunctionSize - localVarSize (* eliminated a local var *) + HasEffect = bindingInfo.HasEffect || bodyInfo.HasEffect + MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall // discard tailcall info from binding - not in tailcall position + Info = evalueR + })) + + | LinearMatchExpr(spMatch, mExpr, dtree, tg1, e2, m, ty) -> + let dtreeR, dinfo = OptimizeDecisionTree cenv env m dtree + let tg1, tg1info = OptimizeDecisionTreeTarget cenv env m tg1 + // tailcall + OptimizeLinearExpr + cenv + env + e2 + (contf + << (fun (e2, e2info) -> + // This ConsiderSplitToMethod is performed because it is present in OptimizeDecisionTreeTarget + let e2, e2info = + ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (e2, e2info) + + let tinfos = [ tg1info; e2info ] + let targetsR = [ tg1; TTarget([], e2, None) ] + OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty))) + + | LinearOpExpr(op, tyargs, argsHead, argLast, m) -> + let argsHeadR, argsHeadInfosR = + OptimizeList (OptimizeExprThenConsiderSplit cenv env) argsHead + // tailcall + OptimizeLinearExpr + cenv + env + argLast + (contf + << (fun (argLastR, argLastInfo) -> + OptimizeExprOpReductionsAfter cenv env (op, tyargs, argsHeadR @ [ argLastR ], argsHeadInfosR @ [ argLastInfo ], m))) + + | Expr.DebugPoint(m, innerExpr) when not (IsDebugPipeRightExpr cenv innerExpr) -> + OptimizeLinearExpr cenv env innerExpr (contf << (fun (innerExprR, einfo) -> Expr.DebugPoint(m, innerExprR), einfo)) + + | _ -> contf (OptimizeExpr cenv env expr) /// Optimize/analyze a try/finally construct. and OptimizeTryFinally cenv env (spTry, spFinally, e1, e2, m, ty) = let g = cenv.g - let e1R, e1info = OptimizeExpr cenv env e1 - let e2R, e2info = OptimizeExpr cenv env e2 + let e1R, e1info = OptimizeExpr cenv env e1 + let e2R, e2info = OptimizeExpr cenv env e2 - let info = - { TotalSize = e1info.TotalSize + e2info.TotalSize + tryFinallySize - FunctionSize = e1info.FunctionSize + e2info.FunctionSize + tryFinallySize - HasEffect = e1info.HasEffect || e2info.HasEffect - MightMakeCriticalTailcall = false // no tailcalls from inside in try/finally - Info = UnknownValue } + let info = + { + TotalSize = e1info.TotalSize + e2info.TotalSize + tryFinallySize + FunctionSize = e1info.FunctionSize + e2info.FunctionSize + tryFinallySize + HasEffect = e1info.HasEffect || e2info.HasEffect + MightMakeCriticalTailcall = false // no tailcalls from inside in try/finally + Info = UnknownValue + } // try-finally, so no effect means no exception can be raised, so just sequence the finally - if cenv.settings.EliminateTryWithAndTryFinally && not e1info.HasEffect then - let e1R2 = - match spTry with + if cenv.settings.EliminateTryWithAndTryFinally && not e1info.HasEffect then + let e1R2 = + match spTry with | DebugPointAtTry.Yes m -> Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, e1R) | DebugPointAtTry.No -> e1R - Expr.Sequential (e1R2, e2R, ThenDoSeq, m), info + + Expr.Sequential(e1R2, e2R, ThenDoSeq, m), info else - mkTryFinally g (e1R, e2R, m, ty, spTry, spFinally), - info + mkTryFinally g (e1R, e2R, m, ty, spTry, spFinally), info /// Optimize/analyze a try/with construct. and OptimizeTryWith cenv env (e1, vf, ef, vh, eh, m, ty, spTry, spWith) = let g = cenv.g - let e1R, e1info = OptimizeExpr cenv env e1 + let e1R, e1info = OptimizeExpr cenv env e1 - // try-with, so no effect means no exception can be raised, so discard the with - if cenv.settings.EliminateTryWithAndTryFinally && not e1info.HasEffect then - e1R, e1info + // try-with, so no effect means no exception can be raised, so discard the with + if cenv.settings.EliminateTryWithAndTryFinally && not e1info.HasEffect then + e1R, e1info else - let envinner = BindInternalValToUnknown cenv vf (BindInternalValToUnknown cenv vh env) - let efR, efinfo = OptimizeExpr cenv envinner ef - let ehR, ehinfo = OptimizeExpr cenv envinner eh + let envinner = + BindInternalValToUnknown cenv vf (BindInternalValToUnknown cenv vh env) + + let efR, efinfo = OptimizeExpr cenv envinner ef + let ehR, ehinfo = OptimizeExpr cenv envinner eh - let info = - { TotalSize = e1info.TotalSize + efinfo.TotalSize+ ehinfo.TotalSize + tryWithSize - FunctionSize = e1info.FunctionSize + efinfo.FunctionSize+ ehinfo.FunctionSize + tryWithSize - HasEffect = e1info.HasEffect || efinfo.HasEffect || ehinfo.HasEffect - MightMakeCriticalTailcall = false - Info = UnknownValue } + let info = + { + TotalSize = e1info.TotalSize + efinfo.TotalSize + ehinfo.TotalSize + tryWithSize + FunctionSize = e1info.FunctionSize + efinfo.FunctionSize + ehinfo.FunctionSize + tryWithSize + HasEffect = e1info.HasEffect || efinfo.HasEffect || ehinfo.HasEffect + MightMakeCriticalTailcall = false + Info = UnknownValue + } let exprR = mkTryWith g (e1R, vf, efR, vh, ehR, m, ty, spTry, spWith) exprR, info @@ -3001,83 +3570,88 @@ and OptimizeTryWith cenv env (e1, vf, ef, vh, eh, m, ty, spTry, spWith) = /// Optimize/analyze a while loop and OptimizeWhileLoop cenv env (spWhile, marker, e1, e2, m) = let g = cenv.g - let e1R, e1info = OptimizeExpr cenv env e1 - let e2R, e2info = OptimizeExpr cenv env e2 + let e1R, e1info = OptimizeExpr cenv env e1 + let e2R, e2info = OptimizeExpr cenv env e2 let exprR = mkWhile g (spWhile, marker, e1R, e2R, m) + let info = - { TotalSize = e1info.TotalSize + e2info.TotalSize + forAndWhileLoopSize - FunctionSize = e1info.FunctionSize + e2info.FunctionSize + forAndWhileLoopSize - HasEffect = true // may not terminate - MightMakeCriticalTailcall = false - Info = UnknownValue } + { + TotalSize = e1info.TotalSize + e2info.TotalSize + forAndWhileLoopSize + FunctionSize = e1info.FunctionSize + e2info.FunctionSize + forAndWhileLoopSize + HasEffect = true // may not terminate + MightMakeCriticalTailcall = false + Info = UnknownValue + } + exprR, info -/// Optimize/analyze a call to a 'member' constraint. Try to resolve the call to +/// Optimize/analyze a call to a 'member' constraint. Try to resolve the call to /// a witness (should always be possible due to compulsory inlining of any -/// code that contains calls to member constraints, except when analyzing +/// code that contains calls to member constraints, except when analyzing /// not-yet-inlined generic code) and OptimizeTraitCall cenv env (traitInfo, args, m) = let g = cenv.g - // Resolve the static overloading early (during the compulsory rewrite phase) so we can inline. + // Resolve the static overloading early (during the compulsory rewrite phase) so we can inline. match ConstraintSolver.CodegenWitnessExprForTraitConstraint cenv.TcVal g cenv.amap m traitInfo args with - | OkResult (_, Some expr) -> OptimizeExpr cenv env expr + | OkResult(_, Some expr) -> OptimizeExpr cenv env expr // Resolution fails when optimizing generic code, ignore the failure - | _ -> - let argsR, arginfos = OptimizeExprsThenConsiderSplits cenv env args - OptimizeExprOpFallback cenv env (TOp.TraitCall traitInfo, [], argsR, m) arginfos UnknownValue + | _ -> + let argsR, arginfos = OptimizeExprsThenConsiderSplits cenv env args + OptimizeExprOpFallback cenv env (TOp.TraitCall traitInfo, [], argsR, m) arginfos UnknownValue -and CopyExprForInlining cenv isInlineIfLambda expr (m: range) = +and CopyExprForInlining cenv isInlineIfLambda expr (m: range) = let g = cenv.g // 'InlineIfLambda' doesn't erase ranges, e.g. if the lambda is user code. if isInlineIfLambda then - expr - |> copyExpr g CloneAll + expr |> copyExpr g CloneAll else - expr - |> copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated - |> remarkExpr m + expr |> copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated |> remarkExpr m /// Make optimization decisions once we know the optimization information /// for a value -and TryOptimizeVal cenv env (vOpt: ValRef option, shouldInline, inlineIfLambda, valInfoForVal, m) = +and TryOptimizeVal cenv env (vOpt: ValRef option, shouldInline, inlineIfLambda, valInfoForVal, m) = let g = cenv.g - match valInfoForVal with - // Inline all constants immediately - | ConstValue (c, ty) -> - Some (Expr.Const (c, m, ty)) - - | SizeValue (_, detail) -> - TryOptimizeVal cenv env (vOpt, shouldInline, inlineIfLambda, detail, m) - - | ValValue (vR, detail) -> - // Inline values bound to other values immediately - // Prefer to inline using the more specific info if possible - // If the more specific info didn't reveal an inline then use the value - match TryOptimizeVal cenv env (vOpt, shouldInline, inlineIfLambda, detail, m) with - | Some e -> Some e - | None -> - // If we have proven 'v = compilerGeneratedValue' - // and 'v' is being eliminated in favour of 'compilerGeneratedValue' - // then replace the name of 'compilerGeneratedValue' - // by 'v' and mark it not compiler generated so we preserve good debugging and names. - // Don't do this for things represented statically as it may publish multiple values with the same name. - match vOpt with - | Some v when not v.IsCompilerGenerated && vR.IsCompilerGenerated && not vR.IsCompiledAsTopLevel && not v.IsCompiledAsTopLevel -> - vR.Deref.SetIsCompilerGenerated(false) - vR.Deref.SetLogicalName(v.LogicalName) - | _ -> () - Some(exprForValRef m vR) - - | ConstExprValue(_size, expr) -> - Some (remarkExpr m (copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated expr)) - - | CurriedLambdaValue (_, _, _, expr, _) when shouldInline || inlineIfLambda -> + match valInfoForVal with + // Inline all constants immediately + | ConstValue(c, ty) -> Some(Expr.Const(c, m, ty)) + + | SizeValue(_, detail) -> TryOptimizeVal cenv env (vOpt, shouldInline, inlineIfLambda, detail, m) + + | ValValue(vR, detail) -> + // Inline values bound to other values immediately + // Prefer to inline using the more specific info if possible + // If the more specific info didn't reveal an inline then use the value + match TryOptimizeVal cenv env (vOpt, shouldInline, inlineIfLambda, detail, m) with + | Some e -> Some e + | None -> + // If we have proven 'v = compilerGeneratedValue' + // and 'v' is being eliminated in favour of 'compilerGeneratedValue' + // then replace the name of 'compilerGeneratedValue' + // by 'v' and mark it not compiler generated so we preserve good debugging and names. + // Don't do this for things represented statically as it may publish multiple values with the same name. + match vOpt with + | Some v when + not v.IsCompilerGenerated + && vR.IsCompilerGenerated + && not vR.IsCompiledAsTopLevel + && not v.IsCompiledAsTopLevel + -> + vR.Deref.SetIsCompilerGenerated(false) + vR.Deref.SetLogicalName(v.LogicalName) + | _ -> () + + Some(exprForValRef m vR) + + | ConstExprValue(_size, expr) -> Some(remarkExpr m (copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated expr)) + + | CurriedLambdaValue(_, _, _, expr, _) when shouldInline || inlineIfLambda -> let fvs = freeInExpr CollectLocals expr + if fvs.UsesMethodLocalConstructs then // Discarding lambda for binding because uses protected members --- TBD: Should we warn or error here None @@ -3085,439 +3659,572 @@ and TryOptimizeVal cenv env (vOpt: ValRef option, shouldInline, inlineIfLambda, let exprCopy = CopyExprForInlining cenv inlineIfLambda expr m Some exprCopy - | TupleValue _ | UnionCaseValue _ | RecdValue _ when shouldInline -> - failwith "tuple, union and record values cannot be marked 'inline'" + | TupleValue _ + | UnionCaseValue _ + | RecdValue _ when shouldInline -> failwith "tuple, union and record values cannot be marked 'inline'" | UnknownValue when shouldInline -> - warning(Error(FSComp.SR.optValueMarkedInlineHasUnexpectedValue(), m)) + warning (Error(FSComp.SR.optValueMarkedInlineHasUnexpectedValue (), m)) None | _ when shouldInline -> - warning(Error(FSComp.SR.optValueMarkedInlineCouldNotBeInlined(), m)) + warning (Error(FSComp.SR.optValueMarkedInlineCouldNotBeInlined (), m)) None - | _ -> None - -and TryOptimizeValInfo cenv env m vinfo = - if vinfo.HasEffect then None else TryOptimizeVal cenv env (None, false, false, vinfo.Info, m) + | _ -> None + +and TryOptimizeValInfo cenv env m vinfo = + if vinfo.HasEffect then + None + else + TryOptimizeVal cenv env (None, false, false, vinfo.Info, m) /// Add 'v1 = v2' information into the information stored about a value and AddValEqualityInfo g m (v: ValRef) info = - // ValValue is information that v = v2, where v2 does not change + // ValValue is information that v = v2, where v2 does not change // So we can't record this information for mutable values. An exception can be made // for "outArg" values arising from method calls since they are only temporarily mutable // when their address is passed to the method call. Another exception are mutable variables // created for tuple elimination in branching tuple bindings because they are assigned to // exactly once. - if not v.IsMutable || IsKnownOnlyMutableBeforeUse v then - { info with Info = MakeValueInfoForValue g m v info.Info } + if not v.IsMutable || IsKnownOnlyMutableBeforeUse v then + { info with + Info = MakeValueInfoForValue g m v info.Info + } else - info + info /// Optimize/analyze a use of a value and OptimizeVal cenv env expr (v: ValRef, m) = let g = cenv.g - let valInfoForVal = GetInfoForValWithCheck cenv env m v + let valInfoForVal = GetInfoForValWithCheck cenv env m v match TryOptimizeVal cenv env (Some v, v.ShouldInline, v.InlineIfLambda, valInfoForVal.ValExprInfo, m) with - | Some e -> - // don't reoptimize inlined lambdas until they get applied to something - match e with - | Expr.TyLambda _ - | Expr.Lambda _ -> - e, (AddValEqualityInfo g m v - { Info=valInfoForVal.ValExprInfo - HasEffect=false - MightMakeCriticalTailcall = false - FunctionSize=10 - TotalSize=10}) - | _ -> - let e, einfo = OptimizeExpr cenv env e - e, AddValEqualityInfo g m v einfo + | Some e -> + // don't reoptimize inlined lambdas until they get applied to something + match e with + | Expr.TyLambda _ + | Expr.Lambda _ -> + e, + (AddValEqualityInfo + g + m + v + { + Info = valInfoForVal.ValExprInfo + HasEffect = false + MightMakeCriticalTailcall = false + FunctionSize = 10 + TotalSize = 10 + }) + | _ -> + let e, einfo = OptimizeExpr cenv env e + e, AddValEqualityInfo g m v einfo | None -> - if v.ShouldInline then + if v.ShouldInline then match valInfoForVal.ValExprInfo with - | UnknownValue -> error(Error(FSComp.SR.optFailedToInlineValue(v.DisplayName), m)) - | _ -> warning(Error(FSComp.SR.optFailedToInlineValue(v.DisplayName), m)) - if v.InlineIfLambda then - warning(Error(FSComp.SR.optFailedToInlineSuggestedValue(v.DisplayName), m)) - - expr, (AddValEqualityInfo g m v - { Info=valInfoForVal.ValExprInfo - HasEffect=false - MightMakeCriticalTailcall = false - FunctionSize=1 - TotalSize=1}) + | UnknownValue -> error (Error(FSComp.SR.optFailedToInlineValue (v.DisplayName), m)) + | _ -> warning (Error(FSComp.SR.optFailedToInlineValue (v.DisplayName), m)) + + if v.InlineIfLambda then + warning (Error(FSComp.SR.optFailedToInlineSuggestedValue (v.DisplayName), m)) + + expr, + (AddValEqualityInfo + g + m + v + { + Info = valInfoForVal.ValExprInfo + HasEffect = false + MightMakeCriticalTailcall = false + FunctionSize = 1 + TotalSize = 1 + }) /// Attempt to replace an application of a value by an alternative value. -and StripToNominalTyconRef cenv ty = +and StripToNominalTyconRef cenv ty = let g = cenv.g + match tryAppTy g ty with | ValueSome x -> x | _ -> if isRefTupleTy g ty then let tyargs = destRefTupleTy g ty - mkCompiledTupleTyconRef g false (List.length tyargs), tyargs - else failwith "StripToNominalTyconRef: unreachable" + mkCompiledTupleTyconRef g false (List.length tyargs), tyargs + else + failwith "StripToNominalTyconRef: unreachable" -and CanDevirtualizeApplication cenv v vref ty args = +and CanDevirtualizeApplication cenv v vref ty args = let g = cenv.g + valRefEq g v vref && not (isUnitTy g ty) - && isAppTy g ty - // Exclusion: Some unions have null as representations - && not (IsUnionTypeWithNullAsTrueValue g (fst(StripToNominalTyconRef cenv ty)).Deref) + && isAppTy g ty + // Exclusion: Some unions have null as representations + && not (IsUnionTypeWithNullAsTrueValue g (fst (StripToNominalTyconRef cenv ty)).Deref) // If we de-virtualize an operation on structs then we have to take the address of the object argument - // Hence we have to actually have the object argument available to us, - && (not (isStructTy g ty) || not (isNil args)) + // Hence we have to actually have the object argument available to us, + && (not (isStructTy g ty) || not (isNil args)) and TakeAddressOfStructArgumentIfNeeded cenv (vref: ValRef) ty args m = let g = cenv.g - if vref.IsInstanceMember && isStructTy g ty then - match args with - | objArg :: rest -> - // We set NeverMutates here, allowing more address-taking. This is valid because we only ever use DevirtualizeApplication to transform + + if vref.IsInstanceMember && isStructTy g ty then + match args with + | objArg :: rest -> + // We set NeverMutates here, allowing more address-taking. This is valid because we only ever use DevirtualizeApplication to transform // known calls to known generated F# code for CompareTo, Equals and GetHashCode. - // If we ever reuse DevirtualizeApplication to transform an arbitrary virtual call into a + // If we ever reuse DevirtualizeApplication to transform an arbitrary virtual call into a // direct call then this assumption is not valid. - let wrap, objArgAddress, _readonly, _writeonly = mkExprAddrOfExpr g true false NeverMutates objArg None m + let wrap, objArgAddress, _readonly, _writeonly = + mkExprAddrOfExpr g true false NeverMutates objArg None m + wrap, (objArgAddress :: rest) - | _ -> - // no wrapper, args stay the same + | _ -> + // no wrapper, args stay the same id, args else id, args and DevirtualizeApplication cenv env (vref: ValRef) ty tyargs args m nullHandlerOpt = let g = cenv.g - let wrap, args = + + let wrap, args = match nullHandlerOpt with - | Some nullHandler when g.checkNullness && TypeNullIsExtraValueNew g vref.Range ty -> - nullHandler g m, args + | Some nullHandler when g.checkNullness && TypeNullIsExtraValueNew g vref.Range ty -> nullHandler g m, args | _ -> TakeAddressOfStructArgumentIfNeeded cenv vref ty args m - let transformedExpr = wrap (MakeApplicationAndBetaReduce g (exprForValRef m vref, vref.Type, (if isNil tyargs then [] else [tyargs]), args, m)) + + let transformedExpr = + wrap (MakeApplicationAndBetaReduce g (exprForValRef m vref, vref.Type, (if isNil tyargs then [] else [ tyargs ]), args, m)) + OptimizeExpr cenv env transformedExpr - + and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = let g = cenv.g - match f, tyargs, args with - // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonIntrinsic when type is known - // to be augmented with a visible comparison value. + + match f, tyargs, args with + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonIntrinsic when type is known + // to be augmented with a visible comparison value. // - // e.g rewrite - // 'LanguagePrimitives.HashCompare.GenericComparisonIntrinsic (x: C) (y: C)' + // e.g rewrite + // 'LanguagePrimitives.HashCompare.GenericComparisonIntrinsic (x: C) (y: C)' // --> 'x.CompareTo(y: C)' where this is a direct call to the implementation of CompareTo, i.e. // C :: CompareTo(C) // not C :: CompareTo(obj) // // If C is a struct type then we have to take the address of 'c' - - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_comparison_inner_vref ty args -> - + + | Expr.Val(v, _, _), [ ty ], _ when CanDevirtualizeApplication cenv v g.generic_comparison_inner_vref ty args -> + let tcref, tyargs = StripToNominalTyconRef cenv ty - match tcref.GeneratedCompareToValues, args with - | Some (_, vref), [x;y] -> - let nullHandler g m = AugmentTypeDefinitions.mkBindNullComparison g m x y - Some (DevirtualizeApplication cenv env vref ty tyargs args m (Some nullHandler)) + + match tcref.GeneratedCompareToValues, args with + | Some(_, vref), [ x; y ] -> + let nullHandler g m = + AugmentTypeDefinitions.mkBindNullComparison g m x y + + Some(DevirtualizeApplication cenv env vref ty tyargs args m (Some nullHandler)) | _ -> None - - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_comparison_withc_inner_vref ty args -> - + + | Expr.Val(v, _, _), [ ty ], _ when CanDevirtualizeApplication cenv v g.generic_comparison_withc_inner_vref ty args -> + let tcref, tyargs = StripToNominalTyconRef cenv ty - match tcref.GeneratedCompareToWithComparerValues, args with - | Some vref, [comp; x; y] -> + + match tcref.GeneratedCompareToWithComparerValues, args with + | Some vref, [ comp; x; y ] -> // the target takes a tupled argument, so we need to reorder the arg expressions in the // arg list, and create a tuple of y & comp // push the comparer to the end and box the argument - let args2 = [x; mkRefTupledNoTypes g m [mkCoerceExpr(y, g.obj_ty_ambivalent, m, ty) ; comp]] - let nullHandler g m = AugmentTypeDefinitions.mkBindNullComparison g m x y - Some (DevirtualizeApplication cenv env vref ty tyargs args2 m (Some nullHandler)) + let args2 = + [ + x + mkRefTupledNoTypes g m [ mkCoerceExpr (y, g.obj_ty_ambivalent, m, ty); comp ] + ] + + let nullHandler g m = + AugmentTypeDefinitions.mkBindNullComparison g m x y + + Some(DevirtualizeApplication cenv env vref ty tyargs args2 m (Some nullHandler)) | _ -> None - - // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityIntrinsic when type is known - // to be augmented with a visible equality-without-comparer value. + + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityIntrinsic when type is known + // to be augmented with a visible equality-without-comparer value. // REVIEW: GenericEqualityIntrinsic (which has no comparer) implements PER semantics (5537: this should be ER semantics) // We are devirtualizing to a Equals(T) method which also implements PER semantics (5537: this should be ER semantics) - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_equality_er_inner_vref ty args -> - - let tcref, tyargs = StripToNominalTyconRef cenv ty - match tcref.GeneratedHashAndEqualsValues, args with - | Some (_, vref),[x;y] -> - let nullHandler g m = AugmentTypeDefinitions.mkBindThisNullEquals g m x y - Some (DevirtualizeApplication cenv env vref ty tyargs args m (Some nullHandler)) + | Expr.Val(v, _, _), [ ty ], _ when CanDevirtualizeApplication cenv v g.generic_equality_er_inner_vref ty args -> + + let tcref, tyargs = StripToNominalTyconRef cenv ty + + match tcref.GeneratedHashAndEqualsValues, args with + | Some(_, vref), [ x; y ] -> + let nullHandler g m = + AugmentTypeDefinitions.mkBindThisNullEquals g m x y + + Some(DevirtualizeApplication cenv env vref ty tyargs args m (Some nullHandler)) | _ -> None - + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparerIntrinsic - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_equality_withc_inner_vref ty args -> + | Expr.Val(v, _, _), [ ty ], _ when CanDevirtualizeApplication cenv v g.generic_equality_withc_inner_vref ty args -> let tcref, tyargs = StripToNominalTyconRef cenv ty + match tcref.GeneratedHashAndEqualsWithComparerValues, args with - | Some (_, _, _, Some withcEqualsExactVal), [comp; x; y] -> + | Some(_, _, _, Some withcEqualsExactVal), [ comp; x; y ] -> // push the comparer to the end - let args2 = [x; mkRefTupledNoTypes g m [y; comp]] - let nullHandler g m = AugmentTypeDefinitions.mkBindThisNullEquals g m x y - Some (DevirtualizeApplication cenv env withcEqualsExactVal ty tyargs args2 m (Some nullHandler)) - | Some (_, _, withcEqualsVal, _ ), [comp; x; y] -> + let args2 = [ x; mkRefTupledNoTypes g m [ y; comp ] ] + + let nullHandler g m = + AugmentTypeDefinitions.mkBindThisNullEquals g m x y + + Some(DevirtualizeApplication cenv env withcEqualsExactVal ty tyargs args2 m (Some nullHandler)) + | Some(_, _, withcEqualsVal, _), [ comp; x; y ] -> // push the comparer to the end and box the argument - let args2 = [x; mkRefTupledNoTypes g m [mkCoerceExpr(y, g.obj_ty_ambivalent, m, ty) ; comp]] - let nullHandler g m = AugmentTypeDefinitions.mkBindThisNullEquals g m x y - Some (DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m (Some nullHandler)) - | _ -> None - + let args2 = + [ + x + mkRefTupledNoTypes g m [ mkCoerceExpr (y, g.obj_ty_ambivalent, m, ty); comp ] + ] + + let nullHandler g m = + AugmentTypeDefinitions.mkBindThisNullEquals g m x y + + Some(DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m (Some nullHandler)) + | _ -> None + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityIntrinsic - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_equality_per_inner_vref ty args && not(isRefTupleTy g ty) -> - let tcref, tyargs = StripToNominalTyconRef cenv ty - match tcref.GeneratedHashAndEqualsWithComparerValues, args with - | Some (_, _, _, Some withcEqualsExactVal), [x; y] -> - let args2 = [x; mkRefTupledNoTypes g m [y; (mkCallGetGenericPEREqualityComparer g m)]] - let nullHandler g m = AugmentTypeDefinitions.mkBindThisNullEquals g m x y - Some (DevirtualizeApplication cenv env withcEqualsExactVal ty tyargs args2 m (Some nullHandler)) - | Some (_, _, withcEqualsVal, _), [x; y] -> - let equalsExactOpt = - tcref.MembersOfFSharpTyconByName.TryFind("Equals") - |> Option.map (List.where (fun x -> x.IsCompilerGenerated)) - |> Option.bind List.tryExactlyOne - - let nullHandler g m = AugmentTypeDefinitions.mkBindThisNullEquals g m x y - - match equalsExactOpt with - | Some equalsExact -> - let args2 = [x; mkRefTupledNoTypes g m [y; (mkCallGetGenericPEREqualityComparer g m)]] - Some (DevirtualizeApplication cenv env equalsExact ty tyargs args2 m (Some nullHandler)) - | None -> - let args2 = [x; mkRefTupledNoTypes g m [mkCoerceExpr(y, g.obj_ty_ambivalent, m, ty); (mkCallGetGenericPEREqualityComparer g m)]] - Some (DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m (Some nullHandler)) - | _ -> None - + | Expr.Val(v, _, _), [ ty ], _ when + CanDevirtualizeApplication cenv v g.generic_equality_per_inner_vref ty args + && not (isRefTupleTy g ty) + -> + let tcref, tyargs = StripToNominalTyconRef cenv ty + + match tcref.GeneratedHashAndEqualsWithComparerValues, args with + | Some(_, _, _, Some withcEqualsExactVal), [ x; y ] -> + let args2 = + [ x; mkRefTupledNoTypes g m [ y; (mkCallGetGenericPEREqualityComparer g m) ] ] + + let nullHandler g m = + AugmentTypeDefinitions.mkBindThisNullEquals g m x y + + Some(DevirtualizeApplication cenv env withcEqualsExactVal ty tyargs args2 m (Some nullHandler)) + | Some(_, _, withcEqualsVal, _), [ x; y ] -> + let equalsExactOpt = + tcref.MembersOfFSharpTyconByName.TryFind("Equals") + |> Option.map (List.where (fun x -> x.IsCompilerGenerated)) + |> Option.bind List.tryExactlyOne + + let nullHandler g m = + AugmentTypeDefinitions.mkBindThisNullEquals g m x y + + match equalsExactOpt with + | Some equalsExact -> + let args2 = + [ x; mkRefTupledNoTypes g m [ y; (mkCallGetGenericPEREqualityComparer g m) ] ] + + Some(DevirtualizeApplication cenv env equalsExact ty tyargs args2 m (Some nullHandler)) + | None -> + let args2 = + [ + x + mkRefTupledNoTypes + g + m + [ + mkCoerceExpr (y, g.obj_ty_ambivalent, m, ty) + (mkCallGetGenericPEREqualityComparer g m) + ] + ] + + Some(DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m (Some nullHandler)) + | _ -> None + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashIntrinsic - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_hash_inner_vref ty args -> + | Expr.Val(v, _, _), [ ty ], _ when CanDevirtualizeApplication cenv v g.generic_hash_inner_vref ty args -> let tcref, tyargs = StripToNominalTyconRef cenv ty + match tcref.GeneratedHashAndEqualsWithComparerValues, args with - | Some (_, withcGetHashCodeVal, _, _), [x] -> - let args2 = [x; mkCallGetGenericEREqualityComparer g m] - let nullHandler g m = AugmentTypeDefinitions.mkBindNullHash g m x - Some (DevirtualizeApplication cenv env withcGetHashCodeVal ty tyargs args2 m (Some nullHandler)) - | _ -> None - + | Some(_, withcGetHashCodeVal, _, _), [ x ] -> + let args2 = [ x; mkCallGetGenericEREqualityComparer g m ] + + let nullHandler g m = + AugmentTypeDefinitions.mkBindNullHash g m x + + Some(DevirtualizeApplication cenv env withcGetHashCodeVal ty tyargs args2 m (Some nullHandler)) + | _ -> None + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic - | Expr.Val (v, _, _), [ty], _ when CanDevirtualizeApplication cenv v g.generic_hash_withc_inner_vref ty args -> + | Expr.Val(v, _, _), [ ty ], _ when CanDevirtualizeApplication cenv v g.generic_hash_withc_inner_vref ty args -> let tcref, tyargs = StripToNominalTyconRef cenv ty + match tcref.GeneratedHashAndEqualsWithComparerValues, args with - | Some (_, withcGetHashCodeVal, _, _), [comp; x] -> - let args2 = [x; comp] - let nullHandler g m = AugmentTypeDefinitions.mkBindNullHash g m x - Some (DevirtualizeApplication cenv env withcGetHashCodeVal ty tyargs args2 m (Some nullHandler)) - | _ -> None + | Some(_, withcGetHashCodeVal, _, _), [ comp; x ] -> + let args2 = [ x; comp ] + + let nullHandler g m = + AugmentTypeDefinitions.mkBindNullHash g m x + + Some(DevirtualizeApplication cenv env withcGetHashCodeVal ty tyargs args2 m (Some nullHandler)) + | _ -> None // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonWithComparerIntrinsic for tuple types - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.generic_comparison_inner_vref && isRefTupleTy g ty -> - let tyargs = destRefTupleTy g ty - let vref = - match tyargs.Length with - | 2 -> Some g.generic_compare_withc_tuple2_vref - | 3 -> Some g.generic_compare_withc_tuple3_vref - | 4 -> Some g.generic_compare_withc_tuple4_vref - | 5 -> Some g.generic_compare_withc_tuple5_vref + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.generic_comparison_inner_vref && isRefTupleTy g ty -> + let tyargs = destRefTupleTy g ty + + let vref = + match tyargs.Length with + | 2 -> Some g.generic_compare_withc_tuple2_vref + | 3 -> Some g.generic_compare_withc_tuple3_vref + | 4 -> Some g.generic_compare_withc_tuple4_vref + | 5 -> Some g.generic_compare_withc_tuple5_vref | _ -> None - match vref with - | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericComparer g m :: args) m None) + + match vref with + | Some vref -> Some(DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericComparer g m :: args) m None) | None -> None - + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic for tuple types - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.generic_hash_inner_vref && isRefTupleTy g ty -> - let tyargs = destRefTupleTy g ty - let vref = - match tyargs.Length with - | 2 -> Some g.generic_hash_withc_tuple2_vref - | 3 -> Some g.generic_hash_withc_tuple3_vref - | 4 -> Some g.generic_hash_withc_tuple4_vref - | 5 -> Some g.generic_hash_withc_tuple5_vref + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.generic_hash_inner_vref && isRefTupleTy g ty -> + let tyargs = destRefTupleTy g ty + + let vref = + match tyargs.Length with + | 2 -> Some g.generic_hash_withc_tuple2_vref + | 3 -> Some g.generic_hash_withc_tuple3_vref + | 4 -> Some g.generic_hash_withc_tuple4_vref + | 5 -> Some g.generic_hash_withc_tuple5_vref | _ -> None - match vref with - | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericEREqualityComparer g m :: args) m None) + + match vref with + | Some vref -> Some(DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericEREqualityComparer g m :: args) m None) | None -> None - + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityIntrinsic for tuple types // REVIEW (5537): GenericEqualityIntrinsic implements PER semantics, and we are replacing it to something also // implementing PER semantics. However GenericEqualityIntrinsic should implement ER semantics. - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.generic_equality_per_inner_vref && isRefTupleTy g ty -> - let tyargs = destRefTupleTy g ty - let vref = - match tyargs.Length with - | 2 -> Some g.generic_equals_withc_tuple2_vref - | 3 -> Some g.generic_equals_withc_tuple3_vref - | 4 -> Some g.generic_equals_withc_tuple4_vref - | 5 -> Some g.generic_equals_withc_tuple5_vref + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.generic_equality_per_inner_vref && isRefTupleTy g ty -> + let tyargs = destRefTupleTy g ty + + let vref = + match tyargs.Length with + | 2 -> Some g.generic_equals_withc_tuple2_vref + | 3 -> Some g.generic_equals_withc_tuple3_vref + | 4 -> Some g.generic_equals_withc_tuple4_vref + | 5 -> Some g.generic_equals_withc_tuple5_vref | _ -> None - match vref with - | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericPEREqualityComparer g m :: args) m None) + + match vref with + | Some vref -> Some(DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericPEREqualityComparer g m :: args) m None) | None -> None - + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonWithComparerIntrinsic for tuple types - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.generic_comparison_withc_inner_vref && isRefTupleTy g ty -> - let tyargs = destRefTupleTy g ty - let vref = - match tyargs.Length with - | 2 -> Some g.generic_compare_withc_tuple2_vref - | 3 -> Some g.generic_compare_withc_tuple3_vref - | 4 -> Some g.generic_compare_withc_tuple4_vref - | 5 -> Some g.generic_compare_withc_tuple5_vref + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.generic_comparison_withc_inner_vref && isRefTupleTy g ty -> + let tyargs = destRefTupleTy g ty + + let vref = + match tyargs.Length with + | 2 -> Some g.generic_compare_withc_tuple2_vref + | 3 -> Some g.generic_compare_withc_tuple3_vref + | 4 -> Some g.generic_compare_withc_tuple4_vref + | 5 -> Some g.generic_compare_withc_tuple5_vref | _ -> None - match vref with - | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs args m None) + + match vref with + | Some vref -> Some(DevirtualizeApplication cenv env vref ty tyargs args m None) | None -> None - + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic for tuple types - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.generic_hash_withc_inner_vref && isRefTupleTy g ty -> - let tyargs = destRefTupleTy g ty - let vref = - match tyargs.Length with - | 2 -> Some g.generic_hash_withc_tuple2_vref - | 3 -> Some g.generic_hash_withc_tuple3_vref - | 4 -> Some g.generic_hash_withc_tuple4_vref - | 5 -> Some g.generic_hash_withc_tuple5_vref + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.generic_hash_withc_inner_vref && isRefTupleTy g ty -> + let tyargs = destRefTupleTy g ty + + let vref = + match tyargs.Length with + | 2 -> Some g.generic_hash_withc_tuple2_vref + | 3 -> Some g.generic_hash_withc_tuple3_vref + | 4 -> Some g.generic_hash_withc_tuple4_vref + | 5 -> Some g.generic_hash_withc_tuple5_vref | _ -> None - match vref with - | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs args m None) + + match vref with + | Some vref -> Some(DevirtualizeApplication cenv env vref ty tyargs args m None) | None -> None - + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparerIntrinsic for tuple types - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.generic_equality_withc_inner_vref && isRefTupleTy g ty -> - let tyargs = destRefTupleTy g ty - let vref = - match tyargs.Length with - | 2 -> Some g.generic_equals_withc_tuple2_vref - | 3 -> Some g.generic_equals_withc_tuple3_vref - | 4 -> Some g.generic_equals_withc_tuple4_vref - | 5 -> Some g.generic_equals_withc_tuple5_vref + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.generic_equality_withc_inner_vref && isRefTupleTy g ty -> + let tyargs = destRefTupleTy g ty + + let vref = + match tyargs.Length with + | 2 -> Some g.generic_equals_withc_tuple2_vref + | 3 -> Some g.generic_equals_withc_tuple3_vref + | 4 -> Some g.generic_equals_withc_tuple4_vref + | 5 -> Some g.generic_equals_withc_tuple5_vref | _ -> None - match vref with - | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs args m None) + + match vref with + | Some vref -> Some(DevirtualizeApplication cenv env vref ty tyargs args m None) | None -> None - - // Calls to LanguagePrimitives.IntrinsicFunctions.UnboxGeneric can be optimized to calls to UnboxFast when we know that the - // target type isn't 'NullNotLiked', i.e. that the target type is not an F# union, record etc. - // Note UnboxFast is just the .NET IL 'unbox.any' instruction. - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.unbox_vref && - canUseUnboxFast g m ty -> + + // Calls to LanguagePrimitives.IntrinsicFunctions.UnboxGeneric can be optimized to calls to UnboxFast when we know that the + // target type isn't 'NullNotLiked', i.e. that the target type is not an F# union, record etc. + // Note UnboxFast is just the .NET IL 'unbox.any' instruction. + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.unbox_vref && canUseUnboxFast g m ty -> Some(DevirtualizeApplication cenv env g.unbox_fast_vref ty tyargs args m None) - - // Calls to LanguagePrimitives.IntrinsicFunctions.TypeTestGeneric can be optimized to calls to TypeTestFast when we know that the - // target type isn't 'NullNotTrueValue', i.e. that the target type is not an F# union, record etc. - // Note TypeTestFast is just the .NET IL 'isinst' instruction followed by a non-null comparison - | Expr.Val (v, _, _), [ty], _ when valRefEq g v g.istype_vref && - canUseTypeTestFast g ty -> + + // Calls to LanguagePrimitives.IntrinsicFunctions.TypeTestGeneric can be optimized to calls to TypeTestFast when we know that the + // target type isn't 'NullNotTrueValue', i.e. that the target type is not an F# union, record etc. + // Note TypeTestFast is just the .NET IL 'isinst' instruction followed by a non-null comparison + | Expr.Val(v, _, _), [ ty ], _ when valRefEq g v g.istype_vref && canUseTypeTestFast g ty -> Some(DevirtualizeApplication cenv env g.istype_fast_vref ty tyargs args m None) - + // Don't fiddle with 'methodhandleof' calls - just remake the application - | Expr.Val (vref, _, _), _, _ when valRefEq g vref g.methodhandleof_vref -> - Some( MakeApplicationAndBetaReduce g (exprForValRef m vref, vref.Type, (if isNil tyargs then [] else [tyargs]), args, m), - { TotalSize=1 - FunctionSize=1 - HasEffect=false + | Expr.Val(vref, _, _), _, _ when valRefEq g vref g.methodhandleof_vref -> + Some( + MakeApplicationAndBetaReduce g (exprForValRef m vref, vref.Type, (if isNil tyargs then [] else [ tyargs ]), args, m), + { + TotalSize = 1 + FunctionSize = 1 + HasEffect = false MightMakeCriticalTailcall = false - Info=UnknownValue}) + Info = UnknownValue + } + ) | _ -> None /// Attempt to inline an application of a known value at callsites and TryInlineApplication cenv env finfo (tyargs: TType list, args: Expr list, m) = let g = cenv.g - // Considering inlining app - match finfo.Info with - | StripLambdaValue (lambdaId, arities, size, f2, f2ty) when - (// Considering inlining lambda - cenv.optimizing && - cenv.settings.InlineLambdas && - not finfo.HasEffect && - // Don't inline recursively! - not (Zset.contains lambdaId env.dontInline) && - (// Check the number of argument groups is enough to saturate the lambdas of the target. - (if tyargs |> List.exists (fun t -> match t with TType_measure _ -> false | _ -> true) then 1 else 0) + args.Length = arities && - if size <= cenv.settings.lambdaInlineThreshold + args.Length then true - // Not inlining lambda near, size too big: - else false - )) -> - - let isBaseCall = not (List.isEmpty args) && - match args[0] with - | Expr.Val (vref, _, _) when vref.IsBaseVal -> true - | _ -> false - - if isBaseCall then None else - - // Since Lazy`1 moved from FSharp.Core to mscorlib on .NET 4.0, inlining Lazy values from 2.0 will - // confuse the optimizer if the assembly is referenced on 4.0, since there will be no value to tie back - // to FSharp.Core - let isValFromLazyExtensions = - if g.compilingFSharpCore then - false - else - match finfo.Info with - | ValValue(vref, _) -> - match vref.ApparentEnclosingEntity with - | Parent tcr when (tyconRefEq g g.lazy_tcr_canon tcr) -> + // Considering inlining app + match finfo.Info with + | StripLambdaValue(lambdaId, arities, size, f2, f2ty) when + ( // Considering inlining lambda + cenv.optimizing + && cenv.settings.InlineLambdas + && not finfo.HasEffect + && + // Don't inline recursively! + not (Zset.contains lambdaId env.dontInline) + && ( // Check the number of argument groups is enough to saturate the lambdas of the target. + (if + tyargs + |> List.exists (fun t -> + match t with + | TType_measure _ -> false + | _ -> true) + then + 1 + else + 0) + + args.Length = arities + && if size <= cenv.settings.lambdaInlineThreshold + args.Length then + true + // Not inlining lambda near, size too big: + else + false)) + -> + + let isBaseCall = + not (List.isEmpty args) + && match args[0] with + | Expr.Val(vref, _, _) when vref.IsBaseVal -> true + | _ -> false + + if isBaseCall then + None + else + + // Since Lazy`1 moved from FSharp.Core to mscorlib on .NET 4.0, inlining Lazy values from 2.0 will + // confuse the optimizer if the assembly is referenced on 4.0, since there will be no value to tie back + // to FSharp.Core + let isValFromLazyExtensions = + if g.compilingFSharpCore then + false + else + match finfo.Info with + | ValValue(vref, _) -> + match vref.ApparentEnclosingEntity with + | Parent tcr when (tyconRefEq g g.lazy_tcr_canon tcr) -> match tcr.CompiledRepresentation with - | CompiledTypeRepr.ILAsmNamed(iltr, _, _) -> + | CompiledTypeRepr.ILAsmNamed(iltr, _, _) -> match iltr.Scope with | ILScopeRef.Assembly aref -> aref.Name = "FSharp.Core" | _ -> false | _ -> false + | _ -> false | _ -> false - | _ -> false - - if isValFromLazyExtensions then None else - let isSecureMethod = - match finfo.Info with - | ValValue(vref, _) -> - vref.Attribs |> List.exists (fun a -> (IsSecurityAttribute g cenv.amap cenv.casApplied a m) || (IsSecurityCriticalAttribute g a)) - | _ -> false - - if isSecureMethod then None else - - let isGetHashCode = - match finfo.Info with - | ValValue(vref, _) -> vref.DisplayName = "GetHashCode" && vref.IsCompilerGenerated - | _ -> false + if isValFromLazyExtensions then + None + else - if isGetHashCode then None else + let isSecureMethod = + match finfo.Info with + | ValValue(vref, _) -> + vref.Attribs + |> List.exists (fun a -> + (IsSecurityAttribute g cenv.amap cenv.casApplied a m) + || (IsSecurityCriticalAttribute g a)) + | _ -> false - let isApplicationPartialExpr = - match finfo.Info with - | ValValue (_, CurriedLambdaValue (_, _, _, expr, _) ) -> IsPartialExpr cenv env m expr - | _ -> false + if isSecureMethod then + None + else - if isApplicationPartialExpr then None else + let isGetHashCode = + match finfo.Info with + | ValValue(vref, _) -> vref.DisplayName = "GetHashCode" && vref.IsCompilerGenerated + | _ -> false - // Inlining lambda - let f2R = CopyExprForInlining cenv false f2 m + if isGetHashCode then + None + else - // Optimizing arguments after inlining + let isApplicationPartialExpr = + match finfo.Info with + | ValValue(_, CurriedLambdaValue(_, _, _, expr, _)) -> IsPartialExpr cenv env m expr + | _ -> false - // REVIEW: this is a cheapshot way of optimizing the arg expressions as well without the restriction of recursive - // inlining kicking into effect - let argsR = args |> List.map (fun e -> let eR, _einfo = OptimizeExpr cenv env e in eR) + if isApplicationPartialExpr then + None + else + + // Inlining lambda + let f2R = CopyExprForInlining cenv false f2 m + + // Optimizing arguments after inlining + + // REVIEW: this is a cheapshot way of optimizing the arg expressions as well without the restriction of recursive + // inlining kicking into effect + let argsR = + args |> List.map (fun e -> let eR, _einfo = OptimizeExpr cenv env e in eR) + + // Beta reduce. MakeApplicationAndBetaReduce g does all the hard work. + // Inlining: beta reducing + let exprR = MakeApplicationAndBetaReduce g (f2R, f2ty, [ tyargs ], argsR, m) + // Inlining: reoptimizing + Some( + OptimizeExpr + cenv + { env with + dontInline = Zset.add lambdaId env.dontInline + } + exprR + ) - // Beta reduce. MakeApplicationAndBetaReduce g does all the hard work. - // Inlining: beta reducing - let exprR = MakeApplicationAndBetaReduce g (f2R, f2ty, [tyargs], argsR, m) - // Inlining: reoptimizing - Some(OptimizeExpr cenv {env with dontInline= Zset.add lambdaId env.dontInline} exprR) - | _ -> None // Optimize the application of computed functions. // See https://github.com/fsharp/fslang-design/blob/master/tooling/FST-1034-lambda-optimizations.md // // Always lift 'let', 'letrec', sequentials and 'match' off computed functions so -// (let x = 1 in fexpr) arg ---> let x = 1 in fexpr arg -// (let rec binds in fexpr) arg ---> let rec binds in fexpr arg -// (e; fexpr) arg ---> e; fexpr arg +// (let x = 1 in fexpr) arg ---> let x = 1 in fexpr arg +// (let rec binds in fexpr) arg ---> let rec binds in fexpr arg +// (e; fexpr) arg ---> e; fexpr arg // (match e with pat1 -> func1 | pat2 -> func2) args --> (match e with pat1 -> func1 args | pat2 -> func2 args) // // This is always valid because functions are computed before arguments. @@ -3526,175 +4233,200 @@ and TryInlineApplication cenv env finfo (tyargs: TType list, args: Expr list, m) // inline F# computation expressions. // // The case of 'match' is particularly awkward because we are cloning 'args' on the right. We want to avoid -// this in the common case, so we first collect up all the "function holes" -// (let x = 1 in ) -// (let rec binds in ) -// (e; ) +// this in the common case, so we first collect up all the "function holes" +// (let x = 1 in ) +// (let rec binds in ) +// (e; ) // (match e with pat1 -> | pat2 -> ) // then work out if we only have one of them. While collecting up the holes we build up a function to rebuild the // overall expression given new expressions ("func" --> "func args" and its optimization). // -// If there a multiple holes, we had a "match" somewhere, and we abandon OptimizeApplication and simply apply the +// If there a multiple holes, we had a "match" somewhere, and we abandon OptimizeApplication and simply apply the // function to the arguments at each hole (copying the arguments), then reoptimize the whole result. // // If there is a single hole, we proceed with OptimizeApplication and StripPreComputationsFromComputedFunction g f0 args mkApp = - + // Identify sub-expressions that are the lambda functions to apply. // There may be more than one because of multiple 'match' branches. let rec strip (f: Expr) : Expr list * (Expr list -> Expr) = - match stripExpr f with - | Expr.Let (bind, bodyExpr, m, _) -> - let fs, remake = strip bodyExpr + match stripExpr f with + | Expr.Let(bind, bodyExpr, m, _) -> + let fs, remake = strip bodyExpr fs, (remake >> mkLetBind m bind) - | Expr.LetRec (binds, bodyExpr, m, _) -> - let fs, remake = strip bodyExpr + | Expr.LetRec(binds, bodyExpr, m, _) -> + let fs, remake = strip bodyExpr fs, (remake >> mkLetRecBinds m binds) - | Expr.Sequential (x1, bodyExpr, NormalSeq, m) -> - let fs, remake = strip bodyExpr - fs, (remake >> (fun bodyExpr2 -> Expr.Sequential (x1, bodyExpr2, NormalSeq, m))) + | Expr.Sequential(x1, bodyExpr, NormalSeq, m) -> + let fs, remake = strip bodyExpr + fs, (remake >> (fun bodyExpr2 -> Expr.Sequential(x1, bodyExpr2, NormalSeq, m))) // Matches which compute a different function on each branch are awkward, see above. - | Expr.Match (spMatch, mExpr, dtree, targets, dflt, _ty) when targets.Length <= 2 -> - let fsl, targetRemakes = - targets - |> Array.map (fun (TTarget(vs, bodyExpr, flags)) -> + | Expr.Match(spMatch, mExpr, dtree, targets, dflt, _ty) when targets.Length <= 2 -> + let fsl, targetRemakes = + targets + |> Array.map (fun (TTarget(vs, bodyExpr, flags)) -> let fs, remake = strip bodyExpr fs, (fun holes -> TTarget(vs, remake holes, flags))) |> Array.unzip - let fs = List.concat fsl + let fs = List.concat fsl let chunkSizes = Array.map List.length fsl - let remake (newExprs: Expr list) = - let newExprsInChunks, _ = - ((newExprs,0), chunkSizes) ||> Array.mapFold (fun (acc,i) chunkSize -> - let chunk = acc[0..chunkSize-1] + + let remake (newExprs: Expr list) = + let newExprsInChunks, _ = + ((newExprs, 0), chunkSizes) + ||> Array.mapFold (fun (acc, i) chunkSize -> + let chunk = acc[0 .. chunkSize - 1] let acc = acc[chunkSize..] - chunk, (acc, i+chunkSize)) - let targetsR = (newExprsInChunks, targetRemakes) ||> Array.map2 (fun newExprsChunk targetRemake -> targetRemake newExprsChunk) + chunk, (acc, i + chunkSize)) + + let targetsR = + (newExprsInChunks, targetRemakes) + ||> Array.map2 (fun newExprsChunk targetRemake -> targetRemake newExprsChunk) + let tyR = tyOfExpr g targetsR[0].TargetExpression - Expr.Match (spMatch, mExpr, dtree, targetsR, dflt, tyR) + Expr.Match(spMatch, mExpr, dtree, targetsR, dflt, tyR) + fs, remake - | Expr.DebugPoint (dp, innerExpr) -> - let fs, remake = strip innerExpr - fs, (remake >> (fun innerExprR -> Expr.DebugPoint (dp, innerExprR))) - - | _ -> - [f], (fun newExprs -> (assert (List.isSingleton newExprs)); List.head newExprs) - - match strip f0 with - | [f], remake -> - // If the computed function has only one interesting function result expression then progress as normal - Choice2Of2 (f, (fun x -> remake [x])) - | fs, remake -> - // If there is a match with multiple branches then apply each function to a copy of the arguments, - // remake the whole expression and return an indicator to reoptimize that. - let applied = - fs |> List.mapi (fun i f -> - let argsR = if i = 0 then args else List.map (copyExpr g CloneAll) args - mkApp f argsR) - let remade = remake applied - Choice1Of2 remade + | Expr.DebugPoint(dp, innerExpr) -> + let fs, remake = strip innerExpr + fs, (remake >> (fun innerExprR -> Expr.DebugPoint(dp, innerExprR))) + + | _ -> + [ f ], + (fun newExprs -> + (assert (List.isSingleton newExprs)) + List.head newExprs) + + match strip f0 with + | [ f ], remake -> + // If the computed function has only one interesting function result expression then progress as normal + Choice2Of2(f, (fun x -> remake [ x ])) + | fs, remake -> + // If there is a match with multiple branches then apply each function to a copy of the arguments, + // remake the whole expression and return an indicator to reoptimize that. + let applied = + fs + |> List.mapi (fun i f -> + let argsR = if i = 0 then args else List.map (copyExpr g CloneAll) args + mkApp f argsR) + + let remade = remake applied + Choice1Of2 remade /// When optimizing a function in an application, use the whole range including arguments for the range /// to apply to 'inline' code and OptimizeFuncInApplication cenv env f0 mWithArgs = let f0 = stripExpr f0 + match f0 with - | Expr.Val (v, _vFlags, _) -> - OptimizeVal cenv env f0 (v, mWithArgs) - | _ -> - OptimizeExpr cenv env f0 + | Expr.Val(v, _vFlags, _) -> OptimizeVal cenv env f0 (v, mWithArgs) + | _ -> OptimizeExpr cenv env f0 /// Optimize/analyze an application of a function to type and term arguments and OptimizeApplication cenv env (f0, f0ty, tyargs, args, m) = let g = cenv.g // trying to devirtualize - match TryDevirtualizeApplication cenv env (f0, tyargs, args, m) with - | Some res -> + match TryDevirtualizeApplication cenv env (f0, tyargs, args, m) with + | Some res -> // devirtualized res - | None -> - let optf0, finfo = OptimizeFuncInApplication cenv env f0 m - - match StripPreComputationsFromComputedFunction g optf0 args (fun f argsR -> MakeApplicationAndBetaReduce g (f, tyOfExpr g f, [tyargs], argsR, f.Range)) with - | Choice1Of2 remade -> - OptimizeExpr cenv env remade - | Choice2Of2 (newf0, remake) -> - - match TryInlineApplication cenv env finfo (tyargs, args, m) with - | Some (res, info) -> - // inlined - (res |> remake), info - - | _ -> - - let shapes = - match newf0 with - | Expr.Val (vref, _, _) -> - match vref.ValReprInfo with - | Some(ValReprInfo(_, detupArgsL, _)) -> - let nargs = args.Length - let nDetupArgsL = detupArgsL.Length - let nShapes = min nargs nDetupArgsL - let detupArgsShapesL = - List.truncate nShapes detupArgsL - |> List.map (fun detupArgs -> - match detupArgs with - | [] | [_] -> UnknownValue - | _ -> TupleValue(Array.ofList (List.map (fun _ -> UnknownValue) detupArgs))) - List.zip (detupArgsShapesL @ List.replicate (nargs - nShapes) UnknownValue) args - | _ -> args |> List.map (fun arg -> UnknownValue, arg) - | _ -> args |> List.map (fun arg -> UnknownValue, arg) - - let newArgs, arginfos = OptimizeExprsThenReshapeAndConsiderSplits cenv env shapes - // beta reducing - let reducedExpr = MakeApplicationAndBetaReduce g (newf0, f0ty, [tyargs], newArgs, m) - let newExpr = reducedExpr |> remake - - match newf0, reducedExpr with - | (Expr.Lambda _ | Expr.TyLambda _), Expr.Let _ -> - // we beta-reduced, hence reoptimize - OptimizeExpr cenv env newExpr - | _ -> - // regular - - // Determine if this application is a critical tailcall - let mayBeCriticalTailcall = - match newf0 with - | KnownValApp(vref, _typeArgs, otherArgs) -> - - // Check if this is a call to a function of known arity that has been inferred to not be a critical tailcall when used as a direct call - // This includes recursive calls to the function being defined (in which case we get a non-critical, closed-world tailcall). - // Note we also have to check the argument count to ensure this is a direct call (or a partial application). - let doesNotMakeCriticalTailcall = - vref.MakesNoCriticalTailcalls || - (let valInfoForVal = GetInfoForValWithCheck cenv env m vref in valInfoForVal.ValMakesNoCriticalTailcalls) || - (match env.functionVal with | None -> false | Some (v, _) -> valEq vref.Deref v) - if doesNotMakeCriticalTailcall then - let numArgs = otherArgs.Length + newArgs.Length - match vref.ValReprInfo with - | Some i -> numArgs > i.NumCurriedArgs - | None -> - match env.functionVal with - | Some (_v, i) -> numArgs > i.NumCurriedArgs - | None -> true // over-application of a known function, which presumably returns a function. This counts as an indirect call - else - true // application of a function that may make a critical tailcall - + | None -> + let optf0, finfo = OptimizeFuncInApplication cenv env f0 m + + match + StripPreComputationsFromComputedFunction g optf0 args (fun f argsR -> + MakeApplicationAndBetaReduce g (f, tyOfExpr g f, [ tyargs ], argsR, f.Range)) + with + | Choice1Of2 remade -> OptimizeExpr cenv env remade + | Choice2Of2(newf0, remake) -> + + match TryInlineApplication cenv env finfo (tyargs, args, m) with + | Some(res, info) -> + // inlined + (res |> remake), info + + | _ -> + + let shapes = + match newf0 with + | Expr.Val(vref, _, _) -> + match vref.ValReprInfo with + | Some(ValReprInfo(_, detupArgsL, _)) -> + let nargs = args.Length + let nDetupArgsL = detupArgsL.Length + let nShapes = min nargs nDetupArgsL + + let detupArgsShapesL = + List.truncate nShapes detupArgsL + |> List.map (fun detupArgs -> + match detupArgs with + | [] + | [ _ ] -> UnknownValue + | _ -> TupleValue(Array.ofList (List.map (fun _ -> UnknownValue) detupArgs))) + + List.zip (detupArgsShapesL @ List.replicate (nargs - nShapes) UnknownValue) args + | _ -> args |> List.map (fun arg -> UnknownValue, arg) + | _ -> args |> List.map (fun arg -> UnknownValue, arg) + + let newArgs, arginfos = OptimizeExprsThenReshapeAndConsiderSplits cenv env shapes + // beta reducing + let reducedExpr = + MakeApplicationAndBetaReduce g (newf0, f0ty, [ tyargs ], newArgs, m) + + let newExpr = reducedExpr |> remake + + match newf0, reducedExpr with + | (Expr.Lambda _ | Expr.TyLambda _), Expr.Let _ -> + // we beta-reduced, hence reoptimize + OptimizeExpr cenv env newExpr | _ -> - // All indirect calls (calls to unknown functions) are assumed to be critical tailcalls - true - - newExpr, { TotalSize=finfo.TotalSize + AddTotalSizes arginfos - FunctionSize=finfo.FunctionSize + AddFunctionSizes arginfos - HasEffect=true - MightMakeCriticalTailcall = mayBeCriticalTailcall - Info=ValueOfExpr newExpr } - + // regular + + // Determine if this application is a critical tailcall + let mayBeCriticalTailcall = + match newf0 with + | KnownValApp(vref, _typeArgs, otherArgs) -> + + // Check if this is a call to a function of known arity that has been inferred to not be a critical tailcall when used as a direct call + // This includes recursive calls to the function being defined (in which case we get a non-critical, closed-world tailcall). + // Note we also have to check the argument count to ensure this is a direct call (or a partial application). + let doesNotMakeCriticalTailcall = + vref.MakesNoCriticalTailcalls + || (let valInfoForVal = GetInfoForValWithCheck cenv env m vref in valInfoForVal.ValMakesNoCriticalTailcalls) + || (match env.functionVal with + | None -> false + | Some(v, _) -> valEq vref.Deref v) + + if doesNotMakeCriticalTailcall then + let numArgs = otherArgs.Length + newArgs.Length + + match vref.ValReprInfo with + | Some i -> numArgs > i.NumCurriedArgs + | None -> + match env.functionVal with + | Some(_v, i) -> numArgs > i.NumCurriedArgs + | None -> true // over-application of a known function, which presumably returns a function. This counts as an indirect call + else + true // application of a function that may make a critical tailcall + + | _ -> + // All indirect calls (calls to unknown functions) are assumed to be critical tailcalls + true + + newExpr, + { + TotalSize = finfo.TotalSize + AddTotalSizes arginfos + FunctionSize = finfo.FunctionSize + AddFunctionSizes arginfos + HasEffect = true + MightMakeCriticalTailcall = mayBeCriticalTailcall + Info = ValueOfExpr newExpr + } + /// Extract a sequence of pipe-right operations (note the pipe-right operator is left-associative /// so we start with the full thing and descend down taking apps off the end first) /// The pipeline begins with a |>, ||> or |||> @@ -3703,20 +4435,17 @@ and getPipes g expr acc = // the pipeline. // // For example - // let test () = x |> f + // let test () = x |> f // initially has a debug point covering "x |> f", e.g. // let test () = DP(x |> f) // This is dreplaced by // let test () = DP(x) |> DP(f) match stripDebugPoints expr with - | OpPipeRight g (resType, xExpr, fExpr, m) -> - getPipes g xExpr (([xExpr.Range], resType, fExpr, m) :: acc) - | OpPipeRight2 g (resType, x1Expr, x2Expr, fExpr, m) -> - [x1Expr; x2Expr], (([x1Expr.Range; x2Expr.Range], resType, fExpr, m) :: acc) + | OpPipeRight g (resType, xExpr, fExpr, m) -> getPipes g xExpr (([ xExpr.Range ], resType, fExpr, m) :: acc) + | OpPipeRight2 g (resType, x1Expr, x2Expr, fExpr, m) -> [ x1Expr; x2Expr ], (([ x1Expr.Range; x2Expr.Range ], resType, fExpr, m) :: acc) | OpPipeRight3 g (resType, x1Expr, x2Expr, x3Expr, fExpr, m) -> - [x1Expr; x2Expr; x3Expr], (([x1Expr.Range; x2Expr.Range; x3Expr.Range], resType, fExpr, m) :: acc) - | _ -> - [expr], acc + [ x1Expr; x2Expr; x3Expr ], (([ x1Expr.Range; x2Expr.Range; x3Expr.Range ], resType, fExpr, m) :: acc) + | _ -> [ expr ], acc /// In debug code, process a pipe-right manually to lay down the debug point for the application of the function after /// the evaluation of the argument, all the way down the chain. @@ -3725,7 +4454,7 @@ and OptimizeDebugPipeRights cenv env expr = env.methEnv.pipelineCount <- env.methEnv.pipelineCount + 1 let xs0, pipes = getPipes g expr [] - + let xs0R, xs0Infos = OptimizeExprsThenConsiderSplits cenv env xs0 let xs0Info = CombineValueInfosUnknown xs0Infos @@ -3744,96 +4473,131 @@ and OptimizeDebugPipeRights cenv env expr = let fR, finfo = OptimizeExpr cenv env fExpr let app = mkApps g ((fR, fType), [], prevInputs, fRange) let expr = mkDebugPoint fRange app - let info = CombineValueInfosUnknown [finfo; prevInputInfo] + let info = CombineValueInfosUnknown [ finfo; prevInputInfo ] expr, info // Mid points in the chain // ... |> fMid |> rest // turn into let-binding on an intermediate pipe stage - // let pipe-stage-n = fMid + // let pipe-stage-n = fMid // rest // with a breakpoint on the binding // let pipesBinder = - List.foldBack + List.foldBack (fun (i, (xsRange, resType, fExpr: Expr, _)) binder -> let fRange = fExpr.Range let fType = tyOfExpr g fExpr - let name = $"Pipe #%d{env.methEnv.pipelineCount} stage #%d{i+1} at line %d{fRange.StartLine}" + + let name = + $"Pipe #%d{env.methEnv.pipelineCount} stage #%d{i + 1} at line %d{fRange.StartLine}" + let stageVal, stageValExpr = mkLocal (List.reduce unionRanges xsRange) name resType let fR, finfo = OptimizeExpr cenv env fExpr - let restExpr, restInfo = binder ([stageValExpr], finfo) - let newBinder (ves, info) = + let restExpr, restInfo = binder ([ stageValExpr ], finfo) + + let newBinder (ves, info) = // The range used for the 'let' expression is only the 'f' in x |> f let app = mkApps g ((fR, fType), [], ves, fRange) let appDebugPoint = DebugPointAtBinding.Yes fRange let expr = mkLet appDebugPoint fRange stageVal app restExpr - let info = CombineValueInfosUnknown [info; restInfo] + let info = CombineValueInfosUnknown [ info; restInfo ] expr, info - newBinder - ) - (List.indexed pipesFront) - binderLast - + + newBinder) + (List.indexed pipesFront) + binderLast + // The first point in the chain is similar - // let = x + // let = x // rest // with a breakpoint on the pipe-input binding let nxs0R = xs0R.Length + let inputVals, inputValExprs = xs0R - |> List.mapi (fun i x0R -> - let nm = $"Pipe #%d{env.methEnv.pipelineCount} input" + (if nxs0R > 1 then " #" + string (i+1) else "") + $" at line %d{x0R.Range.StartLine}" + |> List.mapi (fun i x0R -> + let nm = + $"Pipe #%d{env.methEnv.pipelineCount} input" + + (if nxs0R > 1 then " #" + string (i + 1) else "") + + $" at line %d{x0R.Range.StartLine}" + mkLocal x0R.Range nm (tyOfExpr g x0R)) |> List.unzip + let pipesExprR, pipesInfo = pipesBinder (inputValExprs, xs0Info) - + // Build up the chain of 'let' related to the first input - let expr = + let expr = List.foldBack2 - (fun (x0R: Expr) inputVal e -> + (fun (x0R: Expr) inputVal e -> let xRange0 = x0R.Range - mkLet (DebugPointAtBinding.Yes xRange0) expr.Range inputVal x0R e) - xs0R + mkLet (DebugPointAtBinding.Yes xRange0) expr.Range inputVal x0R e) + xs0R inputVals pipesExprR - expr, { pipesInfo with HasEffect=true} - + + expr, { pipesInfo with HasEffect = true } + and OptimizeFSharpDelegateInvoke cenv env (delInvokeRef, delExpr, delInvokeTy, tyargs, delInvokeArg, m) = let g = cenv.g let optf0, finfo = OptimizeExpr cenv env delExpr - match StripPreComputationsFromComputedFunction g optf0 [delInvokeArg] (fun f delInvokeArgsR -> MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, f, delInvokeTy, tyargs, List.head delInvokeArgsR, m)) with - | Choice1Of2 remade -> - OptimizeExpr cenv env remade - | Choice2Of2 (newf0, remake) -> - - let newDelInvokeArgs, arginfos = OptimizeExprsThenConsiderSplits cenv env [delInvokeArg] - let newDelInvokeArg = List.head newDelInvokeArgs - let reducedExpr = MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, newf0, delInvokeTy, tyargs, newDelInvokeArg, m) - let newExpr = reducedExpr |> remake - match newf0, reducedExpr with - | Expr.Obj _, Expr.Let _ -> - // we beta-reduced, hence reoptimize - OptimizeExpr cenv env newExpr - | _ -> - // no reduction, return - newExpr, { TotalSize=finfo.TotalSize + AddTotalSizes arginfos - FunctionSize=finfo.FunctionSize + AddFunctionSizes arginfos - HasEffect=true - MightMakeCriticalTailcall = true - Info=ValueOfExpr newExpr } + match + StripPreComputationsFromComputedFunction g optf0 [ delInvokeArg ] (fun f delInvokeArgsR -> + MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, f, delInvokeTy, tyargs, List.head delInvokeArgsR, m)) + with + | Choice1Of2 remade -> OptimizeExpr cenv env remade + | Choice2Of2(newf0, remake) -> + + let newDelInvokeArgs, arginfos = + OptimizeExprsThenConsiderSplits cenv env [ delInvokeArg ] + + let newDelInvokeArg = List.head newDelInvokeArgs + + let reducedExpr = + MakeFSharpDelegateInvokeAndTryBetaReduce g (delInvokeRef, newf0, delInvokeTy, tyargs, newDelInvokeArg, m) + + let newExpr = reducedExpr |> remake + + match newf0, reducedExpr with + | Expr.Obj _, Expr.Let _ -> + // we beta-reduced, hence reoptimize + OptimizeExpr cenv env newExpr + | _ -> + // no reduction, return + newExpr, + { + TotalSize = finfo.TotalSize + AddTotalSizes arginfos + FunctionSize = finfo.FunctionSize + AddFunctionSizes arginfos + HasEffect = true + MightMakeCriticalTailcall = true + Info = ValueOfExpr newExpr + } /// Optimize/analyze a lambda expression -and OptimizeLambdas (vspec: Val option) cenv env valReprInfo expr exprTy = +and OptimizeLambdas (vspec: Val option) cenv env valReprInfo expr exprTy = let g = cenv.g match expr with - | Expr.Lambda (lambdaId, _, _, _, _, m, _) - | Expr.TyLambda (lambdaId, _, _, m, _) -> - let env = { env with methEnv = { pipelineCount = 0 }} - let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = IteratedAdjustLambdaToMatchValReprInfo g cenv.amap valReprInfo expr - let env = { env with functionVal = (match vspec with None -> None | Some v -> Some (v, valReprInfo)) } + | Expr.Lambda(lambdaId, _, _, _, _, m, _) + | Expr.TyLambda(lambdaId, _, _, m, _) -> + let env = + { env with + methEnv = { pipelineCount = 0 } + } + + let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = + IteratedAdjustLambdaToMatchValReprInfo g cenv.amap valReprInfo expr + + let env = + { env with + functionVal = + (match vspec with + | None -> None + | Some v -> Some(v, valReprInfo)) + } + let env = Option.foldBack (BindInternalValToUnknown cenv) ctorThisValOpt env let env = Option.foldBack (BindInternalValToUnknown cenv) baseValOpt env let env = BindTyparsToUnknown tps env @@ -3841,321 +4605,417 @@ and OptimizeLambdas (vspec: Val option) cenv env valReprInfo expr exprTy = let bodyR, bodyinfo = OptimizeExpr cenv env body let exprR = mkMemberLambdas g m tps ctorThisValOpt baseValOpt vsl (bodyR, bodyTy) let arities = vsl.Length - let arities = if isNil tps then arities else 1+arities + let arities = if isNil tps then arities else 1 + arities let bsize = bodyinfo.TotalSize - + // Set the flag on the value indicating that direct calls can avoid a tailcall (which are expensive on .NET x86) // MightMakeCriticalTailcall is true whenever the body of the method may itself do a useful tailcall, e.g. has // an application in the last position. - match vspec with - | Some v -> - if not bodyinfo.MightMakeCriticalTailcall then - v.SetMakesNoCriticalTailcalls() - - // UNIT TEST HOOK: report analysis results for the first optimization phase - if cenv.settings.reportingPhase && not v.IsCompilerGenerated then - if cenv.settings.reportNoNeedToTailcall then + match vspec with + | Some v -> + if not bodyinfo.MightMakeCriticalTailcall then + v.SetMakesNoCriticalTailcalls() + + // UNIT TEST HOOK: report analysis results for the first optimization phase + if cenv.settings.reportingPhase && not v.IsCompilerGenerated then + if cenv.settings.reportNoNeedToTailcall then if bodyinfo.MightMakeCriticalTailcall then - printfn "value %s at line %d may make a critical tailcall" v.DisplayName v.Range.StartLine - else - printfn "value %s at line %d does not make a critical tailcall" v.DisplayName v.Range.StartLine - if cenv.settings.reportTotalSizes then - printfn "value %s at line %d has total size %d" v.DisplayName v.Range.StartLine bodyinfo.TotalSize - if cenv.settings.reportFunctionSizes then + printfn "value %s at line %d may make a critical tailcall" v.DisplayName v.Range.StartLine + else + printfn "value %s at line %d does not make a critical tailcall" v.DisplayName v.Range.StartLine + + if cenv.settings.reportTotalSizes then + printfn "value %s at line %d has total size %d" v.DisplayName v.Range.StartLine bodyinfo.TotalSize + + if cenv.settings.reportFunctionSizes then printfn "value %s at line %d has method size %d" v.DisplayName v.Range.StartLine bodyinfo.FunctionSize - if cenv.settings.reportHasEffect then + + if cenv.settings.reportHasEffect then if bodyinfo.HasEffect then - printfn "function %s at line %d causes side effects or may not terminate" v.DisplayName v.Range.StartLine - else - printfn "function %s at line %d causes no side effects" v.DisplayName v.Range.StartLine - | _ -> - () - - // can't inline any values with semi-recursive object references to self or base - let value_ = - match baseValOpt with - | None -> CurriedLambdaValue (lambdaId, arities, bsize, exprR, exprTy) - | Some baseVal -> - let fvs = freeInExpr CollectLocals bodyR - if fvs.UsesMethodLocalConstructs || fvs.FreeLocals.Contains baseVal then - UnknownValue - else - let expr2 = mkMemberLambdas g m tps ctorThisValOpt None vsl (bodyR, bodyTy) - CurriedLambdaValue (lambdaId, arities, bsize, expr2, exprTy) - - let estimatedSize = + printfn "function %s at line %d causes side effects or may not terminate" v.DisplayName v.Range.StartLine + else + printfn "function %s at line %d causes no side effects" v.DisplayName v.Range.StartLine + | _ -> () + + // can't inline any values with semi-recursive object references to self or base + let value_ = + match baseValOpt with + | None -> CurriedLambdaValue(lambdaId, arities, bsize, exprR, exprTy) + | Some baseVal -> + let fvs = freeInExpr CollectLocals bodyR + + if fvs.UsesMethodLocalConstructs || fvs.FreeLocals.Contains baseVal then + UnknownValue + else + let expr2 = mkMemberLambdas g m tps ctorThisValOpt None vsl (bodyR, bodyTy) + CurriedLambdaValue(lambdaId, arities, bsize, expr2, exprTy) + + let estimatedSize = match vspec with | Some v when v.IsCompiledAsTopLevel -> methodDefnTotalSize | _ -> closureTotalSize - exprR, { TotalSize=bsize + estimatedSize (* estimate size of new syntactic closure - expensive, in contrast to a method *) - FunctionSize=1 - HasEffect=false - MightMakeCriticalTailcall = false - Info= value_ } + exprR, + { + TotalSize = bsize + estimatedSize (* estimate size of new syntactic closure - expensive, in contrast to a method *) + FunctionSize = 1 + HasEffect = false + MightMakeCriticalTailcall = false + Info = value_ + } - | _ -> - OptimizeExpr cenv env expr - -and OptimizeNewDelegateExpr cenv env (lambdaId, vsl, body, remake) = + | _ -> OptimizeExpr cenv env expr + +and OptimizeNewDelegateExpr cenv env (lambdaId, vsl, body, remake) = let g = cenv.g let env = List.foldBack (BindInternalValsToUnknown cenv) vsl env let bodyR, bodyinfo = OptimizeExpr cenv env body let arities = vsl.Length let bsize = bodyinfo.TotalSize let exprR = remake bodyR - let value_ = CurriedLambdaValue (lambdaId, arities, bsize, exprR, tyOfExpr g exprR) - - exprR, { TotalSize=bsize + closureTotalSize (* estimate size of new syntactic closure - expensive, in contrast to a method *) - FunctionSize=1 - HasEffect=false - MightMakeCriticalTailcall = false - Info= value_ } + let value_ = CurriedLambdaValue(lambdaId, arities, bsize, exprR, tyOfExpr g exprR) + + exprR, + { + TotalSize = bsize + closureTotalSize (* estimate size of new syntactic closure - expensive, in contrast to a method *) + FunctionSize = 1 + HasEffect = false + MightMakeCriticalTailcall = false + Info = value_ + } /// Recursive calls that first try to make an expression "fit" the shape /// where it is about to be consumed. -and OptimizeExprsThenReshapeAndConsiderSplits cenv env exprs = - match exprs with - | [] -> NoExprs +and OptimizeExprsThenReshapeAndConsiderSplits cenv env exprs = + match exprs with + | [] -> NoExprs | _ -> OptimizeList (OptimizeExprThenReshapeAndConsiderSplit cenv env) exprs -and OptimizeExprsThenConsiderSplits cenv env exprs = - match exprs with - | [] -> NoExprs +and OptimizeExprsThenConsiderSplits cenv env exprs = + match exprs with + | [] -> NoExprs | _ -> OptimizeList (OptimizeExprThenConsiderSplit cenv env) exprs -and OptimizeExprThenReshapeAndConsiderSplit cenv env (shape, e) = +and OptimizeExprThenReshapeAndConsiderSplit cenv env (shape, e) = OptimizeExprThenConsiderSplit cenv env (ReshapeExpr cenv (shape, e)) -and OptimizeDecisionTreeTargets cenv env m targets = +and OptimizeDecisionTreeTargets cenv env m targets = OptimizeList (OptimizeDecisionTreeTarget cenv env m) (Array.toList targets) -and ReshapeExpr cenv (shape, e) = +and ReshapeExpr cenv (shape, e) = let g = cenv.g - match shape, e with - | TupleValue subshapes, Expr.Val (_vref, _vFlags, m) -> + + match shape, e with + | TupleValue subshapes, Expr.Val(_vref, _vFlags, m) -> let tinst = destRefTupleTy g (tyOfExpr g e) let subshapes = Array.toList subshapes - mkRefTupled g m (List.mapi (fun i subshape -> ReshapeExpr cenv (subshape, mkTupleFieldGet g (tupInfoRef, e, tinst, i, m))) subshapes) tinst - | _ -> - e -and OptimizeExprThenConsiderSplit cenv env e = - let eR, einfo = OptimizeExpr cenv env e - // ALWAYS consider splits for enormous sub terms here - otherwise we will create invalid .NET programs - ConsiderSplitToMethod true cenv.settings.veryBigExprSize cenv env (eR, einfo) + mkRefTupled + g + m + (List.mapi (fun i subshape -> ReshapeExpr cenv (subshape, mkTupleFieldGet g (tupInfoRef, e, tinst, i, m))) subshapes) + tinst + | _ -> e + +and OptimizeExprThenConsiderSplit cenv env e = + let eR, einfo = OptimizeExpr cenv env e + // ALWAYS consider splits for enormous sub terms here - otherwise we will create invalid .NET programs + ConsiderSplitToMethod true cenv.settings.veryBigExprSize cenv env (eR, einfo) /// Decide whether to List.unzip a sub-expression into a new method -and ComputeSplitToMethodCondition flag threshold cenv env (e: Expr, einfo) = +and ComputeSplitToMethodCondition flag threshold cenv env (e: Expr, einfo) = let g = cenv.g - flag && + + flag + && // NOTE: The method splitting optimization is completely disabled if we are not taking tailcalls. - cenv.emitTailcalls && - not env.disableMethodSplitting && - einfo.FunctionSize >= threshold && + cenv.emitTailcalls + && not env.disableMethodSplitting + && einfo.FunctionSize >= threshold + && + + // We can only split an expression out as a method if certain conditions are met. + // It can't use any protected or base calls, rethrow(), byrefs etc. + let m = e.Range in - // We can only split an expression out as a method if certain conditions are met. - // It can't use any protected or base calls, rethrow(), byrefs etc. - let m = e.Range (let fvs = freeInExpr (CollectLocalsWithStackGuard()) e - not fvs.UsesUnboundRethrow && - not fvs.UsesMethodLocalConstructs && - fvs.FreeLocals |> Zset.forall (fun v -> - // no direct-self-recursive references - not (env.dontSplitVars.ContainsVal v) && - (v.ValReprInfo.IsSome || - // All the free variables (apart from things with an arity, i.e. compiled as methods) should be normal, i.e. not base/this etc. - (v.BaseOrThisInfo = NormalVal && - // None of them should be byrefs - not (isByrefLikeTy g m v.Type) && - // None of them should be local polymorphic constrained values - not (IsGenericValWithGenericConstraints g v) && - // None of them should be mutable - not v.IsMutable)))) && - not (isByrefLikeTy g m (tyOfExpr g e)) - -and ConsiderSplitToMethod flag threshold cenv env (e, einfo) = + + not fvs.UsesUnboundRethrow + && not fvs.UsesMethodLocalConstructs + && fvs.FreeLocals + |> Zset.forall (fun v -> + // no direct-self-recursive references + not (env.dontSplitVars.ContainsVal v) + && (v.ValReprInfo.IsSome + || + // All the free variables (apart from things with an arity, i.e. compiled as methods) should be normal, i.e. not base/this etc. + (v.BaseOrThisInfo = NormalVal + && + // None of them should be byrefs + not (isByrefLikeTy g m v.Type) + && + // None of them should be local polymorphic constrained values + not (IsGenericValWithGenericConstraints g v) + && + // None of them should be mutable + not v.IsMutable)))) + && not (isByrefLikeTy g m (tyOfExpr g e)) + +and ConsiderSplitToMethod flag threshold cenv env (e, einfo) = let g = cenv.g + if ComputeSplitToMethodCondition flag threshold cenv env (e, einfo) then let m = e.Range let uv, _ue = mkCompGenLocal m "unitVar" g.unit_ty let ty = tyOfExpr g e - let nm = - match env.latestBoundId with - | Some id -> id.idText+suffixForVariablesThatMayNotBeEliminated - | None -> suffixForVariablesThatMayNotBeEliminated + + let nm = + match env.latestBoundId with + | Some id -> id.idText + suffixForVariablesThatMayNotBeEliminated + | None -> suffixForVariablesThatMayNotBeEliminated + let fv, fe = mkCompGenLocal m nm (mkFunTy g g.unit_ty ty) - mkInvisibleLet m fv (mkLambda m uv (e, ty)) - (primMkApp (fe, (mkFunTy g g.unit_ty ty)) [] [mkUnit g m] m), - {einfo with FunctionSize=callSize } + + mkInvisibleLet m fv (mkLambda m uv (e, ty)) (primMkApp (fe, (mkFunTy g g.unit_ty ty)) [] [ mkUnit g m ] m), + { einfo with FunctionSize = callSize } else - e, einfo + e, einfo /// Optimize/analyze a pattern matching expression and OptimizeMatch cenv env (spMatch, mExpr, dtree, targets, m, ty) = - // REVIEW: consider collecting, merging and using information flowing through each line of the decision tree to each target - let dtreeR, dinfo = OptimizeDecisionTree cenv env m dtree - let targetsR, tinfos = OptimizeDecisionTreeTargets cenv env m targets + // REVIEW: consider collecting, merging and using information flowing through each line of the decision tree to each target + let dtreeR, dinfo = OptimizeDecisionTree cenv env m dtree + let targetsR, tinfos = OptimizeDecisionTreeTargets cenv env m targets OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty) and OptimizeMatchPart2 cenv (spMatch, mExpr, dtreeR, targetsR, dinfo, tinfos, m, ty) = - let newExpr, newInfo = RebuildOptimizedMatch (spMatch, mExpr, m, ty, dtreeR, targetsR, dinfo, tinfos) - let newExpr2 = if not cenv.settings.LocalOptimizationsEnabled then newExpr else CombineBoolLogic newExpr + let newExpr, newInfo = + RebuildOptimizedMatch(spMatch, mExpr, m, ty, dtreeR, targetsR, dinfo, tinfos) + + let newExpr2 = + if not cenv.settings.LocalOptimizationsEnabled then + newExpr + else + CombineBoolLogic newExpr + newExpr2, newInfo -and CombineMatchInfos dinfo tinfo = - { TotalSize = dinfo.TotalSize + tinfo.TotalSize - FunctionSize = dinfo.FunctionSize + tinfo.FunctionSize - HasEffect = dinfo.HasEffect || tinfo.HasEffect - MightMakeCriticalTailcall=tinfo.MightMakeCriticalTailcall // discard tailcall info from decision tree since it's not in tailcall position - Info= UnknownValue } +and CombineMatchInfos dinfo tinfo = + { + TotalSize = dinfo.TotalSize + tinfo.TotalSize + FunctionSize = dinfo.FunctionSize + tinfo.FunctionSize + HasEffect = dinfo.HasEffect || tinfo.HasEffect + MightMakeCriticalTailcall = tinfo.MightMakeCriticalTailcall // discard tailcall info from decision tree since it's not in tailcall position + Info = UnknownValue + } -and RebuildOptimizedMatch (spMatch, mExpr, m, ty, dtree, tgs, dinfo, tinfos) = - let tinfo = CombineValueInfosUnknown tinfos - let expr = mkAndSimplifyMatch spMatch mExpr m ty dtree tgs - let einfo = CombineMatchInfos dinfo tinfo - expr, einfo +and RebuildOptimizedMatch (spMatch, mExpr, m, ty, dtree, tgs, dinfo, tinfos) = + let tinfo = CombineValueInfosUnknown tinfos + let expr = mkAndSimplifyMatch spMatch mExpr m ty dtree tgs + let einfo = CombineMatchInfos dinfo tinfo + expr, einfo /// Optimize/analyze a target of a decision tree -and OptimizeDecisionTreeTarget cenv env _m (TTarget(vs, expr, flags)) = - let env = BindInternalValsToUnknown cenv vs env - let exprR, einfo = OptimizeExpr cenv env expr - let exprR, einfo = ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (exprR, einfo) - let evalueR = AbstractExprInfoByVars (vs, []) einfo.Info - TTarget(vs, exprR, flags), - { TotalSize=einfo.TotalSize - FunctionSize=einfo.FunctionSize - HasEffect=einfo.HasEffect - MightMakeCriticalTailcall = einfo.MightMakeCriticalTailcall - Info=evalueR } +and OptimizeDecisionTreeTarget cenv env _m (TTarget(vs, expr, flags)) = + let env = BindInternalValsToUnknown cenv vs env + let exprR, einfo = OptimizeExpr cenv env expr + + let exprR, einfo = + ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (exprR, einfo) + + let evalueR = AbstractExprInfoByVars (vs, []) einfo.Info + + TTarget(vs, exprR, flags), + { + TotalSize = einfo.TotalSize + FunctionSize = einfo.FunctionSize + HasEffect = einfo.HasEffect + MightMakeCriticalTailcall = einfo.MightMakeCriticalTailcall + Info = evalueR + } /// Optimize/analyze a decision tree and OptimizeDecisionTree cenv env m x = let g = cenv.g - match x with - | TDSuccess (es, n) -> - let esR, einfos = OptimizeExprsThenConsiderSplits cenv env es + + match x with + | TDSuccess(es, n) -> + let esR, einfos = OptimizeExprsThenConsiderSplits cenv env es TDSuccess(esR, n), CombineValueInfosUnknown einfos - | TDBind(bind, rest) -> - let (bind, binfo), envinner = OptimizeBinding cenv false env bind - let rest, rinfo = OptimizeDecisionTree cenv envinner m rest + | TDBind(bind, rest) -> + let (bind, binfo), envinner = OptimizeBinding cenv false env bind + let rest, rinfo = OptimizeDecisionTree cenv envinner m rest if ValueIsUsedOrHasEffect cenv (fun () -> (accFreeInDecisionTree CollectLocals rest emptyFreeVars).FreeLocals) (bind, binfo) then - let info = CombineValueInfosUnknown [rinfo;binfo] + let info = CombineValueInfosUnknown [ rinfo; binfo ] // try to fold the let-binding into a single result expression - match rest with - | TDSuccess([e], n) -> - let e, _adjust = TryEliminateLet cenv env bind e m - TDSuccess([e], n), info - | _ -> - TDBind(bind, rest), info - - else + match rest with + | TDSuccess([ e ], n) -> + let e, _adjust = TryEliminateLet cenv env bind e m + TDSuccess([ e ], n), info + | _ -> TDBind(bind, rest), info + + else rest, rinfo - | TDSwitch (e, cases, dflt, m) -> + | TDSwitch(e, cases, dflt, m) -> // We always duplicate boolean-typed guards prior to optimizing. This is work which really should be done in patcompile.fs // where we must duplicate "when" expressions to ensure uniqueness of bound variables. // // However, we are not allowed to copy expressions in patcompile.fs because type checking is not complete (see FSharp 1.0 bug 4821). // Hence we do it here. There is no doubt a better way to do this. - let e = if typeEquiv g (tyOfExpr g e) g.bool_ty then copyExpr g CloneAll e else e + let e = + if typeEquiv g (tyOfExpr g e) g.bool_ty then + copyExpr g CloneAll e + else + e OptimizeSwitch cenv env (e, cases, dflt, m) -and TryOptimizeDecisionTreeTest cenv test vinfo = +and TryOptimizeDecisionTreeTest cenv test vinfo = let g = cenv.g - match test, vinfo with - | DecisionTreeTest.UnionCase (c1, _), StripUnionCaseValue(c2, _) -> Some(g.unionCaseRefEq c1 c2) + + match test, vinfo with + | DecisionTreeTest.UnionCase(c1, _), StripUnionCaseValue(c2, _) -> Some(g.unionCaseRefEq c1 c2) | DecisionTreeTest.ArrayLength _, _ -> None - | DecisionTreeTest.Const c1, StripConstValue c2 -> if c1 = Const.Zero || c2 = Const.Zero then None else Some(c1=c2) - | DecisionTreeTest.IsNull, StripConstValue c2 -> Some(c2=Const.Zero) - | DecisionTreeTest.IsInst (_srcTy1, _tgtTy1), _ -> None + | DecisionTreeTest.Const c1, StripConstValue c2 -> + if c1 = Const.Zero || c2 = Const.Zero then + None + else + Some(c1 = c2) + | DecisionTreeTest.IsNull, StripConstValue c2 -> Some(c2 = Const.Zero) + | DecisionTreeTest.IsInst(_srcTy1, _tgtTy1), _ -> None // These should not occur in optimization | DecisionTreeTest.ActivePatternCase _, _ -> None | _ -> None -/// Optimize/analyze a switch construct from pattern matching +/// Optimize/analyze a switch construct from pattern matching and OptimizeSwitch cenv env (e, cases, dflt, m) = let g = cenv.g // Replace IsInst tests by calls to the helper for type tests, which may then get optimized let e, cases = match cases with - | [ TCase(DecisionTreeTest.IsInst (_srcTy, tgtTy), success)] -> + | [ TCase(DecisionTreeTest.IsInst(_srcTy, tgtTy), success) ] -> let testExpr = mkCallTypeTest g m tgtTy e - let testCases = [TCase(DecisionTreeTest.Const(Const.Bool true), success)] + let testCases = [ TCase(DecisionTreeTest.Const(Const.Bool true), success) ] testExpr, testCases | _ -> e, cases - let eR, einfo = OptimizeExpr cenv env e + let eR, einfo = OptimizeExpr cenv env e - let cases, dflt = + let cases, dflt = if cenv.settings.EliminateSwitch && not einfo.HasEffect then // Attempt to find a definite success, i.e. the first case where there is definite success - match (List.tryFind (function TCase(d2, _) when TryOptimizeDecisionTreeTest cenv d2 einfo.Info = Some true -> true | _ -> false) cases) with + match + (List.tryFind + (function + | TCase(d2, _) when TryOptimizeDecisionTreeTest cenv d2 einfo.Info = Some true -> true + | _ -> false) + cases) + with | Some(TCase(_, case)) -> [], Some case - | _ -> + | _ -> // Filter definite failures - cases |> List.filter (function TCase(d2, _) when TryOptimizeDecisionTreeTest cenv d2 einfo.Info = Some false -> false | _ -> true), + cases + |> List.filter (function + | TCase(d2, _) when TryOptimizeDecisionTreeTest cenv d2 einfo.Info = Some false -> false + | _ -> true), dflt else - cases, dflt + cases, dflt // OK, see what we are left with and continue - match cases, dflt with + match cases, dflt with | [], Some case -> OptimizeDecisionTree cenv env m case | _ -> OptimizeSwitchFallback cenv env (eR, einfo, cases, dflt, m) and OptimizeSwitchFallback cenv env (eR, einfo, cases, dflt, m) = let casesR, cinfos = - cases + cases |> List.map (fun (TCase(discrim, e)) -> let eR, einfo = OptimizeDecisionTree cenv env m e in TCase(discrim, eR), einfo) |> List.unzip + let dfltR, dinfos = match dflt with - | None -> None, [] - | Some df -> let dfR, einfo = OptimizeDecisionTree cenv env m df in Some dfR, [einfo] + | None -> None, [] + | Some df -> let dfR, einfo = OptimizeDecisionTree cenv env m df in Some dfR, [ einfo ] + let size = (dinfos.Length + cinfos.Length) * 2 - let info = CombineValueInfosUnknown (einfo :: cinfos @ dinfos) - let info = { info with TotalSize = info.TotalSize + size; FunctionSize = info.FunctionSize + size; } - TDSwitch (eR, casesR, dfltR, m), info + let info = CombineValueInfosUnknown(einfo :: cinfos @ dinfos) + + let info = + { info with + TotalSize = info.TotalSize + size + FunctionSize = info.FunctionSize + size + } + + TDSwitch(eR, casesR, dfltR, m), info and OptimizeBinding cenv isRec env (TBind(vref, expr, spBind)) = let g = cenv.g - try - + + try + // The aim here is to stop method splitting for direct-self-tailcalls. We do more than that: if an expression // occurs in the body of recursively defined values RVS, then we refuse to split // any expression that contains a reference to any value in RVS. // This doesn't prevent splitting for mutually recursive references. See FSharp 1.0 bug 2892. - let env = - if isRec then { env with dontSplitVars = env.dontSplitVars.Add vref () } - else env - - let exprOptimized, einfo = - let env = if vref.IsCompilerGenerated && Option.isSome env.latestBoundId then env else {env with latestBoundId=Some vref.Id} - let cenv = if vref.InlineInfo.ShouldInline then { cenv with optimizing=false} else cenv + let env = + if isRec then + { env with + dontSplitVars = env.dontSplitVars.Add vref () + } + else + env + + let exprOptimized, einfo = + let env = + if vref.IsCompilerGenerated && Option.isSome env.latestBoundId then + env + else + { env with + latestBoundId = Some vref.Id + } + + let cenv = + if vref.InlineInfo.ShouldInline then + { cenv with optimizing = false } + else + cenv + let arityInfo = InferValReprInfoOfBinding g AllowTypeDirectedDetupling.No vref expr - let exprOptimized, einfo = OptimizeLambdas (Some vref) cenv env arityInfo expr vref.Type - let size = localVarSize - exprOptimized, {einfo with FunctionSize=einfo.FunctionSize+size; TotalSize = einfo.TotalSize+size} + + let exprOptimized, einfo = + OptimizeLambdas (Some vref) cenv env arityInfo expr vref.Type + + let size = localVarSize + + exprOptimized, + { einfo with + FunctionSize = einfo.FunctionSize + size + TotalSize = einfo.TotalSize + size + } // Trim out optimization information for large lambdas we'll never inline - // Trim out optimization information for expressions that call protected members - let rec cut ivalue = + // Trim out optimization information for expressions that call protected members + let rec cut ivalue = match ivalue with - | CurriedLambdaValue (_, arities, size, body, _) -> - if size > (cenv.settings.lambdaInlineThreshold + arities + 2) then - // Discarding lambda for large binding - UnknownValue + | CurriedLambdaValue(_, arities, size, body, _) -> + if size > (cenv.settings.lambdaInlineThreshold + arities + 2) then + // Discarding lambda for large binding + UnknownValue else let fvs = freeInExpr CollectLocals body + if fvs.UsesMethodLocalConstructs then // Discarding lambda for binding because uses protected members UnknownValue - elif fvs.FreeLocals.ToArray() |> Seq.fold(fun acc v -> if not acc then v.Accessibility.IsPrivate else acc) false then + elif + fvs.FreeLocals.ToArray() + |> Seq.fold (fun acc v -> if not acc then v.Accessibility.IsPrivate else acc) false + then // Discarding lambda for binding because uses private members UnknownValue else @@ -4163,220 +5023,302 @@ and OptimizeBinding cenv isRec env (TBind(vref, expr, spBind)) = | ValValue(v, x) -> ValValue(v, cut x) | TupleValue a -> TupleValue(Array.map cut a) - | RecdValue (tcref, a) -> RecdValue(tcref, Array.map cut a) - | UnionCaseValue (a, b) -> UnionCaseValue (a, Array.map cut b) - | UnknownValue | ConstValue _ | ConstExprValue _ -> ivalue - | SizeValue(_, a) -> MakeSizedValueInfo (cut a) - - let einfo = if vref.ShouldInline || vref.InlineIfLambda then einfo else {einfo with Info = cut einfo.Info } - - let einfo = - if (not vref.ShouldInline && not vref.InlineIfLambda && not cenv.settings.KeepOptimizationValues) || - - // Bug 4916: do not record inline data for initialization trigger expressions - // Note: we can't eliminate these value infos at the file boundaries because that would change initialization - // order - IsCompiledAsStaticPropertyWithField g vref || - - (vref.InlineInfo = ValInline.Never) || - // MarshalByRef methods may not be inlined - (match vref.TryDeclaringEntity with - | Parent tcref -> - match g.system_MarshalByRefObject_tcref with - | None -> false - | Some mbrTyconRef -> - // Check we can deref system_MarshalByRefObject_tcref. When compiling against the Silverlight mscorlib we can't - if mbrTyconRef.TryDeref.IsSome then - // Check if this is a subtype of MarshalByRefObject - assert g.system_MarshalByRefObject_ty.IsSome - ExistsSameHeadTypeInHierarchy g cenv.amap vref.Range (generalizedTyconRef g tcref) g.system_MarshalByRefObject_ty.Value - else - false - | ParentNone -> false) || - - // These values are given a special going-over by the optimizer and - // ilxgen.fs, hence treat them as if no-inline (when preparing the inline information for - // FSharp.Core). - (let nvref = mkLocalValRef vref - g.compilingFSharpCore && - (valRefEq g nvref g.seq_vref || - valRefEq g nvref g.seq_generated_vref || - valRefEq g nvref g.seq_finally_vref || - valRefEq g nvref g.seq_using_vref || - valRefEq g nvref g.seq_append_vref || - valRefEq g nvref g.seq_empty_vref || - valRefEq g nvref g.seq_delay_vref || - valRefEq g nvref g.seq_singleton_vref || - valRefEq g nvref g.seq_map_vref || - valRefEq g nvref g.seq_collect_vref || - valRefEq g nvref g.reference_equality_inner_vref || - valRefEq g nvref g.generic_comparison_inner_vref || - valRefEq g nvref g.generic_comparison_withc_inner_vref || - valRefEq g nvref g.generic_equality_er_inner_vref || - valRefEq g nvref g.generic_equality_per_inner_vref || - valRefEq g nvref g.generic_equality_withc_inner_vref || - valRefEq g nvref g.generic_hash_inner_vref)) - then {einfo with Info=UnknownValue} - else einfo - if vref.ShouldInline && IsPartialExprVal einfo.Info then - errorR(InternalError("the inline value '"+vref.LogicalName+"' was not inferred to have a known value", vref.Range)) - - let env = BindInternalLocalVal cenv vref (mkValInfo einfo vref) env + | RecdValue(tcref, a) -> RecdValue(tcref, Array.map cut a) + | UnionCaseValue(a, b) -> UnionCaseValue(a, Array.map cut b) + | UnknownValue + | ConstValue _ + | ConstExprValue _ -> ivalue + | SizeValue(_, a) -> MakeSizedValueInfo(cut a) + + let einfo = + if vref.ShouldInline || vref.InlineIfLambda then + einfo + else + { einfo with Info = cut einfo.Info } + + let einfo = + if + (not vref.ShouldInline + && not vref.InlineIfLambda + && not cenv.settings.KeepOptimizationValues) + || + + // Bug 4916: do not record inline data for initialization trigger expressions + // Note: we can't eliminate these value infos at the file boundaries because that would change initialization + // order + IsCompiledAsStaticPropertyWithField g vref + || + + (vref.InlineInfo = ValInline.Never) + || + // MarshalByRef methods may not be inlined + (match vref.TryDeclaringEntity with + | Parent tcref -> + match g.system_MarshalByRefObject_tcref with + | None -> false + | Some mbrTyconRef -> + // Check we can deref system_MarshalByRefObject_tcref. When compiling against the Silverlight mscorlib we can't + if mbrTyconRef.TryDeref.IsSome then + // Check if this is a subtype of MarshalByRefObject + assert g.system_MarshalByRefObject_ty.IsSome + + ExistsSameHeadTypeInHierarchy + g + cenv.amap + vref.Range + (generalizedTyconRef g tcref) + g.system_MarshalByRefObject_ty.Value + else + false + | ParentNone -> false) + || + + // These values are given a special going-over by the optimizer and + // ilxgen.fs, hence treat them as if no-inline (when preparing the inline information for + // FSharp.Core). + (let nvref = mkLocalValRef vref + + g.compilingFSharpCore + && (valRefEq g nvref g.seq_vref + || valRefEq g nvref g.seq_generated_vref + || valRefEq g nvref g.seq_finally_vref + || valRefEq g nvref g.seq_using_vref + || valRefEq g nvref g.seq_append_vref + || valRefEq g nvref g.seq_empty_vref + || valRefEq g nvref g.seq_delay_vref + || valRefEq g nvref g.seq_singleton_vref + || valRefEq g nvref g.seq_map_vref + || valRefEq g nvref g.seq_collect_vref + || valRefEq g nvref g.reference_equality_inner_vref + || valRefEq g nvref g.generic_comparison_inner_vref + || valRefEq g nvref g.generic_comparison_withc_inner_vref + || valRefEq g nvref g.generic_equality_er_inner_vref + || valRefEq g nvref g.generic_equality_per_inner_vref + || valRefEq g nvref g.generic_equality_withc_inner_vref + || valRefEq g nvref g.generic_hash_inner_vref)) + then + { einfo with Info = UnknownValue } + else + einfo + + if vref.ShouldInline && IsPartialExprVal einfo.Info then + errorR ( + InternalError( + "the inline value '" + + vref.LogicalName + + "' was not inferred to have a known value", + vref.Range + ) + ) + + let env = BindInternalLocalVal cenv vref (mkValInfo einfo vref) env (TBind(vref, exprOptimized, spBind), einfo), env - with RecoverableException exn -> - errorRecovery exn vref.Range - raise (ReportedError (Some exn)) - + with RecoverableException exn -> + errorRecovery exn vref.Range + raise (ReportedError(Some exn)) + and OptimizeBindings cenv isRec env xs = List.mapFold (OptimizeBinding cenv isRec) env xs - -and OptimizeModuleExprWithSig cenv env mty def = - let g = cenv.g - // Optimize the module implementation - let (def, info), (_env, bindInfosColl) = OptimizeModuleContents cenv (env, []) def - let bindInfosColl = List.concat bindInfosColl - - // Compute the elements truly hidden by the module signature. - // The hidden set here must contain NOT MORE THAN the set of values made inaccessible by - // the application of the signature. If it contains extra elements we'll accidentally eliminate - // bindings. - - let _renaming, hidden as rpi = ComputeRemappingFromImplementationToSignature g def mty - - let def = - if not cenv.settings.LocalOptimizationsEnabled then def else - - let fvs = freeInModuleOrNamespace (CollectLocalsWithStackGuard()) def - let dead = - bindInfosColl |> List.filter (fun (bind, binfo) -> + +and OptimizeModuleExprWithSig cenv env mty def = + let g = cenv.g + // Optimize the module implementation + let (def, info), (_env, bindInfosColl) = OptimizeModuleContents cenv (env, []) def + let bindInfosColl = List.concat bindInfosColl + + // Compute the elements truly hidden by the module signature. + // The hidden set here must contain NOT MORE THAN the set of values made inaccessible by + // the application of the signature. If it contains extra elements we'll accidentally eliminate + // bindings. + + let _renaming, hidden as rpi = + ComputeRemappingFromImplementationToSignature g def mty + + let def = + if not cenv.settings.LocalOptimizationsEnabled then + def + else + + let fvs = freeInModuleOrNamespace (CollectLocalsWithStackGuard()) def + + let dead = + bindInfosColl + |> List.filter (fun (bind, binfo) -> // Check the expression has no side effect, e.g. is a lambda expression (a function definition) - not (ValueIsUsedOrHasEffect cenv (fun () -> fvs.FreeLocals) (bind, binfo)) && + not (ValueIsUsedOrHasEffect cenv (fun () -> fvs.FreeLocals) (bind, binfo)) + && // Check the thing is hidden by the signature (if any) - hidden.HiddenVals.Contains bind.Var && + hidden.HiddenVals.Contains bind.Var + && // Check the thing is not compiled as a static field or property, since reflected definitions and other reflective stuff might need it not (IsCompiledAsStaticProperty g bind.Var)) - let deadSet = Zset.addList (dead |> List.map (fun (bind, _) -> bind.Var)) (Zset.empty valOrder) + let deadSet = + Zset.addList (dead |> List.map (fun (bind, _) -> bind.Var)) (Zset.empty valOrder) // Eliminate dead private bindings from a module type by mutation. Note that the optimizer doesn't - // actually copy the entire term - it copies the expression portions of the term and leaves the - // value_spec and entity_specs in place. However this means that the value_specs and entity specs - // need to be updated when a change is made that affects them, e.g. when a binding is eliminated. + // actually copy the entire term - it copies the expression portions of the term and leaves the + // value_spec and entity_specs in place. However this means that the value_specs and entity specs + // need to be updated when a change is made that affects them, e.g. when a binding is eliminated. // We'd have to do similar tricks if the type of variable is changed (as happens in TLR, which also // uses mutation), or if we eliminated a type constructor. // // It may be wise to move to a non-mutating implementation at some point here. Copying expressions is // probably more costly than copying specs anyway. - let rec elimModTy (mtyp: ModuleOrNamespaceType) = - let mty = - ModuleOrNamespaceType(kind=mtyp.ModuleOrNamespaceKind, - vals= (mtyp.AllValsAndMembers |> QueueList.filter (Zset.memberOf deadSet >> not)), - entities= mtyp.AllEntities) + let rec elimModTy (mtyp: ModuleOrNamespaceType) = + let mty = + ModuleOrNamespaceType( + kind = mtyp.ModuleOrNamespaceKind, + vals = (mtyp.AllValsAndMembers |> QueueList.filter (Zset.memberOf deadSet >> not)), + entities = mtyp.AllEntities + ) + mtyp.ModuleAndNamespaceDefinitions |> List.iter elimModSpec mty - and elimModSpec (mspec: ModuleOrNamespace) = - let mtyp = elimModTy mspec.ModuleOrNamespaceType + and elimModSpec (mspec: ModuleOrNamespace) = + let mtyp = elimModTy mspec.ModuleOrNamespaceType mspec.entity_modul_type <- MaybeLazy.Strict mtyp - let rec elimModuleDefn x = - match x with - | TMDefRec(isRec, opens, tycons, mbinds, m) -> + let rec elimModuleDefn x = + match x with + | TMDefRec(isRec, opens, tycons, mbinds, m) -> let mbinds = mbinds |> List.choose elimModuleBinding TMDefRec(isRec, opens, tycons, mbinds, m) - | TMDefLet(bind, m) -> - if Zset.contains bind.Var deadSet then TMDefRec(false, [], [], [], m) else x + | TMDefLet(bind, m) -> + if Zset.contains bind.Var deadSet then + TMDefRec(false, [], [], [], m) + else + x | TMDefOpens _ -> x | TMDefDo _ -> x - | TMDefs defs -> TMDefs(List.map elimModuleDefn defs) + | TMDefs defs -> TMDefs(List.map elimModuleDefn defs) - and elimModuleBinding modBind = - match modBind with - | ModuleOrNamespaceBinding.Binding bind -> - if bind.Var |> Zset.memberOf deadSet then None - else Some modBind + and elimModuleBinding modBind = + match modBind with + | ModuleOrNamespaceBinding.Binding bind -> + if bind.Var |> Zset.memberOf deadSet then + None + else + Some modBind | ModuleOrNamespaceBinding.Module(mspec, d) -> // Clean up the ModuleOrNamespaceType by mutation elimModSpec mspec - Some (ModuleOrNamespaceBinding.Module(mspec, elimModuleDefn d)) - - elimModuleDefn def + Some(ModuleOrNamespaceBinding.Module(mspec, elimModuleDefn d)) - let info = AbstractAndRemapModulInfo g rpi info + elimModuleDefn def - def, info + let info = AbstractAndRemapModulInfo g rpi info -and mkValBind (bind: Binding) info = - (mkLocalValRef bind.Var, info) + def, info + +and mkValBind (bind: Binding) info = (mkLocalValRef bind.Var, info) + +and OptimizeModuleContents cenv (env, bindInfosColl) input = + match input with + | TMDefRec(isRec, opens, tycons, mbinds, m) -> + let env = + if isRec then + BindInternalValsToUnknown cenv (allValsOfModDef input) env + else + env + + let mbindInfos, (env, bindInfosColl) = + OptimizeModuleBindings cenv (env, bindInfosColl) mbinds -and OptimizeModuleContents cenv (env, bindInfosColl) input = - match input with - | TMDefRec(isRec, opens, tycons, mbinds, m) -> - let env = if isRec then BindInternalValsToUnknown cenv (allValsOfModDef input) env else env - let mbindInfos, (env, bindInfosColl) = OptimizeModuleBindings cenv (env, bindInfosColl) mbinds let mbinds, minfos = List.unzip mbindInfos - let binds = minfos |> List.choose (function Choice1Of2 (x, _) -> Some x | _ -> None) - let binfos = minfos |> List.choose (function Choice1Of2 (_, x) -> Some x | _ -> None) - let minfos = minfos |> List.choose (function Choice2Of2 x -> Some x | _ -> None) - - (TMDefRec(isRec, opens, tycons, mbinds, m), - notlazy { ValInfos = ValInfos(List.map2 (fun bind binfo -> mkValBind bind (mkValInfo binfo bind.Var)) binds binfos) - ModuleOrNamespaceInfos = NameMap.ofList minfos}), + + let binds = + minfos + |> List.choose (function + | Choice1Of2(x, _) -> Some x + | _ -> None) + + let binfos = + minfos + |> List.choose (function + | Choice1Of2(_, x) -> Some x + | _ -> None) + + let minfos = + minfos + |> List.choose (function + | Choice2Of2 x -> Some x + | _ -> None) + + (TMDefRec(isRec, opens, tycons, mbinds, m), + notlazy + { + ValInfos = ValInfos(List.map2 (fun bind binfo -> mkValBind bind (mkValInfo binfo bind.Var)) binds binfos) + ModuleOrNamespaceInfos = NameMap.ofList minfos + }), (env, bindInfosColl) - | TMDefOpens _openDecls -> - (input, EmptyModuleInfo), (env, bindInfosColl) + | TMDefOpens _openDecls -> (input, EmptyModuleInfo), (env, bindInfosColl) | TMDefLet(bind, m) -> let bindR, binfo as bindInfo, env = OptimizeBinding cenv false env bind - (TMDefLet(bindR, m), - notlazy { ValInfos=ValInfos [mkValBind bind (mkValInfo binfo bind.Var)] - ModuleOrNamespaceInfos = NameMap.empty }), - (env, ([bindInfo] :: bindInfosColl)) + + (TMDefLet(bindR, m), + notlazy + { + ValInfos = ValInfos [ mkValBind bind (mkValInfo binfo bind.Var) ] + ModuleOrNamespaceInfos = NameMap.empty + }), + (env, ([ bindInfo ] :: bindInfosColl)) | TMDefDo(e, m) -> let eR, _einfo = OptimizeExpr cenv env e - (TMDefDo(eR, m), EmptyModuleInfo), - (env, bindInfosColl) + (TMDefDo(eR, m), EmptyModuleInfo), (env, bindInfosColl) + + | TMDefs defs -> + let (defs, info), (env, bindInfosColl) = + OptimizeModuleDefs cenv (env, bindInfosColl) defs - | TMDefs defs -> - let (defs, info), (env, bindInfosColl) = OptimizeModuleDefs cenv (env, bindInfosColl) defs (TMDefs defs, info), (env, bindInfosColl) and OptimizeModuleBindings cenv (env, bindInfosColl) xs = List.mapFold (OptimizeModuleBinding cenv) (env, bindInfosColl) xs -and OptimizeModuleBinding cenv (env, bindInfosColl) x = +and OptimizeModuleBinding cenv (env, bindInfosColl) x = match x with - | ModuleOrNamespaceBinding.Binding bind -> + | ModuleOrNamespaceBinding.Binding bind -> let bindR, binfo as bindInfo, env = OptimizeBinding cenv true env bind - (ModuleOrNamespaceBinding.Binding bindR, Choice1Of2 (bindR, binfo)), (env, [ bindInfo ] :: bindInfosColl) + (ModuleOrNamespaceBinding.Binding bindR, Choice1Of2(bindR, binfo)), (env, [ bindInfo ] :: bindInfosColl) | ModuleOrNamespaceBinding.Module(mspec, def) -> let id = mspec.Id - let (def, info), (_, bindInfosColl) = OptimizeModuleContents cenv (env, bindInfosColl) def + + let (def, info), (_, bindInfosColl) = + OptimizeModuleContents cenv (env, bindInfosColl) def + let env = BindValsInModuleOrNamespace cenv info env - (ModuleOrNamespaceBinding.Module(mspec, def), Choice2Of2 (id.idText, info)), - (env, bindInfosColl) + (ModuleOrNamespaceBinding.Module(mspec, def), Choice2Of2(id.idText, info)), (env, bindInfosColl) + +and OptimizeModuleDefs cenv (env, bindInfosColl) defs = + let defs, (env, bindInfosColl) = + List.mapFold (OptimizeModuleContents cenv) (env, bindInfosColl) defs -and OptimizeModuleDefs cenv (env, bindInfosColl) defs = - let defs, (env, bindInfosColl) = List.mapFold (OptimizeModuleContents cenv) (env, bindInfosColl) defs let defs, minfos = List.unzip defs (defs, UnionOptimizationInfos minfos), (env, bindInfosColl) - + and OptimizeImplFileInternal cenv env isIncrementalFragment hidden implFile = - let (CheckedImplFile (qname, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = implFile - let env, contentsR, minfo, hidden = + let (CheckedImplFile(qname, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = + implFile + + let env, contentsR, minfo, hidden = // FSI compiles interactive fragments as if you're typing incrementally into one module. // - // This means the fragment is not constrained by its signature and later fragments will be typechecked + // This means the fragment is not constrained by its signature and later fragments will be typechecked // against the implementation of the module rather than the externals. // if isIncrementalFragment then // This optimizes and builds minfo ignoring the signature - let (defR, minfo), (_env, _bindInfosColl) = OptimizeModuleContents cenv (env, []) contents + let (defR, minfo), (_env, _bindInfosColl) = + OptimizeModuleContents cenv (env, []) contents + let hidden = ComputeImplementationHidingInfoAtAssemblyBoundary defR hidden let minfo = AbstractLazyModulInfoByHiding false hidden minfo let env = BindValsInModuleOrNamespace cenv minfo env @@ -4389,101 +5331,116 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment hidden implFile = let env = BindValsInModuleOrNamespace cenv minfo env env, mexprR, minfoExternal, hidden - let implFileR = CheckedImplFile (qname, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + let implFileR = + CheckedImplFile(qname, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) env, implFileR, minfo, hidden /// Entry point -let OptimizeImplFile (settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncrementalFragment, emitTailcalls, hidden, mimpls) = - let cenv = - { settings=settings - scope=ccu - TcVal = tcVal - g=tcGlobals - amap=importMap - optimizing=true - localInternalVals=Dictionary(10000) - emitTailcalls=emitTailcalls - casApplied=Dictionary() - stackGuard = StackGuard(OptimizerStackGuardDepth, "OptimizerStackGuardDepth") - realsig = tcGlobals.realsig +let OptimizeImplFile (settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncrementalFragment, emitTailcalls, hidden, mimpls) = + let cenv = + { + settings = settings + scope = ccu + TcVal = tcVal + g = tcGlobals + amap = importMap + optimizing = true + localInternalVals = Dictionary(10000) + emitTailcalls = emitTailcalls + casApplied = Dictionary() + stackGuard = StackGuard(OptimizerStackGuardDepth, "OptimizerStackGuardDepth") + realsig = tcGlobals.realsig } - let env, _, _, _ as results = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls + let env, _, _, _ as results = + OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls let optimizeDuringCodeGen disableMethodSplitting expr = - let env = { env with disableMethodSplitting = env.disableMethodSplitting || disableMethodSplitting } + let env = + { env with + disableMethodSplitting = env.disableMethodSplitting || disableMethodSplitting + } + OptimizeExpr cenv env expr |> fst results, optimizeDuringCodeGen - /// Pickle to stable format for cross-module optimization data let rec p_ExprValueInfo x st = - match x with - | ConstValue (c, ty) -> + match x with + | ConstValue(c, ty) -> p_byte 0 st - p_tup2 p_const p_ty (c, ty) st - | UnknownValue -> - p_byte 1 st - | ValValue (a, b) -> + p_tup2 p_const p_ty (c, ty) st + | UnknownValue -> p_byte 1 st + | ValValue(a, b) -> p_byte 2 st p_tup2 (p_vref "optval") p_ExprValueInfo (a, b) st | TupleValue a -> p_byte 3 st p_array p_ExprValueInfo a st - | UnionCaseValue (a, b) -> + | UnionCaseValue(a, b) -> p_byte 4 st p_tup2 p_ucref (p_array p_ExprValueInfo) (a, b) st - | CurriedLambdaValue (_, b, c, d, e) -> + | CurriedLambdaValue(_, b, c, d, e) -> p_byte 5 st p_tup4 p_int p_int p_expr p_ty (b, c, d, e) st - | ConstExprValue (a, b) -> + | ConstExprValue(a, b) -> p_byte 6 st p_tup2 p_int p_expr (a, b) st - | RecdValue (tcref, a) -> + | RecdValue(tcref, a) -> p_byte 7 st p_tcref "opt data" tcref st p_array p_ExprValueInfo a st - | SizeValue (_adepth, a) -> - p_ExprValueInfo a st + | SizeValue(_adepth, a) -> p_ExprValueInfo a st -and p_ValInfo (v: ValInfo) st = +and p_ValInfo (v: ValInfo) st = p_ExprValueInfo v.ValExprInfo st p_bool v.ValMakesNoCriticalTailcalls st -and p_ModuleInfo x st = +and p_ModuleInfo x st = p_array (p_tup2 (p_vref "opttab") p_ValInfo) (x.ValInfos.Entries |> Seq.toArray) st p_namemap p_LazyModuleInfo x.ModuleOrNamespaceInfos st -and p_LazyModuleInfo x st = - p_lazy p_ModuleInfo x st +and p_LazyModuleInfo x st = p_lazy p_ModuleInfo x st let p_CcuOptimizationInfo x st = p_LazyModuleInfo x st let rec u_ExprInfo st = let rec loop st = let tag = u_byte st + match tag with | 0 -> u_tup2 u_const u_ty st |> ConstValue | 1 -> UnknownValue | 2 -> u_tup2 u_vref loop st |> ValValue | 3 -> u_array loop st |> TupleValue | 4 -> u_tup2 u_ucref (u_array loop) st |> UnionCaseValue - | 5 -> u_tup4 u_int u_int u_expr u_ty st |> (fun (b, c, d, e) -> CurriedLambdaValue (newUnique(), b, c, d, e)) + | 5 -> + u_tup4 u_int u_int u_expr u_ty st + |> (fun (b, c, d, e) -> CurriedLambdaValue(newUnique (), b, c, d, e)) | 6 -> u_tup2 u_int u_expr st |> ConstExprValue | 7 -> u_tup2 u_tcref (u_array loop) st |> RecdValue | _ -> failwith "loop" // calc size of unpicked ExprValueInfo - MakeSizedValueInfo (loop st) + MakeSizedValueInfo(loop st) -and u_ValInfo st = +and u_ValInfo st = let a, b = u_tup2 u_ExprInfo u_bool st - { ValExprInfo=a; ValMakesNoCriticalTailcalls = b } -and u_ModuleInfo st = - let a, b = u_tup2 (u_array (u_tup2 u_vref u_ValInfo)) (u_namemap u_LazyModuleInfo) st - { ValInfos= ValInfos a; ModuleOrNamespaceInfos=b} + { + ValExprInfo = a + ValMakesNoCriticalTailcalls = b + } + +and u_ModuleInfo st = + let a, b = + u_tup2 (u_array (u_tup2 u_vref u_ValInfo)) (u_namemap u_LazyModuleInfo) st + + { + ValInfos = ValInfos a + ModuleOrNamespaceInfos = b + } and u_LazyModuleInfo st = u_lazy u_ModuleInfo st diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 33c87edb597..b96edcf6e41 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -19,260 +19,314 @@ open FSharp.Compiler.TypeHierarchy open FSharp.Compiler.TypeRelations [] -module ExprTranslationImpl = +module ExprTranslationImpl = let nonNil x = not (List.isEmpty x) - type ExprTranslationEnv = - { - /// Map from Val to binding index - vs: ValMap + type ExprTranslationEnv = + { + /// Map from Val to binding index + vs: ValMap - /// Map from typar stamps to binding index - tyvs: StampMap + /// Map from typar stamps to binding index + tyvs: StampMap - // Map for values bound by the - // 'let v = isinst e in .... if nonnull v then ...v .... ' - // construct arising out the compilation of pattern matching. We decode these back to the form - // 'if istype v then ...unbox v .... ' - isinstVals: ValMap + // Map for values bound by the + // 'let v = isinst e in .... if nonnull v then ...v .... ' + // construct arising out the compilation of pattern matching. We decode these back to the form + // 'if istype v then ...unbox v .... ' + isinstVals: ValMap - substVals: ValMap + substVals: ValMap - /// Indicates that we disable generation of witnesses - suppressWitnesses: bool + /// Indicates that we disable generation of witnesses + suppressWitnesses: bool - /// All witnesses in scope and their mapping to lambda variables. - // - // Note: this uses an immutable HashMap/Dictionary with an IEqualityComparer that captures TcGlobals, see - // the point where the empty initial object is created. - witnessesInScope: TraitWitnessInfoHashMap + /// All witnesses in scope and their mapping to lambda variables. + // + // Note: this uses an immutable HashMap/Dictionary with an IEqualityComparer that captures TcGlobals, see + // the point where the empty initial object is created. + witnessesInScope: TraitWitnessInfoHashMap } - static member Empty g = - { vs=ValMap<_>.Empty - tyvs = Map.empty - isinstVals = ValMap<_>.Empty - substVals = ValMap<_>.Empty - suppressWitnesses = false - witnessesInScope = EmptyTraitWitnessInfoHashMap g + static member Empty g = + { + vs = ValMap<_>.Empty + tyvs = Map.empty + isinstVals = ValMap<_>.Empty + substVals = ValMap<_>.Empty + suppressWitnesses = false + witnessesInScope = EmptyTraitWitnessInfoHashMap g } - member env.BindTypar (v: Typar, gp) = - { env with tyvs = env.tyvs.Add(v.Stamp, gp ) } + member env.BindTypar(v: Typar, gp) = + { env with + tyvs = env.tyvs.Add(v.Stamp, gp) + } - member env.BindTypars vs = - (env, vs) ||> List.fold (fun env v -> env.BindTypar v) // fold left-to-right because indexes are left-to-right + member env.BindTypars vs = + (env, vs) ||> List.fold (fun env v -> env.BindTypar v) // fold left-to-right because indexes are left-to-right - member env.BindVal v = - { env with vs = env.vs.Add v () } + member env.BindVal v = { env with vs = env.vs.Add v () } - member env.BindIsInstVal v (ty, e) = - { env with isinstVals = env.isinstVals.Add v (ty, e) } + member env.BindIsInstVal v (ty, e) = + { env with + isinstVals = env.isinstVals.Add v (ty, e) + } - member env.BindSubstVal v e = - { env with substVals = env.substVals.Add v e } + member env.BindSubstVal v e = + { env with + substVals = env.substVals.Add v e + } - member env.BindVals vs = - (env, vs) ||> List.fold (fun env v -> env.BindVal v) + member env.BindVals vs = + (env, vs) ||> List.fold (fun env v -> env.BindVal v) - member env.BindCurriedVals vsl = - (env, vsl) ||> List.fold (fun env vs -> env.BindVals vs) + member env.BindCurriedVals vsl = + (env, vsl) ||> List.fold (fun env vs -> env.BindVals vs) exception IgnoringPartOfQuotedTermWarning of string * range - let wfail (msg, m: range) = failwith (msg + sprintf " at %s" (m.ToString())) + let wfail (msg, m: range) = + failwith (msg + sprintf " at %s" (m.ToString())) /// The core tree of data produced by converting F# compiler TAST expressions into the form which we make available through the compiler API /// through active patterns. type E = - | Value of FSharpMemberOrFunctionOrValue - | ThisValue of FSharpType - | BaseValue of FSharpType - | Application of FSharpExpr * FSharpType list * FSharpExpr list - | Lambda of FSharpMemberOrFunctionOrValue * FSharpExpr - | TypeLambda of FSharpGenericParameter list * FSharpExpr - | Quote of FSharpExpr - | IfThenElse of FSharpExpr * FSharpExpr * FSharpExpr - | DecisionTree of FSharpExpr * (FSharpMemberOrFunctionOrValue list * FSharpExpr) list + | Value of FSharpMemberOrFunctionOrValue + | ThisValue of FSharpType + | BaseValue of FSharpType + | Application of FSharpExpr * FSharpType list * FSharpExpr list + | Lambda of FSharpMemberOrFunctionOrValue * FSharpExpr + | TypeLambda of FSharpGenericParameter list * FSharpExpr + | Quote of FSharpExpr + | IfThenElse of FSharpExpr * FSharpExpr * FSharpExpr + | DecisionTree of FSharpExpr * (FSharpMemberOrFunctionOrValue list * FSharpExpr) list | DecisionTreeSuccess of int * FSharpExpr list - | Call of FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list * FSharpExpr list - | NewObject of FSharpMemberOrFunctionOrValue * FSharpType list * FSharpExpr list - | LetRec of (FSharpMemberOrFunctionOrValue * FSharpExpr * DebugPointAtBinding) list * FSharpExpr - | Let of (FSharpMemberOrFunctionOrValue * FSharpExpr * DebugPointAtBinding) * FSharpExpr - | NewRecord of FSharpType * FSharpExpr list + | Call of FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list * FSharpExpr list + | NewObject of FSharpMemberOrFunctionOrValue * FSharpType list * FSharpExpr list + | LetRec of (FSharpMemberOrFunctionOrValue * FSharpExpr * DebugPointAtBinding) list * FSharpExpr + | Let of (FSharpMemberOrFunctionOrValue * FSharpExpr * DebugPointAtBinding) * FSharpExpr + | NewRecord of FSharpType * FSharpExpr list | ObjectExpr of FSharpType * FSharpExpr * FSharpObjectExprOverride list * (FSharpType * FSharpObjectExprOverride list) list - | FSharpFieldGet of FSharpExpr option * FSharpType * FSharpField - | FSharpFieldSet of FSharpExpr option * FSharpType * FSharpField * FSharpExpr - | NewUnionCase of FSharpType * FSharpUnionCase * FSharpExpr list + | FSharpFieldGet of FSharpExpr option * FSharpType * FSharpField + | FSharpFieldSet of FSharpExpr option * FSharpType * FSharpField * FSharpExpr + | NewUnionCase of FSharpType * FSharpUnionCase * FSharpExpr list | NewAnonRecord of FSharpType * FSharpExpr list - | AnonRecordGet of FSharpExpr * FSharpType * int - | UnionCaseGet of FSharpExpr * FSharpType * FSharpUnionCase * FSharpField - | UnionCaseSet of FSharpExpr * FSharpType * FSharpUnionCase * FSharpField * FSharpExpr - | UnionCaseTag of FSharpExpr * FSharpType - | UnionCaseTest of FSharpExpr * FSharpType * FSharpUnionCase + | AnonRecordGet of FSharpExpr * FSharpType * int + | UnionCaseGet of FSharpExpr * FSharpType * FSharpUnionCase * FSharpField + | UnionCaseSet of FSharpExpr * FSharpType * FSharpUnionCase * FSharpField * FSharpExpr + | UnionCaseTag of FSharpExpr * FSharpType + | UnionCaseTest of FSharpExpr * FSharpType * FSharpUnionCase | TraitCall of FSharpType list * string * SynMemberFlags * FSharpType list * FSharpType list * FSharpExpr list - | NewTuple of FSharpType * FSharpExpr list - | TupleGet of FSharpType * int * FSharpExpr - | Coerce of FSharpType * FSharpExpr - | NewArray of FSharpType * FSharpExpr list - | TypeTest of FSharpType * FSharpExpr - | AddressSet of FSharpExpr * FSharpExpr - | ValueSet of FSharpMemberOrFunctionOrValue * FSharpExpr + | NewTuple of FSharpType * FSharpExpr list + | TupleGet of FSharpType * int * FSharpExpr + | Coerce of FSharpType * FSharpExpr + | NewArray of FSharpType * FSharpExpr list + | TypeTest of FSharpType * FSharpExpr + | AddressSet of FSharpExpr * FSharpExpr + | ValueSet of FSharpMemberOrFunctionOrValue * FSharpExpr | Unused - | DefaultValue of FSharpType + | DefaultValue of FSharpType | Const of objnull * FSharpType - | AddressOf of FSharpExpr + | AddressOf of FSharpExpr | Sequential of FSharpExpr * FSharpExpr | IntegerForLoop of FSharpExpr * FSharpExpr * FSharpExpr * bool * DebugPointAtFor * DebugPointAtInOrTo - | WhileLoop of FSharpExpr * FSharpExpr * DebugPointAtWhile + | WhileLoop of FSharpExpr * FSharpExpr * DebugPointAtWhile | TryFinally of FSharpExpr * FSharpExpr * DebugPointAtTry * DebugPointAtFinally - | TryWith of FSharpExpr * FSharpMemberOrFunctionOrValue * FSharpExpr * FSharpMemberOrFunctionOrValue * FSharpExpr * DebugPointAtTry * DebugPointAtWith - | NewDelegate of FSharpType * FSharpExpr - | ILFieldGet of FSharpExpr option * FSharpType * string - | ILFieldSet of FSharpExpr option * FSharpType * string * FSharpExpr + | TryWith of + FSharpExpr * + FSharpMemberOrFunctionOrValue * + FSharpExpr * + FSharpMemberOrFunctionOrValue * + FSharpExpr * + DebugPointAtTry * + DebugPointAtWith + | NewDelegate of FSharpType * FSharpExpr + | ILFieldGet of FSharpExpr option * FSharpType * string + | ILFieldSet of FSharpExpr option * FSharpType * string * FSharpExpr | ILAsm of string * FSharpType list * FSharpExpr list | WitnessArg of int | DebugPoint of DebugPointAtLeafExpr * FSharpExpr -/// Used to represent the information at an object expression member -and [] FSharpObjectExprOverride(sgn: FSharpAbstractSignature, gps: FSharpGenericParameter list, args: FSharpMemberOrFunctionOrValue list list, body: FSharpExpr) = +/// Used to represent the information at an object expression member +and [] FSharpObjectExprOverride + (sgn: FSharpAbstractSignature, gps: FSharpGenericParameter list, args: FSharpMemberOrFunctionOrValue list list, body: FSharpExpr) = member _.Signature = sgn member _.GenericParameters = gps member _.CurriedParameterGroups = args member _.Body = body /// The type of expressions provided through the compiler API. -and [] FSharpExpr (cenv, f: (unit -> FSharpExpr) option, e: E, m: range, ty) = +and [] FSharpExpr(cenv, f: (unit -> FSharpExpr) option, e: E, m: range, ty) = + + let mutable e = + match f with + | None -> e + | Some _ -> Unchecked.defaultof - let mutable e = match f with None -> e | Some _ -> Unchecked.defaultof member x.Range = m member x.Type = FSharpType(cenv, ty) member x.cenv = cenv - member x.E = match box e with null -> e <- f.Value().E; e | _ -> e + + member x.E = + match box e with + | null -> + e <- f.Value().E + e + | _ -> e + override x.ToString() = sprintf "%+A" x.E - member x.ImmediateSubExpressions = - match x.E with + member x.ImmediateSubExpressions = + match x.E with | E.Value _v -> [] - | E.Const (_constValue, _ty) -> [] - | E.TypeLambda (_v, body) -> [body] - | E.Lambda (_v, body) -> [body] - | E.Application (f, _tyargs, arg) -> f :: arg - | E.IfThenElse (e1, e2, e3) -> [e1;e2;e3] - | E.Let ((_bindingVar, bindingExpr, _dp), b) -> [bindingExpr;b] - | E.LetRec (ves, b) -> (List.map p23 ves) @ [b] - | E.NewRecord (_recordType, es) -> es - | E.NewAnonRecord (_recordType, es) -> es - | E.AnonRecordGet (e, _recordType, _n) -> [e] - | E.NewUnionCase (_unionType, _unionCase, es) -> es - | E.NewTuple (_tupleType, es) -> es - | E.TupleGet (_tupleType, _itemIndex, tupleExpr) -> [tupleExpr] - | E.Call (objOpt, _b, _c, _d, ws, es) -> (match objOpt with None -> ws @ es | Some x -> x :: ws @ es) - | E.NewObject (_a, _b, c) -> c - | E.FSharpFieldGet (objOpt, _b, _c) -> (match objOpt with None -> [] | Some x -> [x]) - | E.FSharpFieldSet (objOpt, _b, _c, d) -> (match objOpt with None -> [d] | Some x -> [x;d]) - | E.UnionCaseGet (obj, _b, _c, _d) -> [obj] - | E.UnionCaseTag (obj, _b) -> [obj] - | E.UnionCaseTest (obj, _b, _c) -> [obj] - | E.NewArray (_ty, elems) -> elems - | E.Coerce (_ty, b) -> [b] - | E.Quote a -> [a] - | E.TypeTest (_ty, b) -> [b] - | E.Sequential (a, b) -> [a;b] - | E.IntegerForLoop (a, b, c, _dir, _dp, _dp2) -> [a;b;c] - | E.WhileLoop (guard, body, _dp) -> [guard; body] - | E.TryFinally (body, b, _dp, _dp2) -> [body; b] - | E.TryWith (body, _b, _c, _d, handler, _dp, _dp2) -> [body; handler] - | E.NewDelegate (_ty, body) -> [body] + | E.Const(_constValue, _ty) -> [] + | E.TypeLambda(_v, body) -> [ body ] + | E.Lambda(_v, body) -> [ body ] + | E.Application(f, _tyargs, arg) -> f :: arg + | E.IfThenElse(e1, e2, e3) -> [ e1; e2; e3 ] + | E.Let((_bindingVar, bindingExpr, _dp), b) -> [ bindingExpr; b ] + | E.LetRec(ves, b) -> (List.map p23 ves) @ [ b ] + | E.NewRecord(_recordType, es) -> es + | E.NewAnonRecord(_recordType, es) -> es + | E.AnonRecordGet(e, _recordType, _n) -> [ e ] + | E.NewUnionCase(_unionType, _unionCase, es) -> es + | E.NewTuple(_tupleType, es) -> es + | E.TupleGet(_tupleType, _itemIndex, tupleExpr) -> [ tupleExpr ] + | E.Call(objOpt, _b, _c, _d, ws, es) -> + (match objOpt with + | None -> ws @ es + | Some x -> x :: ws @ es) + | E.NewObject(_a, _b, c) -> c + | E.FSharpFieldGet(objOpt, _b, _c) -> + (match objOpt with + | None -> [] + | Some x -> [ x ]) + | E.FSharpFieldSet(objOpt, _b, _c, d) -> + (match objOpt with + | None -> [ d ] + | Some x -> [ x; d ]) + | E.UnionCaseGet(obj, _b, _c, _d) -> [ obj ] + | E.UnionCaseTag(obj, _b) -> [ obj ] + | E.UnionCaseTest(obj, _b, _c) -> [ obj ] + | E.NewArray(_ty, elems) -> elems + | E.Coerce(_ty, b) -> [ b ] + | E.Quote a -> [ a ] + | E.TypeTest(_ty, b) -> [ b ] + | E.Sequential(a, b) -> [ a; b ] + | E.IntegerForLoop(a, b, c, _dir, _dp, _dp2) -> [ a; b; c ] + | E.WhileLoop(guard, body, _dp) -> [ guard; body ] + | E.TryFinally(body, b, _dp, _dp2) -> [ body; b ] + | E.TryWith(body, _b, _c, _d, handler, _dp, _dp2) -> [ body; handler ] + | E.NewDelegate(_ty, body) -> [ body ] | E.DefaultValue _ty -> [] - | E.AddressSet (lvalueExpr, rvalueExpr) -> [lvalueExpr; rvalueExpr] - | E.ValueSet (_v, rvalueExpr) -> [rvalueExpr] - | E.AddressOf lvalueExpr -> [lvalueExpr] + | E.AddressSet(lvalueExpr, rvalueExpr) -> [ lvalueExpr; rvalueExpr ] + | E.ValueSet(_v, rvalueExpr) -> [ rvalueExpr ] + | E.AddressOf lvalueExpr -> [ lvalueExpr ] | E.ThisValue _ty -> [] | E.BaseValue _ty -> [] - | E.ILAsm (_code, _tyargs, argExprs) -> argExprs - | E.ILFieldGet (objOpt, _ty, _fieldName) -> (match objOpt with None -> [] | Some x -> [x]) - | E.ILFieldSet (objOpt, _ty, _fieldName, d) -> (match objOpt with None -> [d] | Some x -> [x;d]) - | E.ObjectExpr (_ty, basecall, overrides, interfaceImpls) -> - [ yield basecall - for m in overrides do yield m.Body - for _, ms in interfaceImpls do for m in ms do yield m.Body ] - | E.DecisionTree (inputExpr, targetCases) -> - [ yield inputExpr - for _targetVars, targetExpr in targetCases do yield targetExpr ] - | E.DecisionTreeSuccess (_targetNumber, targetArgs) -> targetArgs - | E.UnionCaseSet (obj, _unionType, _unionCase, _unionField, valueExpr) -> [ yield obj; yield valueExpr ] - | E.TraitCall (_sourceTypes, _traitName, _memberFlags, _paramTypes, _retTypes, args) -> args + | E.ILAsm(_code, _tyargs, argExprs) -> argExprs + | E.ILFieldGet(objOpt, _ty, _fieldName) -> + (match objOpt with + | None -> [] + | Some x -> [ x ]) + | E.ILFieldSet(objOpt, _ty, _fieldName, d) -> + (match objOpt with + | None -> [ d ] + | Some x -> [ x; d ]) + | E.ObjectExpr(_ty, basecall, overrides, interfaceImpls) -> + [ + yield basecall + for m in overrides do + yield m.Body + for _, ms in interfaceImpls do + for m in ms do + yield m.Body + ] + | E.DecisionTree(inputExpr, targetCases) -> + [ + yield inputExpr + for _targetVars, targetExpr in targetCases do + yield targetExpr + ] + | E.DecisionTreeSuccess(_targetNumber, targetArgs) -> targetArgs + | E.UnionCaseSet(obj, _unionType, _unionCase, _unionField, valueExpr) -> [ yield obj; yield valueExpr ] + | E.TraitCall(_sourceTypes, _traitName, _memberFlags, _paramTypes, _retTypes, args) -> args | E.Unused -> [] // unexpected | E.WitnessArg _n -> [] - | E.DebugPoint (_, e) -> [e] + | E.DebugPoint(_, e) -> [ e ] /// The implementation of the conversion operation module FSharpExprConvert = - let IsStaticInitializationField (rfref: RecdFieldRef) = - rfref.RecdField.IsCompilerGenerated && - rfref.RecdField.IsStatic && - rfref.RecdField.IsMutable && - rfref.RecdField.LogicalName.StartsWithOrdinal("init") - - // Match "if [AI_clt](init@41, 6) then IntrinsicFunctions.FailStaticInit () else ()" - let (|StaticInitializationCheck|_|) e = - match e with - | Expr.Match (_, _, TDSwitch(Expr.Op (TOp.ILAsm ([ AI_clt ], _), _, [Expr.Op (TOp.ValFieldGet rfref, _, _, _) ;_], _), _, _, _), _, _, _) when IsStaticInitializationField rfref -> Some () + let IsStaticInitializationField (rfref: RecdFieldRef) = + rfref.RecdField.IsCompilerGenerated + && rfref.RecdField.IsStatic + && rfref.RecdField.IsMutable + && rfref.RecdField.LogicalName.StartsWithOrdinal("init") + + // Match "if [AI_clt](init@41, 6) then IntrinsicFunctions.FailStaticInit () else ()" + let (|StaticInitializationCheck|_|) e = + match e with + | Expr.Match(_, + _, + TDSwitch(Expr.Op(TOp.ILAsm([ AI_clt ], _), _, [ Expr.Op(TOp.ValFieldGet rfref, _, _, _); _ ], _), _, _, _), + _, + _, + _) when IsStaticInitializationField rfref -> Some() | _ -> None - // Match "init@41 <- 6" - let (|StaticInitializationCount|_|) e = - match e with - | Expr.Op (TOp.ValFieldSet rfref, _, _, _) when IsStaticInitializationField rfref -> Some () + // Match "init@41 <- 6" + let (|StaticInitializationCount|_|) e = + match e with + | Expr.Op(TOp.ValFieldSet rfref, _, _, _) when IsStaticInitializationField rfref -> Some() | _ -> None - let (|ILUnaryOp|_|) e = - match e with + let (|ILUnaryOp|_|) e = + match e with | AI_neg -> Some mkCallUnaryNegOperator | AI_not -> Some mkCallUnaryNotOperator | _ -> None - let (|ILMulDivOp|_|) e = - match e with - | AI_mul -> Some (mkCallMultiplyOperator, true) + let (|ILMulDivOp|_|) e = + match e with + | AI_mul -> Some(mkCallMultiplyOperator, true) | AI_mul_ovf - | AI_mul_ovf_un -> Some (mkCallMultiplyChecked, true) + | AI_mul_ovf_un -> Some(mkCallMultiplyChecked, true) | AI_div - | AI_div_un -> Some (mkCallDivisionOperator, false) + | AI_div_un -> Some(mkCallDivisionOperator, false) | _ -> None - let (|ILBinaryOp|_|) e = - match e with - | AI_add -> Some mkCallAdditionOperator + let (|ILBinaryOp|_|) e = + match e with + | AI_add -> Some mkCallAdditionOperator | AI_add_ovf | AI_add_ovf_un -> Some mkCallAdditionChecked - | AI_sub -> Some mkCallSubtractionOperator + | AI_sub -> Some mkCallSubtractionOperator | AI_sub_ovf | AI_sub_ovf_un -> Some mkCallSubtractionChecked | AI_rem - | AI_rem_un -> Some mkCallModulusOperator - | AI_ceq -> Some mkCallEqualsOperator + | AI_rem_un -> Some mkCallModulusOperator + | AI_ceq -> Some mkCallEqualsOperator | AI_clt - | AI_clt_un -> Some mkCallLessThanOperator + | AI_clt_un -> Some mkCallLessThanOperator | AI_cgt - | AI_cgt_un -> Some mkCallGreaterThanOperator - | AI_and -> Some mkCallBitwiseAndOperator - | AI_or -> Some mkCallBitwiseOrOperator - | AI_xor -> Some mkCallBitwiseXorOperator - | AI_shl -> Some mkCallShiftLeftOperator + | AI_cgt_un -> Some mkCallGreaterThanOperator + | AI_and -> Some mkCallBitwiseAndOperator + | AI_or -> Some mkCallBitwiseOrOperator + | AI_xor -> Some mkCallBitwiseXorOperator + | AI_shl -> Some mkCallShiftLeftOperator | AI_shr - | AI_shr_un -> Some mkCallShiftRightOperator + | AI_shr_un -> Some mkCallShiftRightOperator | _ -> None - let (|ILConvertOp|_|) e = - match e with + let (|ILConvertOp|_|) e = + match e with | AI_conv basicTy -> match basicTy with - | DT_R -> Some mkCallToDoubleOperator + | DT_R -> Some mkCallToDoubleOperator | DT_I1 -> Some mkCallToSByteOperator | DT_U1 -> Some mkCallToByteOperator | DT_I2 -> Some mkCallToInt16Operator @@ -283,13 +337,13 @@ module FSharpExprConvert = | DT_U8 -> Some mkCallToUInt64Operator | DT_R4 -> Some mkCallToSingleOperator | DT_R8 -> Some mkCallToDoubleOperator - | DT_I -> Some mkCallToIntPtrOperator - | DT_U -> Some mkCallToUIntPtrOperator + | DT_I -> Some mkCallToIntPtrOperator + | DT_U -> Some mkCallToUIntPtrOperator | DT_REF -> None | AI_conv_ovf basicTy | AI_conv_ovf_un basicTy -> match basicTy with - | DT_R -> Some mkCallToDoubleOperator + | DT_R -> Some mkCallToDoubleOperator | DT_I1 -> Some mkCallToSByteChecked | DT_U1 -> Some mkCallToByteChecked | DT_I2 -> Some mkCallToInt16Checked @@ -300,25 +354,26 @@ module FSharpExprConvert = | DT_U8 -> Some mkCallToUInt64Checked | DT_R4 -> Some mkCallToSingleOperator | DT_R8 -> Some mkCallToDoubleOperator - | DT_I -> Some mkCallToIntPtrChecked - | DT_U -> Some mkCallToUIntPtrChecked + | DT_I -> Some mkCallToIntPtrChecked + | DT_U -> Some mkCallToUIntPtrChecked | DT_REF -> None | _ -> None - let (|TTypeConvOp|_|) (cenv: SymbolEnv) ty = + let (|TTypeConvOp|_|) (cenv: SymbolEnv) ty = let g = cenv.g + match ty with - | _ when typeEquiv g ty g.sbyte_ty -> Some mkCallToSByteOperator - | _ when typeEquiv g ty g.byte_ty -> Some mkCallToByteOperator - | _ when typeEquiv g ty g.int16_ty -> Some mkCallToInt16Operator - | _ when typeEquiv g ty g.uint16_ty -> Some mkCallToUInt16Operator - | _ when typeEquiv g ty g.int32_ty -> Some mkCallToInt32Operator - | _ when typeEquiv g ty g.uint32_ty -> Some mkCallToUInt32Operator - | _ when typeEquiv g ty g.int64_ty -> Some mkCallToInt64Operator - | _ when typeEquiv g ty g.uint64_ty -> Some mkCallToUInt64Operator - | _ when typeEquiv g ty g.float32_ty -> Some mkCallToSingleOperator - | _ when typeEquiv g ty g.float_ty -> Some mkCallToDoubleOperator - | _ when typeEquiv g ty g.nativeint_ty -> Some mkCallToIntPtrOperator + | _ when typeEquiv g ty g.sbyte_ty -> Some mkCallToSByteOperator + | _ when typeEquiv g ty g.byte_ty -> Some mkCallToByteOperator + | _ when typeEquiv g ty g.int16_ty -> Some mkCallToInt16Operator + | _ when typeEquiv g ty g.uint16_ty -> Some mkCallToUInt16Operator + | _ when typeEquiv g ty g.int32_ty -> Some mkCallToInt32Operator + | _ when typeEquiv g ty g.uint32_ty -> Some mkCallToUInt32Operator + | _ when typeEquiv g ty g.int64_ty -> Some mkCallToInt64Operator + | _ when typeEquiv g ty g.uint64_ty -> Some mkCallToUInt64Operator + | _ when typeEquiv g ty g.float32_ty -> Some mkCallToSingleOperator + | _ when typeEquiv g ty g.float_ty -> Some mkCallToDoubleOperator + | _ when typeEquiv g ty g.nativeint_ty -> Some mkCallToIntPtrOperator | _ when typeEquiv g ty g.unativeint_ty -> Some mkCallToUIntPtrOperator | _ -> None @@ -326,38 +381,39 @@ module FSharpExprConvert = let ConvTypes cenv tys = List.map (ConvType cenv) tys - let ConvILTypeRefApp (cenv: SymbolEnv) m tref tyargs = + let ConvILTypeRefApp (cenv: SymbolEnv) m tref tyargs = let tcref = Import.ImportILTypeRef cenv.amap m tref ConvType cenv (mkWoNullAppTy tcref tyargs) let ConvUnionCaseRef cenv (ucref: UnionCaseRef) = FSharpUnionCase(cenv, ucref) - let ConvRecdFieldRef cenv (rfref: RecdFieldRef) = FSharpField(cenv, rfref ) + let ConvRecdFieldRef cenv (rfref: RecdFieldRef) = FSharpField(cenv, rfref) - let rec exprOfExprAddr (cenv: SymbolEnv) expr = + let rec exprOfExprAddr (cenv: SymbolEnv) expr = let g = cenv.g - match expr with - | Expr.Op (op, tyargs, args, m) -> - match op, args, tyargs with - | TOp.LValueOp (LAddrOf _, vref), _, _ -> exprForValRef m vref - | TOp.ValFieldGetAddr (rfref, _), [], _ -> mkStaticRecdFieldGet (rfref, tyargs, m) - | TOp.ValFieldGetAddr (rfref, _), [arg], _ -> mkRecdFieldGetViaExprAddr (exprOfExprAddr cenv arg, rfref, tyargs, m) - | TOp.UnionCaseFieldGetAddr (uref, n, _), [arg], _ -> mkUnionCaseFieldGetProvenViaExprAddr (exprOfExprAddr cenv arg, uref, tyargs, n, m) - | TOp.ILAsm ([ I_ldflda fspec ], retTypes), [arg], _ -> mkAsmExpr ([ mkNormalLdfld fspec ], tyargs, [exprOfExprAddr cenv arg], retTypes, m) - | TOp.ILAsm ([ I_ldsflda fspec ], retTypes), _, _ -> mkAsmExpr ([ mkNormalLdsfld fspec ], tyargs, args, retTypes, m) - | TOp.ILAsm ([ I_ldelema(_ro, _isNativePtr, shape, _tyarg) ], _), arr :: idxs, [elemTy] -> - match shape.Rank, idxs with - | 1, [idx1] -> mkCallArrayGet g m elemTy arr idx1 - | 2, [idx1; idx2] -> mkCallArray2DGet g m elemTy arr idx1 idx2 - | 3, [idx1; idx2; idx3] -> mkCallArray3DGet g m elemTy arr idx1 idx2 idx3 - | 4, [idx1; idx2; idx3; idx4] -> mkCallArray4DGet g m elemTy arr idx1 idx2 idx3 idx4 + + match expr with + | Expr.Op(op, tyargs, args, m) -> + match op, args, tyargs with + | TOp.LValueOp(LAddrOf _, vref), _, _ -> exprForValRef m vref + | TOp.ValFieldGetAddr(rfref, _), [], _ -> mkStaticRecdFieldGet (rfref, tyargs, m) + | TOp.ValFieldGetAddr(rfref, _), [ arg ], _ -> mkRecdFieldGetViaExprAddr (exprOfExprAddr cenv arg, rfref, tyargs, m) + | TOp.UnionCaseFieldGetAddr(uref, n, _), [ arg ], _ -> + mkUnionCaseFieldGetProvenViaExprAddr (exprOfExprAddr cenv arg, uref, tyargs, n, m) + | TOp.ILAsm([ I_ldflda fspec ], retTypes), [ arg ], _ -> + mkAsmExpr ([ mkNormalLdfld fspec ], tyargs, [ exprOfExprAddr cenv arg ], retTypes, m) + | TOp.ILAsm([ I_ldsflda fspec ], retTypes), _, _ -> mkAsmExpr ([ mkNormalLdsfld fspec ], tyargs, args, retTypes, m) + | TOp.ILAsm([ I_ldelema(_ro, _isNativePtr, shape, _tyarg) ], _), arr :: idxs, [ elemTy ] -> + match shape.Rank, idxs with + | 1, [ idx1 ] -> mkCallArrayGet g m elemTy arr idx1 + | 2, [ idx1; idx2 ] -> mkCallArray2DGet g m elemTy arr idx1 idx2 + | 3, [ idx1; idx2; idx3 ] -> mkCallArray3DGet g m elemTy arr idx1 idx2 idx3 + | 4, [ idx1; idx2; idx3; idx4 ] -> mkCallArray4DGet g m elemTy arr idx1 idx2 idx3 idx4 | _ -> expr | _ -> expr | _ -> expr - - let Mk cenv m ty e = - FSharpExpr(cenv, None, e, m, ty) + let Mk cenv m ty e = FSharpExpr(cenv, None, e, m, ty) let Mk2 cenv (orig: Expr) e = FSharpExpr(cenv, None, e, orig.Range, tyOfExpr cenv.g orig) @@ -365,31 +421,31 @@ module FSharpExprConvert = let rec ConvLValueExpr (cenv: SymbolEnv) env expr = ConvExpr cenv env (exprOfExprAddr cenv expr) - and ConvExpr cenv env expr = - Mk2 cenv expr (ConvExprPrim cenv env expr) + and ConvExpr cenv env expr = + Mk2 cenv expr (ConvExprPrim cenv env expr) - and ConvExprLinear cenv env expr contF = + and ConvExprLinear cenv env expr contF = ConvExprPrimLinear cenv env expr (fun exprR -> contF (Mk2 cenv expr exprR)) // Tail recursive function to process the subset of expressions considered "linear" and ConvExprPrimLinear cenv env expr contF = let g = cenv.g - match expr with - // Large lists - | Expr.Op (TOp.UnionCase ucref, tyargs, [e1;e2], _) -> - let mkR = ConvUnionCaseRef cenv ucref + match expr with + // Large lists + | Expr.Op(TOp.UnionCase ucref, tyargs, [ e1; e2 ], _) -> + let mkR = ConvUnionCaseRef cenv ucref let typR = ConvType cenv (mkWoNullAppTy ucref.TyconRef tyargs) let e1R = ConvExpr cenv env e1 - // tail recursive - ConvExprLinear cenv env e2 (contF << (fun e2R -> E.NewUnionCase(typR, mkR, [e1R; e2R]) )) + // tail recursive + ConvExprLinear cenv env e2 (contF << (fun e2R -> E.NewUnionCase(typR, mkR, [ e1R; e2R ]))) // Large sequences of let bindings - | Expr.Let (bind, body, _, _) -> - match ConvLetBind cenv env bind with + | Expr.Let(bind, body, _, _) -> + match ConvLetBind cenv env bind with | None, env -> ConvExprPrimLinear cenv env body contF - | Some bindR, env -> - // tail recursive + | Some bindR, env -> + // tail recursive ConvExprLinear cenv env body (contF << (fun bodyR -> E.Let(bindR, bodyR))) // Remove initialization checks @@ -399,107 +455,131 @@ module FSharpExprConvert = // Put in ConvExprPrimLinear because of the overlap with Expr.Sequential below // // TODO: allow clients to see static initialization checks if they want to - | Expr.Sequential (ObjectInitializationCheck g, x1, NormalSeq, _) - | Expr.Sequential (StaticInitializationCount, x1, NormalSeq, _) - | Expr.Sequential (StaticInitializationCheck, x1, NormalSeq, _) -> - ConvExprPrim cenv env x1 |> contF + | Expr.Sequential(ObjectInitializationCheck g, x1, NormalSeq, _) + | Expr.Sequential(StaticInitializationCount, x1, NormalSeq, _) + | Expr.Sequential(StaticInitializationCheck, x1, NormalSeq, _) -> ConvExprPrim cenv env x1 |> contF // Large sequences of sequential code - | Expr.Sequential (e1, e2, NormalSeq, _) -> + | Expr.Sequential(e1, e2, NormalSeq, _) -> let e1R = ConvExpr cenv env e1 - // tail recursive + // tail recursive ConvExprLinear cenv env e2 (contF << (fun e2R -> E.Sequential(e1R, e2R))) - | Expr.Sequential (x0, x1, ThenDoSeq, _) -> - E.Sequential(ConvExpr cenv env x0, ConvExpr cenv env x1) |> contF + | Expr.Sequential(x0, x1, ThenDoSeq, _) -> E.Sequential(ConvExpr cenv env x0, ConvExpr cenv env x1) |> contF - | ModuleValueOrMemberUse g (vref, vFlags, _f, _fty, tyargs, curriedArgs) when (nonNil tyargs || nonNil curriedArgs) && vref.IsMemberOrModuleBinding -> + | ModuleValueOrMemberUse g (vref, vFlags, _f, _fty, tyargs, curriedArgs) when + (nonNil tyargs || nonNil curriedArgs) && vref.IsMemberOrModuleBinding + -> ConvModuleValueOrMemberUseLinear cenv env (expr, vref, vFlags, tyargs, curriedArgs) contF - | Expr.Match (_spBind, m, dtree, tgs, _, retTy) -> + | Expr.Match(_spBind, m, dtree, tgs, _, retTy) -> let dtreeR = ConvDecisionTree cenv env retTy dtree m - // tailcall - ConvTargetsLinear cenv env (List.ofArray tgs) (contF << fun (targetsR: _ list) -> - let (|E|) (x: FSharpExpr) = x.E - - // If the match is really an "if-then-else" then return it as such. - match dtreeR with - | E(E.IfThenElse(a, E(E.DecisionTreeSuccess(0, [])), E(E.DecisionTreeSuccess(1, [])))) -> E.IfThenElse(a, snd targetsR[0], snd targetsR[1]) - | _ -> E.DecisionTree(dtreeR, targetsR)) - - | _ -> - ConvExprPrim cenv env expr |> contF - - /// A nasty function copied from creflect.fs. Made nastier by taking a continuation to process the + // tailcall + ConvTargetsLinear + cenv + env + (List.ofArray tgs) + (contF + << fun (targetsR: _ list) -> + let (|E|) (x: FSharpExpr) = x.E + + // If the match is really an "if-then-else" then return it as such. + match dtreeR with + | E(E.IfThenElse(a, E(E.DecisionTreeSuccess(0, [])), E(E.DecisionTreeSuccess(1, [])))) -> + E.IfThenElse(a, snd targetsR[0], snd targetsR[1]) + | _ -> E.DecisionTree(dtreeR, targetsR)) + + | _ -> ConvExprPrim cenv env expr |> contF + + /// A nasty function copied from creflect.fs. Made nastier by taking a continuation to process the /// arguments to the call in a tail-recursive fashion. and ConvModuleValueOrMemberUseLinear (cenv: SymbolEnv) env (expr: Expr, vref, vFlags, tyargs, curriedArgs) contF = let g = cenv.g let m = expr.Range - let numEnclTypeArgs, _, isNewObj, _valUseFlags, _isSelfInit, takesInstanceArg, _isPropGet, _isPropSet = + let numEnclTypeArgs, _, isNewObj, _valUseFlags, _isSelfInit, takesInstanceArg, _isPropGet, _isPropSet = GetMemberCallInfo g (vref, vFlags) - let isMember, tps, curriedArgInfos = + let isMember, tps, curriedArgInfos = - match vref.MemberInfo with - | Some _ when not vref.IsExtensionMember -> + match vref.MemberInfo with + | Some _ when not vref.IsExtensionMember -> // This is an application of a member method // We only count one argument block for these. - let tps, curriedArgInfos, _, _ = GetTypeOfMemberInFSharpForm g vref + let tps, curriedArgInfos, _, _ = GetTypeOfMemberInFSharpForm g vref true, tps, curriedArgInfos - | _ -> + | _ -> // This is an application of a module value or extension member - let arities = arityOfVal vref.Deref + let arities = arityOfVal vref.Deref let tps, curriedArgInfos, _, _ = GetValReprTypeInFSharpForm g arities vref.Type m false, tps, curriedArgInfos // Compute the object arguments as they appear in a compiled call // Strip off the object argument, if any. The curriedArgInfos are already adjusted to compiled member form - let objArgs, curriedArgs = - match takesInstanceArg, curriedArgs with + let objArgs, curriedArgs = + match takesInstanceArg, curriedArgs with | false, curriedArgs -> [], curriedArgs - | true, objArg :: curriedArgs -> [objArg], curriedArgs - | true, [] -> failwith ("warning: unexpected missing object argument when generating quotation for call to F# object member "+vref.LogicalName) + | true, objArg :: curriedArgs -> [ objArg ], curriedArgs + | true, [] -> + failwith ( + "warning: unexpected missing object argument when generating quotation for call to F# object member " + + vref.LogicalName + ) // Check to see if there aren't enough arguments or if there is a tuple-arity mismatch // If so, adjust and try again - if curriedArgs.Length < curriedArgInfos.Length || - ((List.truncate curriedArgInfos.Length curriedArgs, curriedArgInfos) ||> List.exists2 (fun arg argInfo -> (argInfo.Length > (tryDestRefTupleExpr arg).Length))) then - - // Too few arguments or incorrect tupling? Convert to a lambda and beta-reduce the - // partially applied arguments to 'let' bindings - let valReprInfo = - match vref.ValReprInfo with - | None -> failwith ("no arity information found for F# value "+vref.LogicalName) - | Some a -> a - - let expr, exprTy = AdjustValForExpectedValReprInfo g m vref vFlags valReprInfo - let splitCallExpr = MakeApplicationAndBetaReduce g (expr, exprTy, [tyargs], curriedArgs, m) + if + curriedArgs.Length < curriedArgInfos.Length + || ((List.truncate curriedArgInfos.Length curriedArgs, curriedArgInfos) + ||> List.exists2 (fun arg argInfo -> (argInfo.Length > (tryDestRefTupleExpr arg).Length))) + then + + // Too few arguments or incorrect tupling? Convert to a lambda and beta-reduce the + // partially applied arguments to 'let' bindings + let valReprInfo = + match vref.ValReprInfo with + | None -> failwith ("no arity information found for F# value " + vref.LogicalName) + | Some a -> a + + let expr, exprTy = AdjustValForExpectedValReprInfo g m vref vFlags valReprInfo + + let splitCallExpr = + MakeApplicationAndBetaReduce g (expr, exprTy, [ tyargs ], curriedArgs, m) // tailcall ConvExprPrimLinear cenv env splitCallExpr contF - else - let curriedArgs, laterArgs = List.splitAt curriedArgInfos.Length curriedArgs + else + let curriedArgs, laterArgs = List.splitAt curriedArgInfos.Length curriedArgs // detuple the args - let untupledCurriedArgs = - (curriedArgs, curriedArgInfos) ||> List.map2 (fun arg curriedArgInfo -> - let numUntupledArgs = curriedArgInfo.Length - (if numUntupledArgs = 0 then [] - elif numUntupledArgs = 1 then [arg] - else tryDestRefTupleExpr arg)) - - let contf2 = - match laterArgs with - | [] -> contF - | _ -> (fun subCallR -> (subCallR, laterArgs) ||> List.fold (fun fR arg -> E.Application (Mk2 cenv arg fR, [], [ConvExpr cenv env arg])) |> contF) - - if isMember then + let untupledCurriedArgs = + (curriedArgs, curriedArgInfos) + ||> List.map2 (fun arg curriedArgInfo -> + let numUntupledArgs = curriedArgInfo.Length + + (if numUntupledArgs = 0 then [] + elif numUntupledArgs = 1 then [ arg ] + else tryDestRefTupleExpr arg)) + + let contf2 = + match laterArgs with + | [] -> contF + | _ -> + (fun subCallR -> + (subCallR, laterArgs) + ||> List.fold (fun fR arg -> E.Application(Mk2 cenv arg fR, [], [ ConvExpr cenv env arg ])) + |> contF) + + if isMember then let callArgs = (objArgs :: untupledCurriedArgs) |> List.concat let enclTyArgs, methTyArgs = List.splitAfter numEnclTypeArgs tyargs let witnessArgsR = GetWitnessArgs cenv env vref m tps tyargs // tailcall - ConvObjectModelCallLinear cenv env (isNewObj, FSharpMemberOrFunctionOrValue(cenv, vref), enclTyArgs, methTyArgs, witnessArgsR, callArgs) contf2 + ConvObjectModelCallLinear + cenv + env + (isNewObj, FSharpMemberOrFunctionOrValue(cenv, vref), enclTyArgs, methTyArgs, witnessArgsR, callArgs) + contf2 else let v = FSharpMemberOrFunctionOrValue(cenv, vref) let witnessArgsR = GetWitnessArgs cenv env vref m vref.Typars tyargs @@ -508,29 +588,34 @@ module FSharpExprConvert = and GetWitnessArgs cenv (env: ExprTranslationEnv) (vref: ValRef) m tps tyargs : FSharpExpr list = let g = cenv.g - if g.langVersion.SupportsFeature(Features.LanguageFeature.WitnessPassing) && not env.suppressWitnesses then - let witnessExprs = + + if + g.langVersion.SupportsFeature(Features.LanguageFeature.WitnessPassing) + && not env.suppressWitnesses + then + let witnessExprs = match ConstraintSolver.CodegenWitnessesForTyparInst cenv.tcValF g cenv.amap m tps tyargs with // There is a case where optimized code makes expressions that do a shift-left on the 'char' // type. There is no witness for this case. This is due to the code // let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #) - // in FSharp.Core. - | ErrorResult _ when vref.LogicalName = "op_LeftShift" && List.isSingleton tyargs -> [] + // in FSharp.Core. + | ErrorResult _ when vref.LogicalName = "op_LeftShift" && List.isSingleton tyargs -> [] | res -> CommitOperationResult res + let env = { env with suppressWitnesses = true } - witnessExprs |> List.map (fun arg -> - match arg with - | Choice1Of2 traitInfo -> - ConvWitnessInfo cenv env m traitInfo - | Choice2Of2 arg -> - ConvExpr cenv env arg) + + witnessExprs + |> List.map (fun arg -> + match arg with + | Choice1Of2 traitInfo -> ConvWitnessInfo cenv env m traitInfo + | Choice2Of2 arg -> ConvExpr cenv env arg) else [] - and ConvExprPrim (cenv: SymbolEnv) (env: ExprTranslationEnv) expr = + and ConvExprPrim (cenv: SymbolEnv) (env: ExprTranslationEnv) expr = let g = cenv.g - - // Eliminate integer 'for' loops + + // Eliminate integer 'for' loops let expr = DetectAndOptimizeForEachExpression g OptimizeIntRangesOnly expr // Eliminate subsumption coercions for functions. This must be done post-typechecking because we need @@ -538,399 +623,441 @@ module FSharpExprConvert = let expr = NormalizeAndAdjustPossibleSubsumptionExprs g expr // Remove TExpr_ref nodes - let expr = stripExpr expr + let expr = stripExpr expr + + match expr with - match expr with - // Uses of possibly-polymorphic values which were not polymorphic in the end - | Expr.App (InnerExprPat(Expr.Val _ as ve), _fty, [], [], _) -> - ConvExprPrim cenv env ve + | Expr.App(InnerExprPat(Expr.Val _ as ve), _fty, [], [], _) -> ConvExprPrim cenv env ve - // These cases are the start of a "linear" sequence where we use tail recursion to allow use to + // These cases are the start of a "linear" sequence where we use tail recursion to allow use to // deal with large expressions. - | Expr.Op (TOp.UnionCase _, _, [_;_], _) // big lists - | Expr.Let _ // big linear sequences of 'let' - | Expr.Match _ // big linear sequences of 'match ... -> ....' - | Expr.Sequential _ -> - ConvExprPrimLinear cenv env expr id - - | ModuleValueOrMemberUse g (vref, vFlags, _f, _fty, tyargs, curriedArgs) when (* (nonNil tyargs || nonNil curriedArgs) && *) vref.IsMemberOrModuleBinding -> + | Expr.Op(TOp.UnionCase _, _, [ _; _ ], _) // big lists + | Expr.Let _ // big linear sequences of 'let' + | Expr.Match _ // big linear sequences of 'match ... -> ....' + | Expr.Sequential _ -> ConvExprPrimLinear cenv env expr id + + | ModuleValueOrMemberUse g (vref, vFlags, _f, _fty, tyargs, curriedArgs) (* (nonNil tyargs || nonNil curriedArgs) && *) when + vref.IsMemberOrModuleBinding + -> // Process applications of top-level values in a tail-recursive way ConvModuleValueOrMemberUseLinear cenv env (expr, vref, vFlags, tyargs, curriedArgs) id - | Expr.Val (vref, _vFlags, m) -> - ConvValRef cenv env m vref + | Expr.Val(vref, _vFlags, m) -> ConvValRef cenv env m vref + + // Simple applications + | Expr.App(f, _fty, tyargs, args, _m) -> E.Application(ConvExpr cenv env f, ConvTypes cenv tyargs, ConvExprs cenv env args) - // Simple applications - | Expr.App (f, _fty, tyargs, args, _m) -> - E.Application (ConvExpr cenv env f, ConvTypes cenv tyargs, ConvExprs cenv env args) - - | Expr.Const (c, m, ty) -> - ConvConst cenv env m c ty + | Expr.Const(c, m, ty) -> ConvConst cenv env m c ty - | Expr.LetRec (binds, body, _, _) -> + | Expr.LetRec(binds, body, _, _) -> let dps = binds |> List.map (fun bind -> bind.DebugPoint) let vs = valsOfBinds binds let vsR = vs |> List.map (ConvVal cenv) let env = env.BindVals vs - let bodyR = ConvExpr cenv env body - let bindsR = List.zip3 vsR (binds |> List.map (fun b -> b.Expr |> ConvExpr cenv env)) dps - E.LetRec(bindsR, bodyR) - - | Expr.Lambda (_, _, _, vs, b, _, _) -> - let v, b = MultiLambdaToTupledLambda g vs b - let vR = ConvVal cenv v - let bR = ConvExpr cenv (env.BindVal v) b - E.Lambda(vR, bR) - - | Expr.Quote (ast, _, _, _, _) -> - E.Quote(ConvExpr cenv env ast) - - | Expr.TyLambda (_, tps, b, _, _) -> + let bodyR = ConvExpr cenv env body + + let bindsR = + List.zip3 vsR (binds |> List.map (fun b -> b.Expr |> ConvExpr cenv env)) dps + + E.LetRec(bindsR, bodyR) + + | Expr.Lambda(_, _, _, vs, b, _, _) -> + let v, b = MultiLambdaToTupledLambda g vs b + let vR = ConvVal cenv v + let bR = ConvExpr cenv (env.BindVal v) b + E.Lambda(vR, bR) + + | Expr.Quote(ast, _, _, _, _) -> E.Quote(ConvExpr cenv env ast) + + | Expr.TyLambda(_, tps, b, _, _) -> let gps = [ for tp in tps -> FSharpGenericParameter(cenv, tp) ] - let env = env.BindTypars (Seq.zip tps gps |> Seq.toList) - E.TypeLambda(gps, ConvExpr cenv env b) + let env = env.BindTypars(Seq.zip tps gps |> Seq.toList) + E.TypeLambda(gps, ConvExpr cenv env b) - | Expr.Obj (_, ty, _, _, [TObjExprMethod(TSlotSig(_, ctyp, _, _, _, _), _, tps, [tmvs], e, _) as tmethod], _, m) when isDelegateTy g ty -> - let f = mkLambdas g m tps tmvs (e, GetFSharpViewOfReturnType g (returnTyOfMethod g tmethod)) - let fR = ConvExpr cenv env f - let tyargR = ConvType cenv ctyp - E.NewDelegate(tyargR, fR) + | Expr.Obj(_, ty, _, _, [ TObjExprMethod(TSlotSig(_, ctyp, _, _, _, _), _, tps, [ tmvs ], e, _) as tmethod ], _, m) when + isDelegateTy g ty + -> + let f = + mkLambdas g m tps tmvs (e, GetFSharpViewOfReturnType g (returnTyOfMethod g tmethod)) - | Expr.StaticOptimization (_, _, x, _) -> - ConvExprPrim cenv env x + let fR = ConvExpr cenv env f + let tyargR = ConvType cenv ctyp + E.NewDelegate(tyargR, fR) - | Expr.TyChoose _ -> - ConvExprPrim cenv env (ChooseTyparSolutionsForFreeChoiceTypars g cenv.amap expr) + | Expr.StaticOptimization(_, _, x, _) -> ConvExprPrim cenv env x - | Expr.Obj (_lambdaId, ty, _basev, basecall, overrides, iimpls, _m) -> + | Expr.TyChoose _ -> ConvExprPrim cenv env (ChooseTyparSolutionsForFreeChoiceTypars g cenv.amap expr) + + | Expr.Obj(_lambdaId, ty, _basev, basecall, overrides, iimpls, _m) -> let basecallR = ConvExpr cenv env basecall - let ConvertMethods methods = - [ for TObjExprMethod(slotsig, _, tps, tmvs, body, _) in methods -> - let vslR = List.mapSquared (ConvVal cenv) tmvs - let sgn = FSharpAbstractSignature(cenv, slotsig) - let tpsR = [ for tp in tps -> FSharpGenericParameter(cenv, tp) ] - let env = env.BindTypars (Seq.zip tps tpsR |> Seq.toList) - let env = env.BindCurriedVals tmvs - let bodyR = ConvExpr cenv env body - FSharpObjectExprOverride(sgn, tpsR, vslR, bodyR) ] - let overridesR = ConvertMethods overrides - let iimplsR = iimpls |> List.map (fun (intfTy, impls) -> ConvType cenv intfTy, ConvertMethods impls) + + let ConvertMethods methods = + [ + for TObjExprMethod(slotsig, _, tps, tmvs, body, _) in methods -> + let vslR = List.mapSquared (ConvVal cenv) tmvs + let sgn = FSharpAbstractSignature(cenv, slotsig) + let tpsR = [ for tp in tps -> FSharpGenericParameter(cenv, tp) ] + let env = env.BindTypars(Seq.zip tps tpsR |> Seq.toList) + let env = env.BindCurriedVals tmvs + let bodyR = ConvExpr cenv env body + FSharpObjectExprOverride(sgn, tpsR, vslR, bodyR) + ] + + let overridesR = ConvertMethods overrides + + let iimplsR = + iimpls + |> List.map (fun (intfTy, impls) -> ConvType cenv intfTy, ConvertMethods impls) E.ObjectExpr(ConvType cenv ty, basecallR, overridesR, iimplsR) - | Expr.Op (op, tyargs, args, m) -> - match op, tyargs, args with - | TOp.UnionCase ucref, _, _ -> - let mkR = ConvUnionCaseRef cenv ucref + | Expr.Op(op, tyargs, args, m) -> + match op, tyargs, args with + | TOp.UnionCase ucref, _, _ -> + let mkR = ConvUnionCaseRef cenv ucref let typR = ConvType cenv (mkWoNullAppTy ucref.TyconRef tyargs) let argsR = ConvExprs cenv env args - E.NewUnionCase(typR, mkR, argsR) + E.NewUnionCase(typR, mkR, argsR) - | TOp.AnonRecd anonInfo, _, _ -> + | TOp.AnonRecd anonInfo, _, _ -> let typR = ConvType cenv (mkAnyAnonRecdTy g anonInfo tyargs) let argsR = ConvExprs cenv env args - E.NewAnonRecord(typR, argsR) + E.NewAnonRecord(typR, argsR) - | TOp.Tuple tupInfo, tyargs, _ -> + | TOp.Tuple tupInfo, tyargs, _ -> let tyR = ConvType cenv (mkAnyTupledTy g tupInfo tyargs) let argsR = ConvExprs cenv env args - E.NewTuple(tyR, argsR) + E.NewTuple(tyR, argsR) - | TOp.Recd (_, tcref), _, _ -> + | TOp.Recd(_, tcref), _, _ -> let typR = ConvType cenv (mkWoNullAppTy tcref tyargs) let argsR = ConvExprs cenv env args - E.NewRecord(typR, argsR) + E.NewRecord(typR, argsR) - | TOp.UnionCaseFieldGet (ucref, n), tyargs, [e1] -> - let mkR = ConvUnionCaseRef cenv ucref + | TOp.UnionCaseFieldGet(ucref, n), tyargs, [ e1 ] -> + let mkR = ConvUnionCaseRef cenv ucref let typR = ConvType cenv (mkWoNullAppTy ucref.TyconRef tyargs) let projR = FSharpField(cenv, ucref, n) - E.UnionCaseGet(ConvExpr cenv env e1, typR, mkR, projR) + E.UnionCaseGet(ConvExpr cenv env e1, typR, mkR, projR) - | TOp.AnonRecdGet (anonInfo, n), tyargs, [e1] -> + | TOp.AnonRecdGet(anonInfo, n), tyargs, [ e1 ] -> let typR = ConvType cenv (mkAnyAnonRecdTy g anonInfo tyargs) - E.AnonRecordGet(ConvExpr cenv env e1, typR, n) + E.AnonRecordGet(ConvExpr cenv env e1, typR, n) - | TOp.UnionCaseFieldSet (ucref, n), tyargs, [e1;e2] -> - let mkR = ConvUnionCaseRef cenv ucref + | TOp.UnionCaseFieldSet(ucref, n), tyargs, [ e1; e2 ] -> + let mkR = ConvUnionCaseRef cenv ucref let typR = ConvType cenv (mkWoNullAppTy ucref.TyconRef tyargs) let projR = FSharpField(cenv, ucref, n) - E.UnionCaseSet(ConvExpr cenv env e1, typR, mkR, projR, ConvExpr cenv env e2) + E.UnionCaseSet(ConvExpr cenv env e1, typR, mkR, projR, ConvExpr cenv env e2) - | TOp.UnionCaseFieldGetAddr _, _tyargs, _ -> - E.AddressOf(ConvLValueExpr cenv env expr) + | TOp.UnionCaseFieldGetAddr _, _tyargs, _ -> E.AddressOf(ConvLValueExpr cenv env expr) - | TOp.ValFieldGetAddr _, _tyargs, _ -> - E.AddressOf(ConvLValueExpr cenv env expr) + | TOp.ValFieldGetAddr _, _tyargs, _ -> E.AddressOf(ConvLValueExpr cenv env expr) | TOp.ValFieldGet rfref, tyargs, [] -> - let projR = ConvRecdFieldRef cenv rfref + let projR = ConvRecdFieldRef cenv rfref let typR = ConvType cenv (mkWoNullAppTy rfref.TyconRef tyargs) - E.FSharpFieldGet(None, typR, projR) + E.FSharpFieldGet(None, typR, projR) - | TOp.ValFieldGet rfref, tyargs, [obj] -> + | TOp.ValFieldGet rfref, tyargs, [ obj ] -> let objR = ConvLValueExpr cenv env obj - let projR = ConvRecdFieldRef cenv rfref + let projR = ConvRecdFieldRef cenv rfref let typR = ConvType cenv (mkWoNullAppTy rfref.TyconRef tyargs) - E.FSharpFieldGet(Some objR, typR, projR) + E.FSharpFieldGet(Some objR, typR, projR) - | TOp.TupleFieldGet (tupInfo, n), tyargs, [e] -> + | TOp.TupleFieldGet(tupInfo, n), tyargs, [ e ] -> let tyR = ConvType cenv (mkAnyTupledTy g tupInfo tyargs) - E.TupleGet(tyR, n, ConvExpr cenv env e) + E.TupleGet(tyR, n, ConvExpr cenv env e) - | TOp.ILAsm ([ I_ldfld (_, _, fspec) ], _), enclTypeArgs, [obj] -> - let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs + | TOp.ILAsm([ I_ldfld(_, _, fspec) ], _), enclTypeArgs, [ obj ] -> + let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs let objR = ConvLValueExpr cenv env obj - E.ILFieldGet(Some objR, typR, fspec.Name) + E.ILFieldGet(Some objR, typR, fspec.Name) - | TOp.ILAsm (( [ I_ldsfld (_, fspec) ] | [ I_ldsfld (_, fspec); AI_nop ]), _), enclTypeArgs, [] -> - let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs - E.ILFieldGet(None, typR, fspec.Name) + | TOp.ILAsm(([ I_ldsfld(_, fspec) ] | [ I_ldsfld(_, fspec); AI_nop ]), _), enclTypeArgs, [] -> + let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs + E.ILFieldGet(None, typR, fspec.Name) - | TOp.ILAsm ([ I_stfld (_, _, fspec) ], _), enclTypeArgs, [obj;arg] -> - let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs + | TOp.ILAsm([ I_stfld(_, _, fspec) ], _), enclTypeArgs, [ obj; arg ] -> + let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs let objR = ConvLValueExpr cenv env obj let argR = ConvExpr cenv env arg - E.ILFieldSet(Some objR, typR, fspec.Name, argR) + E.ILFieldSet(Some objR, typR, fspec.Name, argR) - | TOp.ILAsm ([ I_stsfld (_, fspec) ], _), enclTypeArgs, [arg] -> - let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs + | TOp.ILAsm([ I_stsfld(_, fspec) ], _), enclTypeArgs, [ arg ] -> + let typR = ConvILTypeRefApp cenv m fspec.DeclaringTypeRef enclTypeArgs let argR = ConvExpr cenv env arg - E.ILFieldSet(None, typR, fspec.Name, argR) + E.ILFieldSet(None, typR, fspec.Name, argR) - | TOp.ILAsm ([ ], [tgtTy]), _, [arg] -> + | TOp.ILAsm([], [ tgtTy ]), _, [ arg ] -> match tgtTy with | TTypeConvOp cenv convOp -> let ty = tyOfExpr g arg let op = convOp g m ty arg ConvExprPrim cenv env op - | _ -> - ConvExprPrim cenv env arg + | _ -> ConvExprPrim cenv env arg - | TOp.ILAsm ([ I_box _ ], _), [ty], [arg] -> + | TOp.ILAsm([ I_box _ ], _), [ ty ], [ arg ] -> let op = mkCallBox g m ty arg ConvExprPrim cenv env op - | TOp.ILAsm ([ I_unbox_any _ ], _), [ty], [arg] -> + | TOp.ILAsm([ I_unbox_any _ ], _), [ ty ], [ arg ] -> let op = mkCallUnbox g m ty arg ConvExprPrim cenv env op - | TOp.ILAsm ([ I_isinst _ ], _), [ty], [arg] -> + | TOp.ILAsm([ I_isinst _ ], _), [ ty ], [ arg ] -> let op = mkCallTypeTest g m ty arg ConvExprPrim cenv env op - | TOp.ILAsm ([ I_call (Normalcall, mspec, None) ], _), _, [arg] - when mspec.MethodRef.DeclaringTypeRef.Name = "System.String" && mspec.Name = "GetHashCode" -> + | TOp.ILAsm([ I_call(Normalcall, mspec, None) ], _), _, [ arg ] when + mspec.MethodRef.DeclaringTypeRef.Name = "System.String" + && mspec.Name = "GetHashCode" + -> let ty = tyOfExpr g arg let op = mkCallHash g m ty arg ConvExprPrim cenv env op - | TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, _, _, _), [], - [Expr.Op (TOp.ILAsm ([ I_ldtoken (ILToken.ILType _) ], _), [ty], _, _)] - when ilMethRef.DeclaringTypeRef.Name = "System.Type" && ilMethRef.Name = "GetTypeFromHandle" -> + | TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _), + [], + [ Expr.Op(TOp.ILAsm([ I_ldtoken(ILToken.ILType _) ], _), [ ty ], _, _) ] when + ilMethRef.DeclaringTypeRef.Name = "System.Type" + && ilMethRef.Name = "GetTypeFromHandle" + -> let op = mkCallTypeOf g m ty ConvExprPrim cenv env op - | TOp.ILAsm ([ EI_ilzero _ ], _), [ty], _ -> - E.DefaultValue (ConvType cenv ty) + | TOp.ILAsm([ EI_ilzero _ ], _), [ ty ], _ -> E.DefaultValue(ConvType cenv ty) - | TOp.ILAsm ([ AI_ldnull; AI_cgt_un ], _), _, [arg] -> + | TOp.ILAsm([ AI_ldnull; AI_cgt_un ], _), _, [ arg ] -> let elemTy = tyOfExpr g arg let nullVal = mkNull m elemTy let op = mkCallNotEqualsOperator g m elemTy arg nullVal - let env = { env with suppressWitnesses=true } + let env = { env with suppressWitnesses = true } ConvExprPrim cenv env op - | TOp.ILAsm ([ I_ldlen; AI_conv DT_I4 ], _), _, [arr] -> + | TOp.ILAsm([ I_ldlen; AI_conv DT_I4 ], _), _, [ arr ] -> let arrayTy = tyOfExpr g arr let elemTy = destArrayTy g arrayTy let op = mkCallArrayLength g m elemTy arr - let env = { env with suppressWitnesses=true } + let env = { env with suppressWitnesses = true } ConvExprPrim cenv env op - | TOp.ILAsm ([ I_newarr (ILArrayShape [(Some 0, None)], _)], _), [elemTy], xa -> + | TOp.ILAsm([ I_newarr(ILArrayShape [ (Some 0, None) ], _) ], _), [ elemTy ], xa -> E.NewArray(ConvType cenv elemTy, ConvExprs cenv env xa) - | TOp.ILAsm ([ I_ldelem_any (ILArrayShape [(Some 0, None)], _)], _), [elemTy], [arr; idx1] -> + | TOp.ILAsm([ I_ldelem_any(ILArrayShape [ (Some 0, None) ], _) ], _), [ elemTy ], [ arr; idx1 ] -> let op = mkCallArrayGet g m elemTy arr idx1 ConvExprPrim cenv env op - | TOp.ILAsm ([ I_stelem_any (ILArrayShape [(Some 0, None)], _)], _), [elemTy], [arr; idx1; v] -> + | TOp.ILAsm([ I_stelem_any(ILArrayShape [ (Some 0, None) ], _) ], _), [ elemTy ], [ arr; idx1; v ] -> let op = mkCallArraySet g m elemTy arr idx1 v ConvExprPrim cenv env op - | TOp.ILAsm ([ ILUnaryOp unaryOp ], _), _, [arg] -> + | TOp.ILAsm([ ILUnaryOp unaryOp ], _), _, [ arg ] -> let ty = tyOfExpr g arg let op = unaryOp g m ty arg ConvExprPrim cenv env op - | TOp.ILAsm ([ ILBinaryOp binaryOp ], _), _, [arg1;arg2] -> + | TOp.ILAsm([ ILBinaryOp binaryOp ], _), _, [ arg1; arg2 ] -> let ty = tyOfExpr g arg1 let op = binaryOp g m ty arg1 arg2 ConvExprPrim cenv env op // For units of measure some binary operators change their return type, e.g. a * b where each is int gives int - | TOp.ILAsm ([ ILMulDivOp (binaryOp, isMul) ], _), _, [arg1;arg2] -> + | TOp.ILAsm([ ILMulDivOp(binaryOp, isMul) ], _), _, [ arg1; arg2 ] -> let argTy1 = tyOfExpr g arg1 let argTy2 = tyOfExpr g arg2 - let resTy = + + let resTy = match getMeasureOfType g argTy1, getMeasureOfType g argTy2 with - | Some (tcref, ms1), Some (_tcref2, ms2) -> mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, (if isMul then ms2 else Measure.Inv ms2), unionRanges ms1.Range ms2.Range))] - | Some _, None -> argTy1 + | Some(tcref, ms1), Some(_tcref2, ms2) -> + mkWoNullAppTy + tcref + [ + TType_measure(Measure.Prod(ms1, (if isMul then ms2 else Measure.Inv ms2), unionRanges ms1.Range ms2.Range)) + ] + | Some _, None -> argTy1 | None, Some _ -> argTy2 | None, None -> argTy1 + let op = binaryOp g m argTy1 argTy2 resTy arg1 arg2 ConvExprPrim cenv env op - | TOp.ILAsm ([ ILConvertOp convertOp1; ILConvertOp convertOp2 ], _), _, [arg] -> + | TOp.ILAsm([ ILConvertOp convertOp1; ILConvertOp convertOp2 ], _), _, [ arg ] -> let ty1 = tyOfExpr g arg let op1 = convertOp1 g m ty1 arg let ty2 = tyOfExpr g op1 let op2 = convertOp2 g m ty2 op1 ConvExprPrim cenv env op2 - | TOp.ILAsm ([ ILConvertOp convertOp ], [ty2]), _, [arg] -> + | TOp.ILAsm([ ILConvertOp convertOp ], [ ty2 ]), _, [ arg ] -> let ty = tyOfExpr g arg + let op = if typeEquiv g ty2 g.char_ty then mkCallToCharOperator g m ty arg - else convertOp g m ty arg + else + convertOp g m ty arg + ConvExprPrim cenv env op - | TOp.ILAsm ([ I_throw ], _), _, [arg1] -> - let raiseExpr = mkCallRaise g m (tyOfExpr g expr) arg1 - ConvExprPrim cenv env raiseExpr + | TOp.ILAsm([ I_throw ], _), _, [ arg1 ] -> + let raiseExpr = mkCallRaise g m (tyOfExpr g expr) arg1 + ConvExprPrim cenv env raiseExpr - | TOp.ILAsm (instrs, _), tyargs, args -> - E.ILAsm(sprintf "%+A" instrs, ConvTypes cenv tyargs, ConvExprs cenv env args) + | TOp.ILAsm(instrs, _), tyargs, args -> E.ILAsm(sprintf "%+A" instrs, ConvTypes cenv tyargs, ConvExprs cenv env args) - | TOp.ExnConstr tcref, tyargs, args -> - E.NewRecord(ConvType cenv (mkWoNullAppTy tcref tyargs), ConvExprs cenv env args) + | TOp.ExnConstr tcref, tyargs, args -> E.NewRecord(ConvType cenv (mkWoNullAppTy tcref tyargs), ConvExprs cenv env args) - | TOp.ValFieldSet rfref, _tinst, [obj;arg] -> + | TOp.ValFieldSet rfref, _tinst, [ obj; arg ] -> let objR = ConvLValueExpr cenv env obj let argR = ConvExpr cenv env arg let typR = ConvType cenv (mkWoNullAppTy rfref.TyconRef tyargs) - let projR = ConvRecdFieldRef cenv rfref - E.FSharpFieldSet(Some objR, typR, projR, argR) + let projR = ConvRecdFieldRef cenv rfref + E.FSharpFieldSet(Some objR, typR, projR, argR) - | TOp.ValFieldSet rfref, _tinst, [arg] -> + | TOp.ValFieldSet rfref, _tinst, [ arg ] -> let argR = ConvExpr cenv env arg let typR = ConvType cenv (mkWoNullAppTy rfref.TyconRef tyargs) - let projR = ConvRecdFieldRef cenv rfref - E.FSharpFieldSet(None, typR, projR, argR) + let projR = ConvRecdFieldRef cenv rfref + E.FSharpFieldSet(None, typR, projR, argR) - | TOp.ExnFieldGet (tcref, i), [], [obj] -> + | TOp.ExnFieldGet(tcref, i), [], [ obj ] -> let exnc = stripExnEqns tcref let fspec = exnc.TrueInstanceFieldsAsList[i] let fref = mkRecdFieldRef tcref fspec.LogicalName let typR = ConvType cenv (mkWoNullAppTy tcref tyargs) - let objR = ConvExpr cenv env (mkCoerceExpr (obj, mkWoNullAppTy tcref [], m, g.exn_ty)) - E.FSharpFieldGet(Some objR, typR, ConvRecdFieldRef cenv fref) - | TOp.ExnFieldSet (tcref, i), [], [obj;e2] -> + let objR = + ConvExpr cenv env (mkCoerceExpr (obj, mkWoNullAppTy tcref [], m, g.exn_ty)) + + E.FSharpFieldGet(Some objR, typR, ConvRecdFieldRef cenv fref) + + | TOp.ExnFieldSet(tcref, i), [], [ obj; e2 ] -> let exnc = stripExnEqns tcref let fspec = exnc.TrueInstanceFieldsAsList[i] let fref = mkRecdFieldRef tcref fspec.LogicalName let typR = ConvType cenv (mkWoNullAppTy tcref tyargs) - let objR = ConvExpr cenv env (mkCoerceExpr (obj, mkWoNullAppTy tcref [], m, g.exn_ty)) - E.FSharpFieldSet(Some objR, typR, ConvRecdFieldRef cenv fref, ConvExpr cenv env e2) - | TOp.Coerce, [tgtTy;srcTy], [x] -> - if typeEquiv g tgtTy srcTy then + let objR = + ConvExpr cenv env (mkCoerceExpr (obj, mkWoNullAppTy tcref [], m, g.exn_ty)) + + E.FSharpFieldSet(Some objR, typR, ConvRecdFieldRef cenv fref, ConvExpr cenv env e2) + + | TOp.Coerce, [ tgtTy; srcTy ], [ x ] -> + if typeEquiv g tgtTy srcTy then ConvExprPrim cenv env x else - E.Coerce(ConvType cenv tgtTy, ConvExpr cenv env x) + E.Coerce(ConvType cenv tgtTy, ConvExpr cenv env x) - | TOp.Reraise, [toTy], [] -> - // rebuild reraise() and Convert - mkReraiseLibCall g toTy m |> ConvExprPrim cenv env + | TOp.Reraise, [ toTy ], [] -> + // rebuild reraise() and Convert + mkReraiseLibCall g toTy m |> ConvExprPrim cenv env - | TOp.LValueOp (LAddrOf _, vref), [], [] -> - E.AddressOf(ConvExpr cenv env (exprForValRef m vref)) + | TOp.LValueOp(LAddrOf _, vref), [], [] -> E.AddressOf(ConvExpr cenv env (exprForValRef m vref)) - | TOp.LValueOp (LByrefSet, vref), [], [e] -> - E.AddressSet(ConvExpr cenv env (exprForValRef m vref), ConvExpr cenv env e) + | TOp.LValueOp(LByrefSet, vref), [], [ e ] -> E.AddressSet(ConvExpr cenv env (exprForValRef m vref), ConvExpr cenv env e) - | TOp.LValueOp (LSet, vref), [], [e] -> - E.ValueSet(FSharpMemberOrFunctionOrValue(cenv, vref), ConvExpr cenv env e) + | TOp.LValueOp(LSet, vref), [], [ e ] -> E.ValueSet(FSharpMemberOrFunctionOrValue(cenv, vref), ConvExpr cenv env e) - | TOp.LValueOp (LByrefGet, vref), [], [] -> - ConvValRef cenv env m vref + | TOp.LValueOp(LByrefGet, vref), [], [] -> ConvValRef cenv env m vref - | TOp.Array, [ty], xa -> - E.NewArray(ConvType cenv ty, ConvExprs cenv env xa) + | TOp.Array, [ ty ], xa -> E.NewArray(ConvType cenv ty, ConvExprs cenv env xa) - | TOp.While (dp, _), [], [Expr.Lambda (_, _, _, [_], test, _, _);Expr.Lambda (_, _, _, [_], body, _, _)] -> - E.WhileLoop(ConvExpr cenv env test, ConvExpr cenv env body, dp) - - | TOp.IntegerForLoop (dpFor, dpEquals, dir), [], [Expr.Lambda (_, _, _, [_], lim0, _, _); Expr.Lambda (_, _, _, [_], SimpleArrayLoopUpperBound, lm, _); SimpleArrayLoopBody g (arr, elemTy, body)] -> - let lim1 = + | TOp.While(dp, _), [], [ Expr.Lambda(_, _, _, [ _ ], test, _, _); Expr.Lambda(_, _, _, [ _ ], body, _, _) ] -> + E.WhileLoop(ConvExpr cenv env test, ConvExpr cenv env body, dp) + + | TOp.IntegerForLoop(dpFor, dpEquals, dir), + [], + [ Expr.Lambda(_, _, _, [ _ ], lim0, _, _) + Expr.Lambda(_, _, _, [ _ ], SimpleArrayLoopUpperBound, lm, _) + SimpleArrayLoopBody g (arr, elemTy, body) ] -> + let lim1 = let len = mkCallArrayLength g lm elemTy arr // Array.length arr mkCallSubtractionOperator g lm g.int32_ty len (mkOne g lm) // len - 1 - E.IntegerForLoop(ConvExpr cenv env lim0, ConvExpr cenv env lim1, ConvExpr cenv env body, dir <> FSharpForLoopDown, dpFor, dpEquals) - | TOp.IntegerForLoop (doFor, doEquals, dir), [], [Expr.Lambda (_, _, _, [_], lim0, _, _); Expr.Lambda (_, _, _, [_], lim1, lm, _); body] -> + E.IntegerForLoop( + ConvExpr cenv env lim0, + ConvExpr cenv env lim1, + ConvExpr cenv env body, + dir <> FSharpForLoopDown, + dpFor, + dpEquals + ) + + | TOp.IntegerForLoop(doFor, doEquals, dir), + [], + [ Expr.Lambda(_, _, _, [ _ ], lim0, _, _); Expr.Lambda(_, _, _, [ _ ], lim1, lm, _); body ] -> let lim1 = if dir = CSharpForLoopUp then mkCallSubtractionOperator g lm g.int32_ty lim1 (mkOne g lm) // len - 1 - else lim1 - E.IntegerForLoop(ConvExpr cenv env lim0, ConvExpr cenv env lim1, ConvExpr cenv env body, dir <> FSharpForLoopDown, doFor, doEquals) - - | TOp.ILCall (_, _, _, isCtor, valUseFlag, _, _, ilMethRef, enclTypeInst, methInst, _), [], callArgs -> + else + lim1 + + E.IntegerForLoop( + ConvExpr cenv env lim0, + ConvExpr cenv env lim1, + ConvExpr cenv env body, + dir <> FSharpForLoopDown, + doFor, + doEquals + ) + + | TOp.ILCall(_, _, _, isCtor, valUseFlag, _, _, ilMethRef, enclTypeInst, methInst, _), [], callArgs -> ConvILCall cenv env (isCtor, valUseFlag, ilMethRef, enclTypeInst, methInst, callArgs, m) - | TOp.TryFinally (dpTry, dpFinally), [_resty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> - E.TryFinally(ConvExpr cenv env e1, ConvExpr cenv env e2, dpTry, dpFinally) + | TOp.TryFinally(dpTry, dpFinally), [ _resty ], [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ] -> + E.TryFinally(ConvExpr cenv env e1, ConvExpr cenv env e2, dpTry, dpFinally) - | TOp.TryWith (dpTry, dpWith), [_resty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [vf], ef, _, _); Expr.Lambda (_, _, _, [vh], eh, _, _)] -> + | TOp.TryWith(dpTry, dpWith), + [ _resty ], + [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ vf ], ef, _, _); Expr.Lambda(_, _, _, [ vh ], eh, _, _) ] -> let vfR = ConvVal cenv vf let envf = env.BindVal vf let vhR = ConvVal cenv vh let envh = env.BindVal vh - E.TryWith(ConvExpr cenv env e1, vfR, ConvExpr cenv envf ef, vhR, ConvExpr cenv envh eh, dpTry, dpWith) + E.TryWith(ConvExpr cenv env e1, vfR, ConvExpr cenv envf ef, vhR, ConvExpr cenv envh eh, dpTry, dpWith) | TOp.Bytes bytes, [], [] -> E.Const(box bytes, ConvType cenv (tyOfExpr g expr)) | TOp.UInt16s arr, [], [] -> E.Const(box arr, ConvType cenv (tyOfExpr g expr)) - - | TOp.UnionCaseProof _, _, [e] -> ConvExprPrim cenv env e // Note: we erase the union case proof conversions when converting to quotations - | TOp.UnionCaseTagGet tycr, tyargs, [arg1] -> + + | TOp.UnionCaseProof _, _, [ e ] -> ConvExprPrim cenv env e // Note: we erase the union case proof conversions when converting to quotations + | TOp.UnionCaseTagGet tycr, tyargs, [ arg1 ] -> let typR = ConvType cenv (mkWoNullAppTy tycr tyargs) - E.UnionCaseTag(ConvExpr cenv env arg1, typR) + E.UnionCaseTag(ConvExpr cenv env arg1, typR) | TOp.TraitCall traitInfo, _, _ -> let tysR = ConvTypes cenv traitInfo.SupportTypes let tyargsR = ConvTypes cenv tyargs let argTysR = ConvTypes cenv traitInfo.CompiledObjectAndArgumentTypes let argsR = ConvExprs cenv env args - E.TraitCall(tysR, traitInfo.MemberLogicalName, traitInfo.MemberFlags, argTysR, tyargsR, argsR) + E.TraitCall(tysR, traitInfo.MemberLogicalName, traitInfo.MemberFlags, argTysR, tyargsR, argsR) + + | TOp.RefAddrGet readonly, [ ty ], [ e ] -> + let replExpr = + mkRecdFieldGetAddrViaExprAddr (readonly, e, mkRefCellContentsRef g, [ ty ], m) - | TOp.RefAddrGet readonly, [ty], [e] -> - let replExpr = mkRecdFieldGetAddrViaExprAddr(readonly, e, mkRefCellContentsRef g, [ty], m) ConvExprPrim cenv env replExpr | _ -> wfail (sprintf "unhandled construct in AST", m) - | Expr.WitnessArg (traitInfo, _m) -> - ConvWitnessInfoPrim env traitInfo + | Expr.WitnessArg(traitInfo, _m) -> ConvWitnessInfoPrim env traitInfo - | Expr.DebugPoint (_, innerExpr) -> - ConvExprPrim cenv env innerExpr + | Expr.DebugPoint(_, innerExpr) -> ConvExprPrim cenv env innerExpr - | _ -> - wfail (sprintf "unhandled construct in AST", expr.Range) + | _ -> wfail (sprintf "unhandled construct in AST", expr.Range) and ConvWitnessInfoPrim env traitInfo : E = let witnessInfo = traitInfo.GetWitnessInfo() let env = { env with suppressWitnesses = true } // First check if this is a witness in ReflectedDefinition code match env.witnessesInScope.TryGetValue witnessInfo with - | true, scopewitnessinfo -> + | true, scopewitnessinfo -> let witnessArgIdx = scopewitnessinfo E.WitnessArg(witnessArgIdx) - // Otherwise it is a witness in a quotation literal + // Otherwise it is a witness in a quotation literal | false, _ -> //failwith "witness not found" E.WitnessArg(-1) @@ -938,62 +1065,66 @@ module FSharpExprConvert = and ConvWitnessInfo cenv env m traitInfo : FSharpExpr = let g = cenv.g let witnessInfo = traitInfo.GetWitnessInfo() - let witnessTy = GenWitnessTy g witnessInfo + let witnessTy = GenWitnessTy g witnessInfo let traitInfoR = ConvWitnessInfoPrim env traitInfo Mk cenv m witnessTy traitInfoR - and ConvLetBind cenv env (bind : Binding) = - match bind.Expr with - // Map for values bound by the - // 'let v = isinst e in .... if nonnull v then ...v .... ' + and ConvLetBind cenv env (bind: Binding) = + match bind.Expr with + // Map for values bound by the + // 'let v = isinst e in .... if nonnull v then ...v .... ' // construct arising out the compilation of pattern matching. We decode these back to the form - // 'if istype e then ...unbox e .... ' - // It's bit annoying that pattern matching does this transformation. Like all premature optimization we pay a + // 'if istype e then ...unbox e .... ' + // It's bit annoying that pattern matching does this transformation. Like all premature optimization we pay a // cost here to undo it. - | Expr.Op (TOp.ILAsm ([ I_isinst _ ], _), [ty], [e], _) -> - None, env.BindIsInstVal bind.Var (ty, e) - + | Expr.Op(TOp.ILAsm([ I_isinst _ ], _), [ ty ], [ e ], _) -> None, env.BindIsInstVal bind.Var (ty, e) + // Remove let = from quotation tree - | Expr.Val _ when bind.Var.IsCompilerGenerated && (not bind.Var.IsMutable) -> - None, env.BindSubstVal bind.Var bind.Expr + | Expr.Val _ when bind.Var.IsCompilerGenerated && (not bind.Var.IsMutable) -> None, env.BindSubstVal bind.Var bind.Expr // Remove let = () from quotation tree - | Expr.Const (Const.Unit, _, _) when bind.Var.IsCompilerGenerated && (not bind.Var.IsMutable) -> + | Expr.Const(Const.Unit, _, _) when bind.Var.IsCompilerGenerated && (not bind.Var.IsMutable) -> None, env.BindSubstVal bind.Var bind.Expr // Remove let unionCase = ... from quotation tree - | Expr.Op (TOp.UnionCaseProof _, _, [e], _) when (not bind.Var.IsMutable) -> - None, env.BindSubstVal bind.Var e + | Expr.Op(TOp.UnionCaseProof _, _, [ e ], _) when (not bind.Var.IsMutable) -> None, env.BindSubstVal bind.Var e | _ -> let v = bind.Var - let vR = ConvVal cenv v + let vR = ConvVal cenv v let rhsR = ConvExpr cenv env bind.Expr let envinner = env.BindVal v Some(vR, rhsR, bind.DebugPoint), envinner and ConvILCall (cenv: SymbolEnv) env (isNewObj, valUseFlags, ilMethRef, enclTypeArgs, methTypeArgs, callArgs, m) = let g = cenv.g - let isNewObj = (isNewObj || (match valUseFlags with CtorValUsedAsSuperInit | CtorValUsedAsSelfInit -> true | _ -> false)) + + let isNewObj = + (isNewObj + || (match valUseFlags with + | CtorValUsedAsSuperInit + | CtorValUsedAsSelfInit -> true + | _ -> false)) + let methName = ilMethRef.Name let isPropGet = methName.StartsWithOrdinal("get_") let isPropSet = methName.StartsWithOrdinal("set_") let isProp = isPropGet || isPropSet - - let tcref, subClass = + + let tcref, subClass = // this does not matter currently, type checking fails to resolve it when a TP references a union case subclass try - // if the type is an union case class, lookup will fail + // if the type is an union case class, lookup will fail Import.ImportILTypeRef cenv.amap m ilMethRef.DeclaringTypeRef, None with _ -> let e = ilMethRef.DeclaringTypeRef let parent = ILTypeRef.Create(e.Scope, e.Enclosing.Tail, e.Enclosing.Head) Import.ImportILTypeRef cenv.amap m parent, Some e.Name - + let enclosingTy = generalizedTyconRef g tcref - + let makeCall minfo = - ConvObjectModelCallLinear cenv env (isNewObj, minfo, enclTypeArgs, methTypeArgs, [], callArgs) id + ConvObjectModelCallLinear cenv env (isNewObj, minfo, enclTypeArgs, methTypeArgs, [], callArgs) id let makeFSCall isMember (vr: ValRef) = let memOrVal = @@ -1002,65 +1133,76 @@ module FSharpExprConvert = FSharpMemberOrFunctionOrValue(cenv, minfo) else FSharpMemberOrFunctionOrValue(cenv, vr) + makeCall memOrVal // takes a possibly fake ValRef and tries to resolve it to an F# expression let makeFSExpr isMember (vr: ValRef) = - let nlr = vr.nlr - let enclosingEntity = + let nlr = vr.nlr + + let enclosingEntity = try - nlr.EnclosingEntity.Deref + nlr.EnclosingEntity.Deref with _ -> failwithf "Failed to resolve type '%s'" nlr.EnclosingEntity.CompiledName + let ccu = nlr.EnclosingEntity.nlr.Ccu let vName = nlr.ItemKey.PartialKey.LogicalName // this is actually compiled name + let findByName = - enclosingEntity.MembersOfFSharpTyconSorted |> List.filter (fun v -> (v.CompiledName g.CompilerGlobalState) = vName) + enclosingEntity.MembersOfFSharpTyconSorted + |> List.filter (fun v -> (v.CompiledName g.CompilerGlobalState) = vName) + match findByName with - | [v] -> - makeFSCall isMember v + | [ v ] -> makeFSCall isMember v | [] -> let typR = ConvType cenv (mkWoNullAppTy tcref enclTypeArgs) + if enclosingEntity.IsModuleOrNamespace then - let findModuleMemberByName = - enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers - |> Seq.filter (fun v -> - (v.CompiledName g.CompilerGlobalState) = vName && - match v.TryDeclaringEntity with - | Parent p -> p.PublicPath = enclosingEntity.PublicPath - | _ -> false - ) |> List.ofSeq + let findModuleMemberByName = + enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers + |> Seq.filter (fun v -> + (v.CompiledName g.CompilerGlobalState) = vName + && match v.TryDeclaringEntity with + | Parent p -> p.PublicPath = enclosingEntity.PublicPath + | _ -> false) + |> List.ofSeq + match findModuleMemberByName with - | [v] -> + | [ v ] -> let vr = VRefLocal v makeFSCall isMember vr | [] -> let isPropGet = vName.StartsWithOrdinal("get_") let isPropSet = vName.StartsWithOrdinal("set_") + if isPropGet || isPropSet then - let name = PrettyNaming.ChopPropertyName vName + let name = PrettyNaming.ChopPropertyName vName + let findByName = - enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers + enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers |> Seq.filter (fun v -> (v.CompiledName g.CompilerGlobalState) = name) |> List.ofSeq + match findByName with | [ v ] -> let m = FSharpMemberOrFunctionOrValue(cenv, VRefLocal v) + if isPropGet then E.Value m - else + else let valR = ConvExpr cenv env callArgs.Head - E.ValueSet (m, valR) + E.ValueSet(m, valR) | _ -> failwith "Failed to resolve module value unambiguously" else - failwith "Failed to resolve module member" - | _ -> - failwith "Failed to resolve overloaded module member" + failwith "Failed to resolve module member" + | _ -> failwith "Failed to resolve overloaded module member" elif enclosingEntity.IsRecordTycon then if isProp then - let name = PrettyNaming.ChopPropertyName vName + let name = PrettyNaming.ChopPropertyName vName let projR = ConvRecdFieldRef cenv (RecdFieldRef(tcref, name)) let objR = ConvLValueExpr cenv env callArgs.Head + if isPropGet then E.FSharpFieldGet(Some objR, typR, projR) else @@ -1074,7 +1216,7 @@ module FSharpExprConvert = elif enclosingEntity.IsUnionTycon then if vName = "GetTag" || vName = "get_Tag" then let objR = ConvExpr cenv env callArgs.Head - E.UnionCaseTag(objR, typR) + E.UnionCaseTag(objR, typR) elif vName.StartsWithOrdinal("New") then let name = vName.Substring 3 let mkR = ConvUnionCaseRef cenv (UnionCaseRef(tcref, name)) @@ -1085,7 +1227,7 @@ module FSharpExprConvert = let mkR = ConvUnionCaseRef cenv (UnionCaseRef(tcref, name)) let objR = ConvExpr cenv env callArgs.Head E.UnionCaseTest(objR, typR, mkR) - else + else match subClass with | Some name -> let ucref = UnionCaseRef(tcref, name) @@ -1093,10 +1235,13 @@ module FSharpExprConvert = let objR = ConvLValueExpr cenv env callArgs.Head let projR = FSharpField(cenv, ucref, ucref.Index) E.UnionCaseGet(objR, typR, mkR, projR) - | _ -> - failwith "Failed to recognize union type member" + | _ -> failwith "Failed to recognize union type member" else - let names = enclosingEntity.MembersOfFSharpTyconSorted |> List.map (fun v -> v.CompiledName g.CompilerGlobalState) |> String.concat ", " + let names = + enclosingEntity.MembersOfFSharpTyconSorted + |> List.map (fun v -> v.CompiledName g.CompilerGlobalState) + |> String.concat ", " + failwithf "Member '%s' not found in type %s, found: %s" vName enclosingEntity.DisplayName names | _ -> // member is overloaded match nlr.ItemKey.TypeForLinkage with @@ -1104,20 +1249,21 @@ module FSharpExprConvert = | Some keyTy -> let findBySig = findByName |> List.tryFind (fun v -> ccu.MemberSignatureEquality(keyTy, v.Type)) + match findBySig with - | Some v -> - makeFSCall isMember v - | _ -> - failwith "Failed to recognize F# member" + | Some v -> makeFSCall isMember v + | _ -> failwith "Failed to recognize F# member" // First try to resolve it to IL metadata - let try1 = - if tcref.IsILTycon then - try - let mdef = resolveILMethodRefWithRescope unscopeILType tcref.ILTyconRawMetadata ilMethRef - let minfo = MethInfo.CreateILMeth(cenv.amap, m, enclosingTy, mdef) + let try1 = + if tcref.IsILTycon then + try + let mdef = + resolveILMethodRefWithRescope unscopeILType tcref.ILTyconRawMetadata ilMethRef + + let minfo = MethInfo.CreateILMeth(cenv.amap, m, enclosingTy, mdef) FSharpMemberOrFunctionOrValue(cenv, minfo) |> makeCall |> Some - with _ -> + with _ -> None else None @@ -1126,375 +1272,587 @@ module FSharpExprConvert = match try1 with | Some res -> res | None -> - try - // Try to bind the call to an F# method call - let memberParentName = if tcref.IsModuleOrNamespace then None else Some tcref.LogicalName - // this logical name is not correct in the presence of CompiledName - let logicalName = ilMethRef.Name - let isMember = memberParentName.IsSome - if isMember then - match ilMethRef.Name, ilMethRef.DeclaringTypeRef.Name with - | "Invoke", "Microsoft.FSharp.Core.FSharpFunc`2" -> - let objR = ConvLValueExpr cenv env callArgs.Head - let argR = ConvExpr cenv env callArgs.Tail.Head - let typR = ConvType cenv enclTypeArgs.Head - E.Application(objR, [typR], [argR]) - | _ -> - let isCtor = (ilMethRef.Name = ".ctor") - let isStatic = isCtor || ilMethRef.CallingConv.IsStatic - let scoref = ilMethRef.DeclaringTypeRef.Scope - let typars1 = tcref.Typars m - let typars2 = [ 1 .. ilMethRef.GenericArity ] |> List.map (fun _ -> Construct.NewRigidTypar "T" m) - let tinst1 = typars1 |> generalizeTypars - let tinst2 = typars2 |> generalizeTypars - // TODO: this will not work for curried methods in F# classes. - // This is difficult to solve as the information in the ILMethodRef - // is not sufficient to resolve to a symbol unambiguously in these cases. - - // If this was an ILTycon with potential nullness, try1 is Some(..) and this branch not hit - let argTys = [ ilMethRef.ArgTypes |> List.map (ImportILTypeFromMetadataSkipNullness cenv.amap m scoref tinst1 tinst2) ] - let retTy = - let nullableAttributes = Import.Nullness.NullableAttributesSource.Empty - match ImportReturnTypeFromMetadata cenv.amap m nullableAttributes ilMethRef.ReturnType scoref tinst1 tinst2 with - | None -> if isCtor then enclosingTy else g.unit_ty - | Some ty -> ty - - let linkageType = - let ty = mkIteratedFunTy g (List.map (mkRefTupledTy g) argTys) retTy - let ty = if isStatic then ty else mkFunTy g enclosingTy ty - mkForallTyIfNeeded (typars1 @ typars2) ty - - let argCount = (List.sumBy List.length argTys) + (if isStatic then 0 else 1) - let key = ValLinkageFullKey({ MemberParentMangledName=memberParentName; MemberIsOverride=false; LogicalName=logicalName; TotalArgCount= argCount }, Some linkageType) - - let (PubPath p) = tcref.PublicPath.Value - let enclosingNonLocalRef = mkNonLocalEntityRef tcref.nlr.Ccu p - let vref = mkNonLocalValRef enclosingNonLocalRef key - makeFSExpr isMember vref - - else - let key = ValLinkageFullKey({ MemberParentMangledName=memberParentName; MemberIsOverride=false; LogicalName=logicalName; TotalArgCount= 0 }, None) - let vref = mkNonLocalValRef tcref.nlr key - makeFSExpr isMember vref - - with e -> - failwithf "An IL call to '%s' could not be resolved: %s" (ilMethRef.ToString()) e.Message - - and ConvObjectModelCallLinear cenv env (isNewObj, v: FSharpMemberOrFunctionOrValue, enclTyArgs, methTyArgs, witnessArgsR: FSharpExpr list, callArgs) contF = + try + // Try to bind the call to an F# method call + let memberParentName = + if tcref.IsModuleOrNamespace then + None + else + Some tcref.LogicalName + // this logical name is not correct in the presence of CompiledName + let logicalName = ilMethRef.Name + let isMember = memberParentName.IsSome + + if isMember then + match ilMethRef.Name, ilMethRef.DeclaringTypeRef.Name with + | "Invoke", "Microsoft.FSharp.Core.FSharpFunc`2" -> + let objR = ConvLValueExpr cenv env callArgs.Head + let argR = ConvExpr cenv env callArgs.Tail.Head + let typR = ConvType cenv enclTypeArgs.Head + E.Application(objR, [ typR ], [ argR ]) + | _ -> + let isCtor = (ilMethRef.Name = ".ctor") + let isStatic = isCtor || ilMethRef.CallingConv.IsStatic + let scoref = ilMethRef.DeclaringTypeRef.Scope + let typars1 = tcref.Typars m + + let typars2 = + [ 1 .. ilMethRef.GenericArity ] + |> List.map (fun _ -> Construct.NewRigidTypar "T" m) + + let tinst1 = typars1 |> generalizeTypars + let tinst2 = typars2 |> generalizeTypars + // TODO: this will not work for curried methods in F# classes. + // This is difficult to solve as the information in the ILMethodRef + // is not sufficient to resolve to a symbol unambiguously in these cases. + + // If this was an ILTycon with potential nullness, try1 is Some(..) and this branch not hit + let argTys = + [ + ilMethRef.ArgTypes + |> List.map (ImportILTypeFromMetadataSkipNullness cenv.amap m scoref tinst1 tinst2) + ] + + let retTy = + let nullableAttributes = Import.Nullness.NullableAttributesSource.Empty + + match ImportReturnTypeFromMetadata cenv.amap m nullableAttributes ilMethRef.ReturnType scoref tinst1 tinst2 with + | None -> if isCtor then enclosingTy else g.unit_ty + | Some ty -> ty + + let linkageType = + let ty = mkIteratedFunTy g (List.map (mkRefTupledTy g) argTys) retTy + let ty = if isStatic then ty else mkFunTy g enclosingTy ty + mkForallTyIfNeeded (typars1 @ typars2) ty + + let argCount = (List.sumBy List.length argTys) + (if isStatic then 0 else 1) + + let key = + ValLinkageFullKey( + { + MemberParentMangledName = memberParentName + MemberIsOverride = false + LogicalName = logicalName + TotalArgCount = argCount + }, + Some linkageType + ) + + let (PubPath p) = tcref.PublicPath.Value + let enclosingNonLocalRef = mkNonLocalEntityRef tcref.nlr.Ccu p + let vref = mkNonLocalValRef enclosingNonLocalRef key + makeFSExpr isMember vref + + else + let key = + ValLinkageFullKey( + { + MemberParentMangledName = memberParentName + MemberIsOverride = false + LogicalName = logicalName + TotalArgCount = 0 + }, + None + ) + + let vref = mkNonLocalValRef tcref.nlr key + makeFSExpr isMember vref + + with e -> + failwithf "An IL call to '%s' could not be resolved: %s" (ilMethRef.ToString()) e.Message + + and ConvObjectModelCallLinear + cenv + env + (isNewObj, v: FSharpMemberOrFunctionOrValue, enclTyArgs, methTyArgs, witnessArgsR: FSharpExpr list, callArgs) + contF + = let enclTyArgsR = ConvTypes cenv enclTyArgs let methTyArgsR = ConvTypes cenv methTyArgs - let obj, callArgs = - if v.IsInstanceMember then - match callArgs with + + let obj, callArgs = + if v.IsInstanceMember then + match callArgs with | obj :: rest -> Some obj, rest | _ -> failwith (sprintf "unexpected shape of arguments: %A" callArgs) else None, callArgs + let objR = Option.map (ConvLValueExpr cenv env) obj // tailcall - ConvExprsLinear cenv env callArgs (contF << fun callArgsR -> - if isNewObj then - E.NewObject(v, enclTyArgsR, callArgsR) - else - E.Call(objR, v, enclTyArgsR, methTyArgsR, witnessArgsR, callArgsR)) - - and ConvExprs cenv env args = List.map (ConvExpr cenv env) args + ConvExprsLinear + cenv + env + callArgs + (contF + << fun callArgsR -> + if isNewObj then + E.NewObject(v, enclTyArgsR, callArgsR) + else + E.Call(objR, v, enclTyArgsR, methTyArgsR, witnessArgsR, callArgsR)) + + and ConvExprs cenv env args = List.map (ConvExpr cenv env) args // Process a list of expressions in a tail-recursive way. Identical to "ConvExprs" but the result is eventually passed to contF. - and ConvExprsLinear cenv env args contF = - match args with + and ConvExprsLinear cenv env args contF = + match args with | [] -> contF [] - | [arg] -> ConvExprLinear cenv env arg (fun argR -> contF [argR]) + | [ arg ] -> ConvExprLinear cenv env arg (fun argR -> contF [ argR ]) | arg :: rest -> ConvExprLinear cenv env arg (fun argR -> ConvExprsLinear cenv env rest (fun restR -> contF (argR :: restR))) - and ConvTargetsLinear cenv env tgs contF = - match tgs with + and ConvTargetsLinear cenv env tgs contF = + match tgs with | [] -> contF [] - | TTarget(vars, rhs, _) :: rest -> + | TTarget(vars, rhs, _) :: rest -> let varsR = (List.rev vars) |> List.map (ConvVal cenv) - ConvExprLinear cenv env rhs (fun targetR -> - ConvTargetsLinear cenv env rest (fun restR -> - contF ((varsR, targetR) :: restR))) + ConvExprLinear cenv env rhs (fun targetR -> ConvTargetsLinear cenv env rest (fun restR -> contF ((varsR, targetR) :: restR))) and ConvValRef cenv env m (vref: ValRef) = let g = cenv.g let v = vref.Deref - if env.isinstVals.ContainsVal v then + + if env.isinstVals.ContainsVal v then let ty, e = env.isinstVals[v] ConvExprPrim cenv env (mkCallUnbox g m ty e) - elif env.substVals.ContainsVal v then + elif env.substVals.ContainsVal v then let e = env.substVals[v] ConvExprPrim cenv env e - elif v.IsCtorThisVal then - E.ThisValue(ConvType cenv v.Type) - elif v.IsBaseVal then - E.BaseValue(ConvType cenv v.Type) - else - E.Value(FSharpMemberOrFunctionOrValue(cenv, vref)) + elif v.IsCtorThisVal then + E.ThisValue(ConvType cenv v.Type) + elif v.IsBaseVal then + E.BaseValue(ConvType cenv v.Type) + else + E.Value(FSharpMemberOrFunctionOrValue(cenv, vref)) - and ConvVal cenv (v: Val) : FSharpMemberOrFunctionOrValue = - let vref = mkLocalValRef v - FSharpMemberOrFunctionOrValue(cenv, vref) + and ConvVal cenv (v: Val) : FSharpMemberOrFunctionOrValue = + let vref = mkLocalValRef v + FSharpMemberOrFunctionOrValue(cenv, vref) and ConvConst cenv env m c ty = let g = cenv.g - match TryEliminateDesugaredConstants g m c with + + match TryEliminateDesugaredConstants g m c with | Some e -> ConvExprPrim cenv env e | None -> let tyR = ConvType cenv ty - match c with - | Const.Bool i -> E.Const(box i, tyR) - | Const.SByte i -> E.Const(box i, tyR) - | Const.Byte i -> E.Const(box i, tyR) - | Const.Int16 i -> E.Const(box i, tyR) - | Const.UInt16 i -> E.Const(box i, tyR) - | Const.Int32 i -> E.Const(box i, tyR) - | Const.UInt32 i -> E.Const(box i, tyR) - | Const.Int64 i -> E.Const(box i, tyR) - | Const.UInt64 i -> E.Const(box i, tyR) - | Const.IntPtr i -> E.Const(box (nativeint i), tyR) - | Const.UIntPtr i -> E.Const(box (unativeint i), tyR) - | Const.Decimal i -> E.Const(box i, tyR) - | Const.Double i -> E.Const(box i, tyR) - | Const.Single i -> E.Const(box i, tyR) - | Const.String i -> E.Const(box i, tyR) - | Const.Char i -> E.Const(box i, tyR) - | Const.Unit -> E.Const(box (), tyR) - | Const.Zero -> E.DefaultValue (ConvType cenv ty) - - and ConvDecisionTree cenv env dtreeRetTy x m = + + match c with + | Const.Bool i -> E.Const(box i, tyR) + | Const.SByte i -> E.Const(box i, tyR) + | Const.Byte i -> E.Const(box i, tyR) + | Const.Int16 i -> E.Const(box i, tyR) + | Const.UInt16 i -> E.Const(box i, tyR) + | Const.Int32 i -> E.Const(box i, tyR) + | Const.UInt32 i -> E.Const(box i, tyR) + | Const.Int64 i -> E.Const(box i, tyR) + | Const.UInt64 i -> E.Const(box i, tyR) + | Const.IntPtr i -> E.Const(box (nativeint i), tyR) + | Const.UIntPtr i -> E.Const(box (unativeint i), tyR) + | Const.Decimal i -> E.Const(box i, tyR) + | Const.Double i -> E.Const(box i, tyR) + | Const.Single i -> E.Const(box i, tyR) + | Const.String i -> E.Const(box i, tyR) + | Const.Char i -> E.Const(box i, tyR) + | Const.Unit -> E.Const(box (), tyR) + | Const.Zero -> E.DefaultValue(ConvType cenv ty) + + and ConvDecisionTree cenv env dtreeRetTy x m = ConvDecisionTreePrim cenv env dtreeRetTy x |> Mk cenv m dtreeRetTy - and ConvDecisionTreePrim cenv env dtreeRetTy x = - match x with - | TDSwitch(inpExpr, csl, dfltOpt, m) -> - let acc = - match dfltOpt with - | Some d -> ConvDecisionTreePrim cenv env dtreeRetTy d + and ConvDecisionTreePrim cenv env dtreeRetTy x = + match x with + | TDSwitch(inpExpr, csl, dfltOpt, m) -> + let acc = + match dfltOpt with + | Some d -> ConvDecisionTreePrim cenv env dtreeRetTy d | None -> E.DecisionTreeSuccess(0, []) - (csl, acc) ||> List.foldBack (ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy) + (csl, acc) + ||> List.foldBack (ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy) - | TDSuccess (args, n) -> + | TDSuccess(args, n) -> // TAST stores pattern bindings in reverse order for some reason // Reverse them here to give a good presentation to the user let args = List.rev args - let argsR = ConvExprs cenv env args + let argsR = ConvExprs cenv env args E.DecisionTreeSuccess(n, argsR) - - | TDBind(bind, rest) -> + + | TDBind(bind, rest) -> // The binding may be a compiler-generated binding that gets removed in the quotation presentation - match ConvLetBind cenv env bind with - | None, env -> ConvDecisionTreePrim cenv env dtreeRetTy rest - | Some bindR, env -> E.Let(bindR, ConvDecisionTree cenv env dtreeRetTy rest bind.Var.Range) + match ConvLetBind cenv env bind with + | None, env -> ConvDecisionTreePrim cenv env dtreeRetTy rest + | Some bindR, env -> E.Let(bindR, ConvDecisionTree cenv env dtreeRetTy rest bind.Var.Range) - and ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy dcase acc = + and ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy dcase acc = let g = cenv.g let (TCase(discrim, dtree)) = dcase let acc = acc |> Mk cenv m dtreeRetTy - match discrim with - | DecisionTreeTest.UnionCase (ucref, tyargs) -> + + match discrim with + | DecisionTreeTest.UnionCase(ucref, tyargs) -> let objR = ConvExpr cenv env inpExpr - let ucR = ConvUnionCaseRef cenv ucref + let ucR = ConvUnionCaseRef cenv ucref let utypR = ConvType cenv (mkWoNullAppTy ucref.TyconRef tyargs) - E.IfThenElse (E.UnionCaseTest (objR, utypR, ucR) |> Mk cenv m g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) - | DecisionTreeTest.Const (Const.Bool true) -> + E.IfThenElse(E.UnionCaseTest(objR, utypR, ucR) |> Mk cenv m g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.Const(Const.Bool true) -> let e1R = ConvExpr cenv env inpExpr - E.IfThenElse (e1R, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) - | DecisionTreeTest.Const (Const.Bool false) -> + E.IfThenElse(e1R, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.Const(Const.Bool false) -> let e1R = ConvExpr cenv env inpExpr // Note, reverse the branches - E.IfThenElse (e1R, acc, ConvDecisionTree cenv env dtreeRetTy dtree m) - | DecisionTreeTest.Const c -> + E.IfThenElse(e1R, acc, ConvDecisionTree cenv env dtreeRetTy dtree m) + | DecisionTreeTest.Const c -> let ty = tyOfExpr g inpExpr - let eq = mkCallEqualsOperator g m ty inpExpr (Expr.Const (c, m, ty)) - let eqR = ConvExpr cenv env eq - E.IfThenElse (eqR, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) - | DecisionTreeTest.IsNull -> + let eq = mkCallEqualsOperator g m ty inpExpr (Expr.Const(c, m, ty)) + let eqR = ConvExpr cenv env eq + E.IfThenElse(eqR, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.IsNull -> // Decompile cached isinst tests - match inpExpr with - | Expr.Val (vref, _, _) when env.isinstVals.ContainsVal vref.Deref -> - let ty, e = env.isinstVals[vref.Deref] + match inpExpr with + | Expr.Val(vref, _, _) when env.isinstVals.ContainsVal vref.Deref -> + let ty, e = env.isinstVals[vref.Deref] let tyR = ConvType cenv ty let eR = ConvExpr cenv env e // note: reverse the branches - a null test is a failure of an isinst test - E.IfThenElse (E.TypeTest (tyR, eR) |> Mk cenv m g.bool_ty, acc, ConvDecisionTree cenv env dtreeRetTy dtree m) - | _ -> + E.IfThenElse(E.TypeTest(tyR, eR) |> Mk cenv m g.bool_ty, acc, ConvDecisionTree cenv env dtreeRetTy dtree m) + | _ -> let ty = tyOfExpr g inpExpr + let eqR = - let eq = mkCallEqualsOperator g m ty inpExpr (Expr.Const (Const.Zero, m, ty)) + let eq = mkCallEqualsOperator g m ty inpExpr (Expr.Const(Const.Zero, m, ty)) let env = { env with suppressWitnesses = true } - ConvExpr cenv env eq - E.IfThenElse (eqR, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) - | DecisionTreeTest.IsInst (_srcTy, tgtTy) -> + ConvExpr cenv env eq + + E.IfThenElse(eqR, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.IsInst(_srcTy, tgtTy) -> let e1R = ConvExpr cenv env inpExpr - E.IfThenElse (E.TypeTest (ConvType cenv tgtTy, e1R) |> Mk cenv m g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) - | DecisionTreeTest.ActivePatternCase _ -> wfail("unexpected Test.ActivePatternCase test in quoted expression", m) - | DecisionTreeTest.ArrayLength _ -> wfail("FSharp.Compiler.Service cannot yet return array pattern matching", m) - | DecisionTreeTest.Error m -> wfail("error recovery", m) + E.IfThenElse(E.TypeTest(ConvType cenv tgtTy, e1R) |> Mk cenv m g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.ActivePatternCase _ -> wfail ("unexpected Test.ActivePatternCase test in quoted expression", m) + | DecisionTreeTest.ArrayLength _ -> wfail ("FSharp.Compiler.Service cannot yet return array pattern matching", m) + | DecisionTreeTest.Error m -> wfail ("error recovery", m) /// Wrap the conversion in a function to make it on-demand. Any pattern matching on the FSharpExpr will /// force the evaluation of the entire conversion process eagerly. - let ConvExprOnDemand cenv env expr = + let ConvExprOnDemand cenv env expr = FSharpExpr(cenv, Some(fun () -> ConvExpr cenv env expr), E.Unused, expr.Range, tyOfExpr cenv.g expr) /// The contents of the F# assembly as provided through the compiler API -type FSharpAssemblyContents(cenv: SymbolEnv, mimpls: CheckedImplFile list) = +type FSharpAssemblyContents(cenv: SymbolEnv, mimpls: CheckedImplFile list) = - new (tcGlobals, thisCcu, thisCcuType, tcImports, mimpls) = FSharpAssemblyContents(SymbolEnv(tcGlobals, thisCcu, thisCcuType, tcImports), mimpls) + new(tcGlobals, thisCcu, thisCcuType, tcImports, mimpls) = + FSharpAssemblyContents(SymbolEnv(tcGlobals, thisCcu, thisCcuType, tcImports), mimpls) - member _.ImplementationFiles = - [ for mimpl in mimpls -> FSharpImplementationFileContents(cenv, mimpl)] + member _.ImplementationFiles = + [ for mimpl in mimpls -> FSharpImplementationFileContents(cenv, mimpl) ] -and FSharpImplementationFileDeclaration = +and FSharpImplementationFileDeclaration = | Entity of entity: FSharpEntity * declarations: FSharpImplementationFileDeclaration list - | MemberOrFunctionOrValue of value: FSharpMemberOrFunctionOrValue * curriedArgs: FSharpMemberOrFunctionOrValue list list * body: FSharpExpr + | MemberOrFunctionOrValue of + value: FSharpMemberOrFunctionOrValue * + curriedArgs: FSharpMemberOrFunctionOrValue list list * + body: FSharpExpr | InitAction of action: FSharpExpr -and FSharpImplementationFileContents(cenv, mimpl) = +and FSharpImplementationFileContents(cenv, mimpl) = let g = cenv.g - let (CheckedImplFile (qname, _, contents, hasExplicitEntryPoint, isScript, _anonRecdTypes, _)) = mimpl - let rec getBind (bind: Binding) = + + let (CheckedImplFile(qname, _, contents, hasExplicitEntryPoint, isScript, _anonRecdTypes, _)) = + mimpl + + let rec getBind (bind: Binding) = let v = bind.Var assert v.IsCompiledAsTopLevel - let valReprInfo = InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v bind.Expr - let tps, _ctorThisValOpt, _baseValOpt, vsl, body, _bodyty = IteratedAdjustLambdaToMatchValReprInfo g cenv.amap valReprInfo bind.Expr + + let valReprInfo = + InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v bind.Expr + + let tps, _ctorThisValOpt, _baseValOpt, vsl, body, _bodyty = + IteratedAdjustLambdaToMatchValReprInfo g cenv.amap valReprInfo bind.Expr + let v = FSharpMemberOrFunctionOrValue(cenv, mkLocalValRef v) let gps = v.GenericParameters - let vslR = List.mapSquared (FSharpExprConvert.ConvVal cenv) vsl - let env = ExprTranslationEnv.Empty(g).BindTypars (Seq.zip tps gps |> Seq.toList) - let env = env.BindCurriedVals vsl + let vslR = List.mapSquared (FSharpExprConvert.ConvVal cenv) vsl + let env = ExprTranslationEnv.Empty(g).BindTypars(Seq.zip tps gps |> Seq.toList) + let env = env.BindCurriedVals vsl let e = FSharpExprConvert.ConvExprOnDemand cenv env body - FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v, vslR, e) + FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v, vslR, e) - and getDeclarations mdef = - match mdef with + and getDeclarations mdef = + match mdef with | TMDefRec(_isRec, _opens, tycons, mbinds, _m) -> - [ for tycon in tycons do - let entity = FSharpEntity(cenv, mkLocalEntityRef tycon) - yield FSharpImplementationFileDeclaration.Entity(entity, []) - for mbind in mbinds do - match mbind with - | ModuleOrNamespaceBinding.Module(mspec, def) -> - let entity = FSharpEntity(cenv, mkLocalEntityRef mspec) - yield FSharpImplementationFileDeclaration.Entity (entity, getDeclarations def) - | ModuleOrNamespaceBinding.Binding bind -> - yield getBind bind ] - | TMDefLet(bind, _m) -> - [ yield getBind bind ] - | TMDefOpens _ -> - [ ] - | TMDefDo(expr, _m) -> - [ let expr = FSharpExprConvert.ConvExprOnDemand cenv (ExprTranslationEnv.Empty(g)) expr - yield FSharpImplementationFileDeclaration.InitAction expr ] - | TMDefs mdefs -> - [ for mdef in mdefs do yield! getDeclarations mdef ] + [ + for tycon in tycons do + let entity = FSharpEntity(cenv, mkLocalEntityRef tycon) + yield FSharpImplementationFileDeclaration.Entity(entity, []) + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Module(mspec, def) -> + let entity = FSharpEntity(cenv, mkLocalEntityRef mspec) + yield FSharpImplementationFileDeclaration.Entity(entity, getDeclarations def) + | ModuleOrNamespaceBinding.Binding bind -> yield getBind bind + ] + | TMDefLet(bind, _m) -> [ yield getBind bind ] + | TMDefOpens _ -> [] + | TMDefDo(expr, _m) -> + [ + let expr = + FSharpExprConvert.ConvExprOnDemand cenv (ExprTranslationEnv.Empty(g)) expr + + yield FSharpImplementationFileDeclaration.InitAction expr + ] + | TMDefs mdefs -> + [ + for mdef in mdefs do + yield! getDeclarations mdef + ] member _.QualifiedName = qname.Text member _.FileName = qname.Range.FileName - member _.Declarations = getDeclarations contents + member _.Declarations = getDeclarations contents member _.HasExplicitEntryPoint = hasExplicitEntryPoint member _.IsScript = isScript +module FSharpExprPatterns = + let (|Value|_|) (e: FSharpExpr) = + match e.E with + | E.Value v -> Some v + | _ -> None -module FSharpExprPatterns = - let (|Value|_|) (e: FSharpExpr) = match e.E with E.Value v -> Some v | _ -> None - - let (|Const|_|) (e: FSharpExpr) = match e.E with E.Const (v, ty) -> Some (v, ty) | _ -> None - - let (|TypeLambda|_|) (e: FSharpExpr) = match e.E with E.TypeLambda (v, e) -> Some (v, e) | _ -> None + let (|Const|_|) (e: FSharpExpr) = + match e.E with + | E.Const(v, ty) -> Some(v, ty) + | _ -> None - let (|Lambda|_|) (e: FSharpExpr) = match e.E with E.Lambda (v, e) -> Some (v, e) | _ -> None + let (|TypeLambda|_|) (e: FSharpExpr) = + match e.E with + | E.TypeLambda(v, e) -> Some(v, e) + | _ -> None - let (|Application|_|) (e: FSharpExpr) = match e.E with E.Application (f, tys, e) -> Some (f, tys, e) | _ -> None + let (|Lambda|_|) (e: FSharpExpr) = + match e.E with + | E.Lambda(v, e) -> Some(v, e) + | _ -> None - let (|IfThenElse|_|) (e: FSharpExpr) = match e.E with E.IfThenElse (e1, e2, e3) -> Some (e1, e2, e3) | _ -> None + let (|Application|_|) (e: FSharpExpr) = + match e.E with + | E.Application(f, tys, e) -> Some(f, tys, e) + | _ -> None - let (|Let|_|) (e: FSharpExpr) = match e.E with E.Let ((dp, v, e), b) -> Some ((dp, v, e), b) | _ -> None + let (|IfThenElse|_|) (e: FSharpExpr) = + match e.E with + | E.IfThenElse(e1, e2, e3) -> Some(e1, e2, e3) + | _ -> None - let (|LetRec|_|) (e: FSharpExpr) = match e.E with E.LetRec (ves, b) -> Some (ves, b) | _ -> None + let (|Let|_|) (e: FSharpExpr) = + match e.E with + | E.Let((dp, v, e), b) -> Some((dp, v, e), b) + | _ -> None - let (|NewRecord|_|) (e: FSharpExpr) = match e.E with E.NewRecord (ty, es) -> Some (ty, es) | _ -> None + let (|LetRec|_|) (e: FSharpExpr) = + match e.E with + | E.LetRec(ves, b) -> Some(ves, b) + | _ -> None - let (|NewAnonRecord|_|) (e: FSharpExpr) = match e.E with E.NewAnonRecord (ty, es) -> Some (ty, es) | _ -> None + let (|NewRecord|_|) (e: FSharpExpr) = + match e.E with + | E.NewRecord(ty, es) -> Some(ty, es) + | _ -> None - let (|NewUnionCase|_|) (e: FSharpExpr) = match e.E with E.NewUnionCase (e, tys, es) -> Some (e, tys, es) | _ -> None + let (|NewAnonRecord|_|) (e: FSharpExpr) = + match e.E with + | E.NewAnonRecord(ty, es) -> Some(ty, es) + | _ -> None - let (|NewTuple|_|) (e: FSharpExpr) = match e.E with E.NewTuple (ty, es) -> Some (ty, es) | _ -> None + let (|NewUnionCase|_|) (e: FSharpExpr) = + match e.E with + | E.NewUnionCase(e, tys, es) -> Some(e, tys, es) + | _ -> None - let (|TupleGet|_|) (e: FSharpExpr) = match e.E with E.TupleGet (ty, n, es) -> Some (ty, n, es) | _ -> None + let (|NewTuple|_|) (e: FSharpExpr) = + match e.E with + | E.NewTuple(ty, es) -> Some(ty, es) + | _ -> None - let (|Call|_|) (e: FSharpExpr) = match e.E with E.Call (a, b, c, d, _e, f) -> Some (a, b, c, d, f) | _ -> None + let (|TupleGet|_|) (e: FSharpExpr) = + match e.E with + | E.TupleGet(ty, n, es) -> Some(ty, n, es) + | _ -> None - let (|CallWithWitnesses|_|) (e: FSharpExpr) = match e.E with E.Call (a, b, c, d, e, f) -> Some (a, b, c, d, e, f) | _ -> None + let (|Call|_|) (e: FSharpExpr) = + match e.E with + | E.Call(a, b, c, d, _e, f) -> Some(a, b, c, d, f) + | _ -> None - let (|NewObject|_|) (e: FSharpExpr) = match e.E with E.NewObject (a, b, c) -> Some (a, b, c) | _ -> None + let (|CallWithWitnesses|_|) (e: FSharpExpr) = + match e.E with + | E.Call(a, b, c, d, e, f) -> Some(a, b, c, d, e, f) + | _ -> None - let (|FSharpFieldGet|_|) (e: FSharpExpr) = match e.E with E.FSharpFieldGet (a, b, c) -> Some (a, b, c) | _ -> None + let (|NewObject|_|) (e: FSharpExpr) = + match e.E with + | E.NewObject(a, b, c) -> Some(a, b, c) + | _ -> None - let (|AnonRecordGet|_|) (e: FSharpExpr) = match e.E with E.AnonRecordGet (a, b, c) -> Some (a, b, c) | _ -> None + let (|FSharpFieldGet|_|) (e: FSharpExpr) = + match e.E with + | E.FSharpFieldGet(a, b, c) -> Some(a, b, c) + | _ -> None - let (|FSharpFieldSet|_|) (e: FSharpExpr) = match e.E with E.FSharpFieldSet (a, b, c, d) -> Some (a, b, c, d) | _ -> None + let (|AnonRecordGet|_|) (e: FSharpExpr) = + match e.E with + | E.AnonRecordGet(a, b, c) -> Some(a, b, c) + | _ -> None - let (|UnionCaseGet|_|) (e: FSharpExpr) = match e.E with E.UnionCaseGet (a, b, c, d) -> Some (a, b, c, d) | _ -> None + let (|FSharpFieldSet|_|) (e: FSharpExpr) = + match e.E with + | E.FSharpFieldSet(a, b, c, d) -> Some(a, b, c, d) + | _ -> None - let (|UnionCaseTag|_|) (e: FSharpExpr) = match e.E with E.UnionCaseTag (a, b) -> Some (a, b) | _ -> None + let (|UnionCaseGet|_|) (e: FSharpExpr) = + match e.E with + | E.UnionCaseGet(a, b, c, d) -> Some(a, b, c, d) + | _ -> None - let (|UnionCaseTest|_|) (e: FSharpExpr) = match e.E with E.UnionCaseTest (a, b, c) -> Some (a, b, c) | _ -> None + let (|UnionCaseTag|_|) (e: FSharpExpr) = + match e.E with + | E.UnionCaseTag(a, b) -> Some(a, b) + | _ -> None - let (|NewArray|_|) (e: FSharpExpr) = match e.E with E.NewArray (a, b) -> Some (a, b) | _ -> None + let (|UnionCaseTest|_|) (e: FSharpExpr) = + match e.E with + | E.UnionCaseTest(a, b, c) -> Some(a, b, c) + | _ -> None - let (|Coerce|_|) (e: FSharpExpr) = match e.E with E.Coerce (a, b) -> Some (a, b) | _ -> None + let (|NewArray|_|) (e: FSharpExpr) = + match e.E with + | E.NewArray(a, b) -> Some(a, b) + | _ -> None - let (|Quote|_|) (e: FSharpExpr) = match e.E with E.Quote a -> Some a | _ -> None + let (|Coerce|_|) (e: FSharpExpr) = + match e.E with + | E.Coerce(a, b) -> Some(a, b) + | _ -> None - let (|TypeTest|_|) (e: FSharpExpr) = match e.E with E.TypeTest (a, b) -> Some (a, b) | _ -> None + let (|Quote|_|) (e: FSharpExpr) = + match e.E with + | E.Quote a -> Some a + | _ -> None - let (|Sequential|_|) (e: FSharpExpr) = match e.E with E.Sequential (dp, a) -> Some (dp, a) | _ -> None + let (|TypeTest|_|) (e: FSharpExpr) = + match e.E with + | E.TypeTest(a, b) -> Some(a, b) + | _ -> None - let (|DebugPoint|_|) (e: FSharpExpr) = match e.E with E.DebugPoint (dp, a) -> Some (dp, a) | _ -> None + let (|Sequential|_|) (e: FSharpExpr) = + match e.E with + | E.Sequential(dp, a) -> Some(dp, a) + | _ -> None - let (|FastIntegerForLoop|_|) (e: FSharpExpr) = match e.E with E.IntegerForLoop (dpFor, dpEquals, a, b, c, d) -> Some (dpFor, dpEquals, a, b, c, d) | _ -> None + let (|DebugPoint|_|) (e: FSharpExpr) = + match e.E with + | E.DebugPoint(dp, a) -> Some(dp, a) + | _ -> None - let (|WhileLoop|_|) (e: FSharpExpr) = match e.E with E.WhileLoop (dpWhile, a, b) -> Some (dpWhile, a, b) | _ -> None + let (|FastIntegerForLoop|_|) (e: FSharpExpr) = + match e.E with + | E.IntegerForLoop(dpFor, dpEquals, a, b, c, d) -> Some(dpFor, dpEquals, a, b, c, d) + | _ -> None - let (|TryFinally|_|) (e: FSharpExpr) = match e.E with E.TryFinally (dpTry, dpFinally, a, b) -> Some (dpTry, dpFinally, a, b) | _ -> None + let (|WhileLoop|_|) (e: FSharpExpr) = + match e.E with + | E.WhileLoop(dpWhile, a, b) -> Some(dpWhile, a, b) + | _ -> None - let (|TryWith|_|) (e: FSharpExpr) = match e.E with E.TryWith (dpTry, dpWith, a, b, c, d, e) -> Some (dpTry, dpWith, a, b, c, d, e) | _ -> None + let (|TryFinally|_|) (e: FSharpExpr) = + match e.E with + | E.TryFinally(dpTry, dpFinally, a, b) -> Some(dpTry, dpFinally, a, b) + | _ -> None - let (|NewDelegate|_|) (e: FSharpExpr) = match e.E with E.NewDelegate (ty, e) -> Some (ty, e) | _ -> None + let (|TryWith|_|) (e: FSharpExpr) = + match e.E with + | E.TryWith(dpTry, dpWith, a, b, c, d, e) -> Some(dpTry, dpWith, a, b, c, d, e) + | _ -> None - let (|DefaultValue|_|) (e: FSharpExpr) = match e.E with E.DefaultValue ty -> Some ty | _ -> None + let (|NewDelegate|_|) (e: FSharpExpr) = + match e.E with + | E.NewDelegate(ty, e) -> Some(ty, e) + | _ -> None - let (|AddressSet|_|) (e: FSharpExpr) = match e.E with E.AddressSet (a, b) -> Some (a, b) | _ -> None + let (|DefaultValue|_|) (e: FSharpExpr) = + match e.E with + | E.DefaultValue ty -> Some ty + | _ -> None - let (|ValueSet|_|) (e: FSharpExpr) = match e.E with E.ValueSet (a, b) -> Some (a, b) | _ -> None + let (|AddressSet|_|) (e: FSharpExpr) = + match e.E with + | E.AddressSet(a, b) -> Some(a, b) + | _ -> None - let (|AddressOf|_|) (e: FSharpExpr) = match e.E with E.AddressOf a -> Some a | _ -> None + let (|ValueSet|_|) (e: FSharpExpr) = + match e.E with + | E.ValueSet(a, b) -> Some(a, b) + | _ -> None - let (|ThisValue|_|) (e: FSharpExpr) = match e.E with E.ThisValue a -> Some a | _ -> None + let (|AddressOf|_|) (e: FSharpExpr) = + match e.E with + | E.AddressOf a -> Some a + | _ -> None - let (|BaseValue|_|) (e: FSharpExpr) = match e.E with E.BaseValue a -> Some a | _ -> None + let (|ThisValue|_|) (e: FSharpExpr) = + match e.E with + | E.ThisValue a -> Some a + | _ -> None - let (|ILAsm|_|) (e: FSharpExpr) = match e.E with E.ILAsm (a, b, c) -> Some (a, b, c) | _ -> None + let (|BaseValue|_|) (e: FSharpExpr) = + match e.E with + | E.BaseValue a -> Some a + | _ -> None - let (|ILFieldGet|_|) (e: FSharpExpr) = match e.E with E.ILFieldGet (a, b, c) -> Some (a, b, c) | _ -> None + let (|ILAsm|_|) (e: FSharpExpr) = + match e.E with + | E.ILAsm(a, b, c) -> Some(a, b, c) + | _ -> None - let (|ILFieldSet|_|) (e: FSharpExpr) = match e.E with E.ILFieldSet (a, b, c, d) -> Some (a, b, c, d) | _ -> None + let (|ILFieldGet|_|) (e: FSharpExpr) = + match e.E with + | E.ILFieldGet(a, b, c) -> Some(a, b, c) + | _ -> None - let (|ObjectExpr|_|) (e: FSharpExpr) = match e.E with E.ObjectExpr (a, b, c, d) -> Some (a, b, c, d) | _ -> None + let (|ILFieldSet|_|) (e: FSharpExpr) = + match e.E with + | E.ILFieldSet(a, b, c, d) -> Some(a, b, c, d) + | _ -> None - let (|DecisionTree|_|) (e: FSharpExpr) = match e.E with E.DecisionTree (a, b) -> Some (a, b) | _ -> None + let (|ObjectExpr|_|) (e: FSharpExpr) = + match e.E with + | E.ObjectExpr(a, b, c, d) -> Some(a, b, c, d) + | _ -> None - let (|DecisionTreeSuccess|_|) (e: FSharpExpr) = match e.E with E.DecisionTreeSuccess (a, b) -> Some (a, b) | _ -> None + let (|DecisionTree|_|) (e: FSharpExpr) = + match e.E with + | E.DecisionTree(a, b) -> Some(a, b) + | _ -> None - let (|UnionCaseSet|_|) (e: FSharpExpr) = match e.E with E.UnionCaseSet (a, b, c, d, e) -> Some (a, b, c, d, e) | _ -> None + let (|DecisionTreeSuccess|_|) (e: FSharpExpr) = + match e.E with + | E.DecisionTreeSuccess(a, b) -> Some(a, b) + | _ -> None - let (|TraitCall|_|) (e: FSharpExpr) = match e.E with E.TraitCall (a, b, c, d, e, f) -> Some (a, b, c, d, e, f) | _ -> None + let (|UnionCaseSet|_|) (e: FSharpExpr) = + match e.E with + | E.UnionCaseSet(a, b, c, d, e) -> Some(a, b, c, d, e) + | _ -> None - let (|WitnessArg|_|) (e: FSharpExpr) = match e.E with E.WitnessArg n -> Some n | _ -> None + let (|TraitCall|_|) (e: FSharpExpr) = + match e.E with + | E.TraitCall(a, b, c, d, e, f) -> Some(a, b, c, d, e, f) + | _ -> None + let (|WitnessArg|_|) (e: FSharpExpr) = + match e.E with + | E.WitnessArg n -> Some n + | _ -> None diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fs b/src/Compiler/Symbols/FSharpDiagnostic.fs index 4dcc6305630..fdcb12bd043 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fs +++ b/src/Compiler/Symbols/FSharpDiagnostic.fs @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. //---------------------------------------------------------------------------- -// Open up the compiler as an incremental service for parsing, +// Open up the compiler as an incremental service for parsing, // type checking and intellisense-like environment-reporting. //-------------------------------------------------------------------------- @@ -46,7 +46,7 @@ module ExtendedData = | FollowingPatternMatchClause | PatternMatchGuard | SequenceExpression - with + static member From(contextInfo: ContextInfo) = match contextInfo with | ContextInfo.NoContext -> NoContext @@ -69,8 +69,7 @@ module ExtendedData = /// Additional data for diagnostics about obsolete attributes. [] - type ObsoleteDiagnosticExtendedData - internal (diagnosticId: string option, urlFormat: string option) = + type ObsoleteDiagnosticExtendedData internal (diagnosticId: string option, urlFormat: string option) = interface IFSharpDiagnosticExtendedData /// Represents the DiagnosticId of the diagnostic member this.DiagnosticId: string option = diagnosticId @@ -80,15 +79,14 @@ module ExtendedData = /// Additional data for diagnostics about experimental attributes. [] - type ExperimentalExtendedData - internal (diagnosticId: string option, urlFormat: string option) = + type ExperimentalExtendedData internal (diagnosticId: string option, urlFormat: string option) = interface IFSharpDiagnosticExtendedData /// Represents the DiagnosticId of the diagnostic member this.DiagnosticId: string option = diagnosticId /// Represents the URL format of the diagnostic member this.UrlFormat: string option = urlFormat - + [] type TypeMismatchDiagnosticExtendedData internal (symbolEnv: SymbolEnv, dispEnv: DisplayEnv, expectedType: TType, actualType: TType, context: DiagnosticContextInfo) = @@ -100,8 +98,7 @@ module ExtendedData = member x.DisplayContext = FSharpDisplayContext(fun _ -> dispEnv) [] - type ExpressionIsAFunctionExtendedData - internal (symbolEnv: SymbolEnv, actualType: TType) = + type ExpressionIsAFunctionExtendedData internal (symbolEnv: SymbolEnv, actualType: TType) = interface IFSharpDiagnosticExtendedData member x.ActualType = FSharpType(symbolEnv, actualType) @@ -110,35 +107,49 @@ module ExtendedData = type FieldNotContainedDiagnosticExtendedData internal (symbolEnv: SymbolEnv, implTycon: Tycon, sigTycon: Tycon, signatureField: RecdField, implementationField: RecdField) = interface IFSharpDiagnosticExtendedData - member x.SignatureField = FSharpField(symbolEnv, RecdFieldRef.RecdFieldRef(mkLocalTyconRef sigTycon, signatureField.Id.idText)) - member x.ImplementationField = FSharpField(symbolEnv, RecdFieldRef.RecdFieldRef(mkLocalTyconRef implTycon, implementationField.Id.idText)) + + member x.SignatureField = + FSharpField(symbolEnv, RecdFieldRef.RecdFieldRef(mkLocalTyconRef sigTycon, signatureField.Id.idText)) + + member x.ImplementationField = + FSharpField(symbolEnv, RecdFieldRef.RecdFieldRef(mkLocalTyconRef implTycon, implementationField.Id.idText)) [] - type ValueNotContainedDiagnosticExtendedData - internal (symbolEnv: SymbolEnv, signatureValue: Val, implValue: Val) = + type ValueNotContainedDiagnosticExtendedData internal (symbolEnv: SymbolEnv, signatureValue: Val, implValue: Val) = interface IFSharpDiagnosticExtendedData - member x.SignatureValue = FSharpMemberOrFunctionOrValue(symbolEnv, mkLocalValRef signatureValue) - member x.ImplementationValue = FSharpMemberOrFunctionOrValue(symbolEnv, mkLocalValRef implValue) + + member x.SignatureValue = + FSharpMemberOrFunctionOrValue(symbolEnv, mkLocalValRef signatureValue) + + member x.ImplementationValue = + FSharpMemberOrFunctionOrValue(symbolEnv, mkLocalValRef implValue) [] - type ArgumentsInSigAndImplMismatchExtendedData - internal(sigArg: Ident, implArg: Ident) = + type ArgumentsInSigAndImplMismatchExtendedData internal (sigArg: Ident, implArg: Ident) = interface IFSharpDiagnosticExtendedData member x.SignatureName = sigArg.idText member x.ImplementationName = implArg.idText member x.SignatureRange = sigArg.idRange member x.ImplementationRange = implArg.idRange - + [] - type DefinitionsInSigAndImplNotCompatibleAbbreviationsDifferExtendedData - internal(signatureType: Tycon, implementationType: Tycon) = + type DefinitionsInSigAndImplNotCompatibleAbbreviationsDifferExtendedData internal (signatureType: Tycon, implementationType: Tycon) = interface IFSharpDiagnosticExtendedData member x.SignatureRange: range = signatureType.Range member x.ImplementationRange: range = implementationType.Range open ExtendedData -type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, message: string, subcategory: string, errorNum: int, numberPrefix: string, extendedData: IFSharpDiagnosticExtendedData option) = +type FSharpDiagnostic + ( + m: range, + severity: FSharpDiagnosticSeverity, + message: string, + subcategory: string, + errorNum: int, + numberPrefix: string, + extendedData: IFSharpDiagnosticExtendedData option + ) = member _.Range = m member _.Severity = severity @@ -160,7 +171,7 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, message: str member _.StartLine = m.Start.Line member _.EndLine = m.End.Line - + member _.StartColumn = m.Start.Column member _.EndColumn = m.End.Column @@ -182,136 +193,165 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, message: str let fileName = m.FileName let s = m.Start let e = m.End - let severity = + + let severity = match severity with | FSharpDiagnosticSeverity.Warning -> "warning" | FSharpDiagnosticSeverity.Error -> "error" | FSharpDiagnosticSeverity.Info -> "info" | FSharpDiagnosticSeverity.Hidden -> "hidden" + sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName s.Line (s.Column + 1) e.Line (e.Column + 1) subcategory severity message /// Decompose a warning or error into parts: position, severity, message, error number - static member CreateFromException(diagnostic: PhasedDiagnostic, severity, suggestNames: bool, flatErrors: bool, symbolEnv: SymbolEnv option) = + static member CreateFromException + (diagnostic: PhasedDiagnostic, severity, suggestNames: bool, flatErrors: bool, symbolEnv: SymbolEnv option) + = let extendedData: IFSharpDiagnosticExtendedData option = match symbolEnv with | None -> None | Some symbolEnv -> - match diagnostic.Exception with - | ErrorFromAddingTypeEquation(_, displayEnv, expectedType, actualType, ConstraintSolverTupleDiffLengths(contextInfo = contextInfo), _) - | ErrorFromAddingTypeEquation(_, displayEnv, expectedType, actualType, ConstraintSolverTypesNotInEqualityRelation(_, _, _, _, _, contextInfo), _) - | ErrorsFromAddingSubsumptionConstraint(_, displayEnv, expectedType, actualType, _, contextInfo, _) -> - let context = DiagnosticContextInfo.From(contextInfo) - Some(TypeMismatchDiagnosticExtendedData(symbolEnv, displayEnv, expectedType, actualType, context)) + match diagnostic.Exception with + | ErrorFromAddingTypeEquation(_, + displayEnv, + expectedType, + actualType, + ConstraintSolverTupleDiffLengths(contextInfo = contextInfo), + _) + | ErrorFromAddingTypeEquation(_, + displayEnv, + expectedType, + actualType, + ConstraintSolverTypesNotInEqualityRelation(_, _, _, _, _, contextInfo), + _) + | ErrorsFromAddingSubsumptionConstraint(_, displayEnv, expectedType, actualType, _, contextInfo, _) -> + let context = DiagnosticContextInfo.From(contextInfo) + Some(TypeMismatchDiagnosticExtendedData(symbolEnv, displayEnv, expectedType, actualType, context)) - | ErrorFromAddingTypeEquation(_, displayEnv, expectedType, actualType, _, _)-> - Some(TypeMismatchDiagnosticExtendedData(symbolEnv, displayEnv, expectedType, actualType, DiagnosticContextInfo.NoContext)) + | ErrorFromAddingTypeEquation(_, displayEnv, expectedType, actualType, _, _) -> + Some( + TypeMismatchDiagnosticExtendedData(symbolEnv, displayEnv, expectedType, actualType, DiagnosticContextInfo.NoContext) + ) - | FunctionValueUnexpected(_, actualType, _) -> - Some(ExpressionIsAFunctionExtendedData(symbolEnv, actualType)) + | FunctionValueUnexpected(_, actualType, _) -> Some(ExpressionIsAFunctionExtendedData(symbolEnv, actualType)) - | FieldNotContained(_,_, _, implEntity, sigEntity, impl, sign, _) -> - Some(FieldNotContainedDiagnosticExtendedData(symbolEnv, implEntity, sigEntity, sign, impl)) + | FieldNotContained(_, _, _, implEntity, sigEntity, impl, sign, _) -> + Some(FieldNotContainedDiagnosticExtendedData(symbolEnv, implEntity, sigEntity, sign, impl)) - | ValueNotContained(_,_, _, _, implValue, sigValue, _) -> - Some(ValueNotContainedDiagnosticExtendedData(symbolEnv, sigValue, implValue)) + | ValueNotContained(_, _, _, _, implValue, sigValue, _) -> + Some(ValueNotContainedDiagnosticExtendedData(symbolEnv, sigValue, implValue)) - | ArgumentsInSigAndImplMismatch(sigArg, implArg) -> - Some(ArgumentsInSigAndImplMismatchExtendedData(sigArg, implArg)) + | ArgumentsInSigAndImplMismatch(sigArg, implArg) -> Some(ArgumentsInSigAndImplMismatchExtendedData(sigArg, implArg)) - | DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(implTycon = implTycon; sigTycon = sigTycon) -> - Some(DefinitionsInSigAndImplNotCompatibleAbbreviationsDifferExtendedData(sigTycon, implTycon)) + | DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(implTycon = implTycon; sigTycon = sigTycon) -> + Some(DefinitionsInSigAndImplNotCompatibleAbbreviationsDifferExtendedData(sigTycon, implTycon)) - | ObsoleteDiagnostic(diagnosticId= diagnosticId; urlFormat= urlFormat) -> - Some(ObsoleteDiagnosticExtendedData(diagnosticId, urlFormat)) - - | Experimental(diagnosticId= diagnosticId; urlFormat= urlFormat) -> - Some(ExperimentalExtendedData(diagnosticId, urlFormat)) - | _ -> None + | ObsoleteDiagnostic(diagnosticId = diagnosticId; urlFormat = urlFormat) -> + Some(ObsoleteDiagnosticExtendedData(diagnosticId, urlFormat)) + + | Experimental(diagnosticId = diagnosticId; urlFormat = urlFormat) -> + Some(ExperimentalExtendedData(diagnosticId, urlFormat)) + | _ -> None let msg = - match diagnostic.Exception.Data["CachedFormatCore"] with - | :? string as message -> message - | _ -> diagnostic.FormatCore(flatErrors, suggestNames) + match diagnostic.Exception.Data["CachedFormatCore"] with + | :? string as message -> message + | _ -> diagnostic.FormatCore(flatErrors, suggestNames) let errorNum = diagnostic.Number - let m = match diagnostic.Range with Some m -> m | None -> range0 + + let m = + match diagnostic.Range with + | Some m -> m + | None -> range0 + FSharpDiagnostic(m, severity, msg, diagnostic.Subcategory(), errorNum, "FS", extendedData) static member NewlineifyErrorString(message) = NewlineifyErrorString(message) static member NormalizeErrorString(text) = NormalizeErrorString(text) - + static member Create(severity, message, number, range, ?numberPrefix, ?subcategory) = let subcategory = defaultArg subcategory BuildPhaseSubcategory.TypeCheck let numberPrefix = defaultArg numberPrefix "FS" FSharpDiagnostic(range, severity, message, subcategory, number, numberPrefix, None) -/// Use to reset error and warning handlers +/// Use to reset error and warning handlers [] -type DiagnosticsScope(flatErrors: bool) = - let mutable diags = [] +type DiagnosticsScope(flatErrors: bool) = + let mutable diags = [] let unwindBP = UseBuildPhase BuildPhase.TypeCheck - let unwindEL = - UseDiagnosticsLogger - { new DiagnosticsLogger("DiagnosticsScope") with - member _.DiagnosticSink(diagnostic, severity) = - let diagnostic = FSharpDiagnostic.CreateFromException(diagnostic, severity, false, flatErrors, None) + let unwindEL = + UseDiagnosticsLogger + { new DiagnosticsLogger("DiagnosticsScope") with + + member _.DiagnosticSink(diagnostic, severity) = + let diagnostic = + FSharpDiagnostic.CreateFromException(diagnostic, severity, false, flatErrors, None) + diags <- diagnostic :: diags - member _.ErrorCount = diags.Length } - - member _.Errors = diags |> List.filter (fun error -> error.Severity = FSharpDiagnosticSeverity.Error) + member _.ErrorCount = diags.Length + } + + member _.Errors = + diags + |> List.filter (fun error -> error.Severity = FSharpDiagnosticSeverity.Error) member _.Diagnostics = diags member x.TryGetFirstErrorText() = - match x.Errors with + match x.Errors with | error :: _ -> Some error.Message | [] -> None - + interface IDisposable with - member _.Dispose() = + member _.Dispose() = unwindEL.Dispose() unwindBP.Dispose() /// Used at entry points to FSharp.Compiler.Service (service.fsi) which manipulate symbols and - /// perform other operations which might expose us to either bona-fide F# error messages such - /// "missing assembly" (for incomplete assembly reference sets), or, if there is a compiler bug, + /// perform other operations which might expose us to either bona-fide F# error messages such + /// "missing assembly" (for incomplete assembly reference sets), or, if there is a compiler bug, /// may hit internal compiler failures. /// /// In some calling cases, we get a chance to report the error as part of user text. For example /// if there is a "missing assembly" error while formatting the text of the description of an /// autocomplete, then the error message is shown in replacement of the text (rather than crashing Visual /// Studio, or swallowing the exception completely) - static member Protect<'a> (m: range) (f: unit->'a) (err: string->'a): 'a = + static member Protect<'a> (m: range) (f: unit -> 'a) (err: string -> 'a) : 'a = use diagnosticsScope = new DiagnosticsScope(false) - let res = - try - Some (f()) - with e -> + + let res = + try + Some(f ()) + with e -> // Here we only call errorRecovery to save the error message for later use by TryGetFirstErrorText. - try + try errorRecovery e m - with RecoverableException _ -> + with RecoverableException _ -> () + None - match res with + + match res with | Some res -> res - | None -> - match diagnosticsScope.TryGetFirstErrorText() with + | None -> + match diagnosticsScope.TryGetFirstErrorText() with | Some text -> err text | None -> err "" /// A diagnostics logger that capture diagnostics, filtering them according to warning levels etc. -type internal CompilationDiagnosticLogger (debugName: string, options: FSharpDiagnosticOptions, ?preprocess: (PhasedDiagnostic -> PhasedDiagnostic)) = - inherit DiagnosticsLogger("CompilationDiagnosticLogger("+debugName+")") - +type internal CompilationDiagnosticLogger + (debugName: string, options: FSharpDiagnosticOptions, ?preprocess: (PhasedDiagnostic -> PhasedDiagnostic)) = + inherit DiagnosticsLogger("CompilationDiagnosticLogger(" + debugName + ")") + let mutable errorCount = 0 let diagnostics = ResizeArray<_>() - override _.DiagnosticSink(diagnostic, severity) = + override _.DiagnosticSink(diagnostic, severity) = let diagnostic = match preprocess with | Some f -> f diagnostic @@ -328,19 +368,39 @@ type internal CompilationDiagnosticLogger (debugName: string, options: FSharpDia member _.GetDiagnostics() = diagnostics.ToArray() -module DiagnosticHelpers = - - let ReportDiagnostic (options: FSharpDiagnosticOptions, allErrors, mainInputFileName, diagnostic: PhasedDiagnostic, severity, suggestNames, flatErrors, symbolEnv) = +module DiagnosticHelpers = + + let ReportDiagnostic + ( + options: FSharpDiagnosticOptions, + allErrors, + mainInputFileName, + diagnostic: PhasedDiagnostic, + severity, + suggestNames, + flatErrors, + symbolEnv + ) = match diagnostic.AdjustSeverity(options, severity) with | FSharpDiagnosticSeverity.Hidden -> [] | adjustedSeverity -> - let diagnostic = FSharpDiagnostic.CreateFromException (diagnostic, adjustedSeverity, suggestNames, flatErrors, symbolEnv) + let diagnostic = + FSharpDiagnostic.CreateFromException(diagnostic, adjustedSeverity, suggestNames, flatErrors, symbolEnv) + let fileName = diagnostic.Range.FileName - if allErrors || fileName = mainInputFileName || fileName = TcGlobals.DummyFileNameForRangesWithoutASpecificLocation then - [diagnostic] - else [] + + if + allErrors + || fileName = mainInputFileName + || fileName = TcGlobals.DummyFileNameForRangesWithoutASpecificLocation + then + [ diagnostic ] + else + [] let CreateDiagnostics (options, allErrors, mainInputFileName, diagnostics, suggestNames, flatErrors, symbolEnv) = - [| for diagnostic, severity in diagnostics do - yield! ReportDiagnostic (options, allErrors, mainInputFileName, diagnostic, severity, suggestNames, flatErrors, symbolEnv) |] + [| + for diagnostic, severity in diagnostics do + yield! ReportDiagnostic(options, allErrors, mainInputFileName, diagnostic, severity, suggestNames, flatErrors, symbolEnv) + |] diff --git a/src/Compiler/Symbols/SymbolHelpers.fs b/src/Compiler/Symbols/SymbolHelpers.fs index c516f0c377b..c805c075ed1 100644 --- a/src/Compiler/Symbols/SymbolHelpers.fs +++ b/src/Compiler/Symbols/SymbolHelpers.fs @@ -55,22 +55,22 @@ module internal SymbolHelpers = let rangeOfPropInfo preferFlag (pinfo: PropInfo) = match pinfo with #if !NO_TYPEPROVIDERS - | ProvidedProp(_, pi, _) -> Construct.ComputeDefinitionLocationOfProvidedItem pi + | ProvidedProp(_, pi, _) -> Construct.ComputeDefinitionLocationOfProvidedItem pi #endif - | _ -> pinfo.ArbitraryValRef |> Option.map (rangeOfValRef preferFlag) + | _ -> pinfo.ArbitraryValRef |> Option.map (rangeOfValRef preferFlag) let rangeOfMethInfo (g: TcGlobals) preferFlag (minfo: MethInfo) = match minfo with #if !NO_TYPEPROVIDERS - | ProvidedMeth(_, mi, _, _) -> Construct.ComputeDefinitionLocationOfProvidedItem mi + | ProvidedMeth(_, mi, _, _) -> Construct.ComputeDefinitionLocationOfProvidedItem mi #endif - | DefaultStructCtor(_, AppTy g (tcref, _)) -> Some(rangeOfEntityRef preferFlag tcref) - | _ -> minfo.ArbitraryValRef |> Option.map (rangeOfValRef preferFlag) + | DefaultStructCtor(_, AppTy g (tcref, _)) -> Some(rangeOfEntityRef preferFlag tcref) + | _ -> minfo.ArbitraryValRef |> Option.map (rangeOfValRef preferFlag) let rangeOfEventInfo preferFlag (einfo: EventInfo) = match einfo with #if !NO_TYPEPROVIDERS - | ProvidedEvent (_, ei, _) -> Construct.ComputeDefinitionLocationOfProvidedItem ei + | ProvidedEvent(_, ei, _) -> Construct.ComputeDefinitionLocationOfProvidedItem ei #endif | _ -> einfo.ArbitraryValRef |> Option.map (rangeOfValRef preferFlag) @@ -91,31 +91,37 @@ module internal SymbolHelpers = let rec rangeOfItem (g: TcGlobals) preferFlag d = match d with - | Item.Value vref | Item.CustomBuilder (_, vref) -> Some (rangeOfValRef preferFlag vref) - | Item.UnionCase(ucinfo, _) -> Some (rangeOfUnionCaseInfo preferFlag ucinfo) - | Item.ActivePatternCase apref -> Some (rangeOfValRef preferFlag apref.ActivePatternVal) - | Item.ExnCase tcref -> Some tcref.Range - | Item.AnonRecdField (_,_,_,m) -> Some m - | Item.RecdField rfinfo -> Some (rangeOfRecdFieldInfo preferFlag rfinfo) - | Item.UnionCaseField (UnionCaseInfo (_, ucref), fieldIndex) -> Some (rangeOfRecdField preferFlag (ucref.FieldByIndex(fieldIndex))) - | Item.Event einfo -> rangeOfEventInfo preferFlag einfo - | Item.ILField _ -> None - | Item.Property(info = pinfos; sourceIdentifierRange = mNameOpt) -> + | Item.Value vref + | Item.CustomBuilder(_, vref) -> Some(rangeOfValRef preferFlag vref) + | Item.UnionCase(ucinfo, _) -> Some(rangeOfUnionCaseInfo preferFlag ucinfo) + | Item.ActivePatternCase apref -> Some(rangeOfValRef preferFlag apref.ActivePatternVal) + | Item.ExnCase tcref -> Some tcref.Range + | Item.AnonRecdField(_, _, _, m) -> Some m + | Item.RecdField rfinfo -> Some(rangeOfRecdFieldInfo preferFlag rfinfo) + | Item.UnionCaseField(UnionCaseInfo(_, ucref), fieldIndex) -> Some(rangeOfRecdField preferFlag (ucref.FieldByIndex(fieldIndex))) + | Item.Event einfo -> rangeOfEventInfo preferFlag einfo + | Item.ILField _ -> None + | Item.Property(info = pinfos; sourceIdentifierRange = mNameOpt) -> match mNameOpt with | Some m -> Some m | None -> rangeOfPropInfo preferFlag pinfos.Head - | Item.Types(_, tys) -> tys |> List.tryPick (tryNiceEntityRefOfTyOption >> Option.map (rangeOfEntityRef preferFlag)) - | Item.CustomOperation (_, _, Some minfo) -> rangeOfMethInfo g preferFlag minfo + | Item.Types(_, tys) -> + tys + |> List.tryPick (tryNiceEntityRefOfTyOption >> Option.map (rangeOfEntityRef preferFlag)) + | Item.CustomOperation(_, _, Some minfo) -> rangeOfMethInfo g preferFlag minfo | Item.Trait _ -> None - | Item.TypeVar (_, tp) -> Some tp.Range + | Item.TypeVar(_, tp) -> Some tp.Range | Item.ModuleOrNamespaces modrefs -> modrefs |> List.tryPick (rangeOfEntityRef preferFlag >> Some) | Item.MethodGroup(_, minfos, _) | Item.CtorGroup(_, minfos) -> minfos |> List.tryPick (rangeOfMethInfo g preferFlag) | Item.ActivePatternResult(APInfo _, _, _, m) -> Some m - | Item.SetterArg (_, item) -> rangeOfItem g preferFlag item - | Item.OtherName (range = m) -> Some m - | Item.CustomOperation (_, _, implOpt) -> implOpt |> Option.bind (rangeOfMethInfo g preferFlag) - | Item.ImplicitOp (_, {contents = Some(TraitConstraintSln.FSMethSln(vref=vref))}) -> Some vref.Range + | Item.SetterArg(_, item) -> rangeOfItem g preferFlag item + | Item.OtherName(range = m) -> Some m + | Item.CustomOperation(_, _, implOpt) -> implOpt |> Option.bind (rangeOfMethInfo g preferFlag) + | Item.ImplicitOp(_, + { + contents = Some(TraitConstraintSln.FSMethSln(vref = vref)) + }) -> Some vref.Range | Item.ImplicitOp _ -> None | Item.UnqualifiedType tcrefs -> tcrefs |> List.tryPick (rangeOfEntityRef preferFlag >> Some) | Item.DelegateCtor ty -> ty |> tryNiceEntityRefOfTyOption |> Option.map (rangeOfEntityRef preferFlag) @@ -124,14 +130,15 @@ module internal SymbolHelpers = // Provided type definitions do not have a useful F# CCU for the purposes of goto-definition. let computeCcuOfTyconRef (tcref: TyconRef) = #if !NO_TYPEPROVIDERS - if tcref.IsProvided then None else + if tcref.IsProvided then + None + else #endif ccuOfTyconRef tcref let ccuOfMethInfo (g: TcGlobals) (minfo: MethInfo) = match minfo with - | DefaultStructCtor(_, AppTy g (tcref, _)) -> - computeCcuOfTyconRef tcref + | DefaultStructCtor(_, AppTy g (tcref, _)) -> computeCcuOfTyconRef tcref | _ -> minfo.ArbitraryValRef @@ -141,95 +148,87 @@ module internal SymbolHelpers = let rec ccuOfItem (g: TcGlobals) d = match d with | Item.Value vref - | Item.CustomBuilder (_, vref) -> - ccuOfValRef vref + | Item.CustomBuilder(_, vref) -> ccuOfValRef vref - | Item.UnionCase(ucinfo, _) -> - computeCcuOfTyconRef ucinfo.TyconRef + | Item.UnionCase(ucinfo, _) -> computeCcuOfTyconRef ucinfo.TyconRef - | Item.ActivePatternCase apref -> - ccuOfValRef apref.ActivePatternVal + | Item.ActivePatternCase apref -> ccuOfValRef apref.ActivePatternVal - | Item.ExnCase tcref -> - computeCcuOfTyconRef tcref + | Item.ExnCase tcref -> computeCcuOfTyconRef tcref - | Item.RecdField rfinfo -> - computeCcuOfTyconRef rfinfo.RecdFieldRef.TyconRef + | Item.RecdField rfinfo -> computeCcuOfTyconRef rfinfo.RecdFieldRef.TyconRef - | Item.UnionCaseField (ucinfo, _) -> - computeCcuOfTyconRef ucinfo.TyconRef + | Item.UnionCaseField(ucinfo, _) -> computeCcuOfTyconRef ucinfo.TyconRef - | Item.Event einfo -> - einfo.DeclaringTyconRef |> computeCcuOfTyconRef + | Item.Event einfo -> einfo.DeclaringTyconRef |> computeCcuOfTyconRef - | Item.ILField finfo -> - finfo.DeclaringTyconRef |> computeCcuOfTyconRef + | Item.ILField finfo -> finfo.DeclaringTyconRef |> computeCcuOfTyconRef - | Item.Property(info = pinfos) -> - pinfos |> List.tryPick (fun pinfo -> + | Item.Property(info = pinfos) -> + pinfos + |> List.tryPick (fun pinfo -> pinfo.ArbitraryValRef |> Option.bind ccuOfValRef |> Option.orElseWith (fun () -> pinfo.DeclaringTyconRef |> computeCcuOfTyconRef)) - | Item.OtherName (container = meth) -> + | Item.OtherName(container = meth) -> match meth with | None -> None - | Some (ArgumentContainer.Method minfo) -> ccuOfMethInfo g minfo - | Some (ArgumentContainer.Type eref) -> computeCcuOfTyconRef eref + | Some(ArgumentContainer.Method minfo) -> ccuOfMethInfo g minfo + | Some(ArgumentContainer.Type eref) -> computeCcuOfTyconRef eref | Item.MethodGroup(_, minfos, _) - | Item.CtorGroup(_, minfos) -> - minfos |> List.tryPick (ccuOfMethInfo g) + | Item.CtorGroup(_, minfos) -> minfos |> List.tryPick (ccuOfMethInfo g) - | Item.CustomOperation (_, _, meth) -> + | Item.CustomOperation(_, _, meth) -> match meth with | None -> None | Some minfo -> ccuOfMethInfo g minfo | Item.Types(_, tys) -> - tys |> List.tryPick (tryNiceEntityRefOfTyOption >> Option.bind computeCcuOfTyconRef) + tys + |> List.tryPick (tryNiceEntityRefOfTyOption >> Option.bind computeCcuOfTyconRef) - | Item.DelegateCtor(ty) -> - ty |> tryNiceEntityRefOfTyOption |> Option.bind computeCcuOfTyconRef + | Item.DelegateCtor(ty) -> ty |> tryNiceEntityRefOfTyOption |> Option.bind computeCcuOfTyconRef | Item.ModuleOrNamespaces erefs - | Item.UnqualifiedType erefs -> - erefs |> List.tryPick computeCcuOfTyconRef + | Item.UnqualifiedType erefs -> erefs |> List.tryPick computeCcuOfTyconRef - | Item.SetterArg (_, item) -> - ccuOfItem g item + | Item.SetterArg(_, item) -> ccuOfItem g item - | Item.AnonRecdField (info, _, _, _) -> - Some info.Assembly + | Item.AnonRecdField(info, _, _, _) -> Some info.Assembly // This is not expected: you can't directly refer to trait constraints in other assemblies | Item.Trait _ -> None // This is not expected: you can't directly refer to type variables in other assemblies - | Item.TypeVar _ -> None + | Item.TypeVar _ -> None // This is not expected: you can't directly refer to active pattern result tags in other assemblies - | Item.ActivePatternResult _ -> None + | Item.ActivePatternResult _ -> None // This is not expected: implicit operator references only occur in the current assembly - | Item.ImplicitOp _ -> None + | Item.ImplicitOp _ -> None // This is not expected: NewDef only occurs within checking - | Item.NewDef _ -> None + | Item.NewDef _ -> None /// Work out the source file for an item and fix it up relative to the CCU if it is relative. let fileNameOfItem (g: TcGlobals) qualProjectDir (m: range) h = let file = m.FileName - if verbose then dprintf "file stored in metadata is '%s'\n" file + + if verbose then + dprintf "file stored in metadata is '%s'\n" file + if not (FileSystem.IsPathRootedShim file) then match ccuOfItem g h with - | Some ccu -> - Path.Combine(ccu.SourceCodeDirectory, file) + | Some ccu -> Path.Combine(ccu.SourceCodeDirectory, file) | None -> match qualProjectDir with - | None -> file + | None -> file | Some dir -> Path.Combine(dir, file) - else file + else + file let ParamNameAndTypesOfUnaryCustomOperation g minfo = match minfo with @@ -237,16 +236,20 @@ module internal SymbolHelpers = let argInfos = ArgInfosOfMember g vref |> List.concat // Drop the first 'seq' argument representing the computation space let argInfos = if argInfos.IsEmpty then [] else argInfos.Tail - [ for ty, argInfo in argInfos do - let isPP = HasFSharpAttribute g g.attrib_ProjectionParameterAttribute argInfo.Attribs - // Strip the tuple space type of the type of projection parameters - let ty = if isPP && isFunTy g ty then rangeOfFunTy g ty else ty - yield ParamNameAndType(argInfo.Name, ty) ] + + [ + for ty, argInfo in argInfos do + let isPP = + HasFSharpAttribute g g.attrib_ProjectionParameterAttribute argInfo.Attribs + // Strip the tuple space type of the type of projection parameters + let ty = if isPP && isFunTy g ty then rangeOfFunTy g ty else ty + yield ParamNameAndType(argInfo.Name, ty) + ] | _ -> [] let mkXmlComment thing = match thing with - | Some (Some fileName, xmlDocSig) -> FSharpXmlDoc.FromXmlFile(fileName, xmlDocSig) + | Some(Some fileName, xmlDocSig) -> FSharpXmlDoc.FromXmlFile(fileName, xmlDocSig) | _ -> FSharpXmlDoc.None let GetXmlDocFromLoader (infoReader: InfoReader) xmlDoc = @@ -261,65 +264,53 @@ module internal SymbolHelpers = /// This function gets the signature to pass to Visual Studio to use its lookup functions for .NET stuff. let rec GetXmlDocHelpSigOfItemForLookup (infoReader: InfoReader) m d = let g = infoReader.g + match d with - | Item.ActivePatternCase (APElemRef(_, vref, _, _)) - | Item.Value vref | Item.CustomBuilder (_, vref) -> - mkXmlComment (GetXmlDocSigOfValRef g vref) + | Item.ActivePatternCase(APElemRef(_, vref, _, _)) + | Item.Value vref + | Item.CustomBuilder(_, vref) -> mkXmlComment (GetXmlDocSigOfValRef g vref) - | Item.UnionCase (ucinfo, _) -> - mkXmlComment (GetXmlDocSigOfUnionCaseRef ucinfo.UnionCaseRef) + | Item.UnionCase(ucinfo, _) -> mkXmlComment (GetXmlDocSigOfUnionCaseRef ucinfo.UnionCaseRef) - | Item.UnqualifiedType (tcref :: _) - | Item.ExnCase tcref -> - mkXmlComment (GetXmlDocSigOfEntityRef infoReader m tcref) + | Item.UnqualifiedType(tcref :: _) + | Item.ExnCase tcref -> mkXmlComment (GetXmlDocSigOfEntityRef infoReader m tcref) - | Item.RecdField rfinfo -> - mkXmlComment (GetXmlDocSigOfRecdFieldRef rfinfo.RecdFieldRef) + | Item.RecdField rfinfo -> mkXmlComment (GetXmlDocSigOfRecdFieldRef rfinfo.RecdFieldRef) | Item.NewDef _ -> FSharpXmlDoc.None - | Item.ILField finfo -> - mkXmlComment (GetXmlDocSigOfILFieldInfo infoReader m finfo) + | Item.ILField finfo -> mkXmlComment (GetXmlDocSigOfILFieldInfo infoReader m finfo) | Item.DelegateCtor ty | Item.Types(_, ty :: _) -> match ty with - | AbbrevOrAppTy(tcref, _) -> - mkXmlComment (GetXmlDocSigOfEntityRef infoReader m tcref) + | AbbrevOrAppTy(tcref, _) -> mkXmlComment (GetXmlDocSigOfEntityRef infoReader m tcref) | _ -> FSharpXmlDoc.None - | Item.CustomOperation (_, _, Some minfo) -> - mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) + | Item.CustomOperation(_, _, Some minfo) -> mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) | Item.Trait _ -> FSharpXmlDoc.None - | Item.TypeVar _ -> FSharpXmlDoc.None + | Item.TypeVar _ -> FSharpXmlDoc.None - | Item.ModuleOrNamespaces(modref :: _) -> - mkXmlComment (GetXmlDocSigOfEntityRef infoReader m modref) + | Item.ModuleOrNamespaces(modref :: _) -> mkXmlComment (GetXmlDocSigOfEntityRef infoReader m modref) - | Item.Property(info = pinfo :: _) -> - mkXmlComment (GetXmlDocSigOfProp infoReader m pinfo) + | Item.Property(info = pinfo :: _) -> mkXmlComment (GetXmlDocSigOfProp infoReader m pinfo) - | Item.Event einfo -> - mkXmlComment (GetXmlDocSigOfEvent infoReader m einfo) + | Item.Event einfo -> mkXmlComment (GetXmlDocSigOfEvent infoReader m einfo) - | Item.MethodGroup(_, minfo :: _, _) -> - mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) + | Item.MethodGroup(_, minfo :: _, _) -> mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) - | Item.CtorGroup(_, minfo :: _) -> - mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) + | Item.CtorGroup(_, minfo :: _) -> mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) | Item.OtherName(container = Some argContainer) -> match argContainer with | ArgumentContainer.Method minfo -> mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) | ArgumentContainer.Type tcref -> mkXmlComment (GetXmlDocSigOfEntityRef infoReader m tcref) - | Item.UnionCaseField (ucinfo, _) -> - mkXmlComment (GetXmlDocSigOfUnionCaseRef ucinfo.UnionCaseRef) + | Item.UnionCaseField(ucinfo, _) -> mkXmlComment (GetXmlDocSigOfUnionCaseRef ucinfo.UnionCaseRef) - | Item.SetterArg (_, item) -> - GetXmlDocHelpSigOfItemForLookup infoReader m item + | Item.SetterArg(_, item) -> GetXmlDocHelpSigOfItemForLookup infoReader m item // These do not have entries in XML doc files | Item.CustomOperation _ @@ -329,21 +320,19 @@ module internal SymbolHelpers = | Item.ImplicitOp _ // These empty lists are not expected to occur - | Item.CtorGroup (_, []) - | Item.MethodGroup (_, [], _) - | Item.Property (info = []) + | Item.CtorGroup(_, []) + | Item.MethodGroup(_, [], _) + | Item.Property(info = []) | Item.ModuleOrNamespaces [] | Item.UnqualifiedType [] - | Item.Types(_, []) -> - FSharpXmlDoc.None + | Item.Types(_, []) -> FSharpXmlDoc.None |> GetXmlDocFromLoader infoReader /// Produce an XmlComment with a signature or raw text, given the F# comment and the item let GetXmlCommentForItemAux (xmlDoc: XmlDoc option) (infoReader: InfoReader) m d = match xmlDoc with - | Some xmlDoc when not xmlDoc.IsEmpty -> - FSharpXmlDoc.FromXmlText xmlDoc + | Some xmlDoc when not xmlDoc.IsEmpty -> FSharpXmlDoc.FromXmlText xmlDoc | _ -> GetXmlDocHelpSigOfItemForLookup infoReader m d let GetXmlCommentForMethInfoItem infoReader m d (minfo: MethInfo) = @@ -353,15 +342,19 @@ module internal SymbolHelpers = mkXmlComment (GetXmlDocSigOfMethInfo infoReader m minfo) let FormatTyparMapping denv (prettyTyparInst: TyparInstantiation) = - [ for tp, ty in prettyTyparInst -> - wordL (tagTypeParameter ("'" + tp.DisplayName)) ^^ wordL (tagText (FSComp.SR.descriptionWordIs())) ^^ NicePrint.layoutType denv ty ] + [ + for tp, ty in prettyTyparInst -> + wordL (tagTypeParameter ("'" + tp.DisplayName)) + ^^ wordL (tagText (FSComp.SR.descriptionWordIs ())) + ^^ NicePrint.layoutType denv ty + ] [] let (|ItemWhereTypIsPreferred|_|) item = match item with | Item.DelegateCtor ty - | Item.CtorGroup(_, [DefaultStructCtor(_, ty)]) - | Item.Types(_, [ty]) -> ValueSome ty + | Item.CtorGroup(_, [ DefaultStructCtor(_, ty) ]) + | Item.Types(_, [ ty ]) -> ValueSome ty | _ -> ValueNone /// Specifies functions for comparing 'Item' objects with respect to the user @@ -369,161 +362,165 @@ module internal SymbolHelpers = /// if this is what we want to show to the user, because we're comparing just the name // for some cases e.g. when using 'fullDisplayTextOfModRef') let ItemDisplayPartialEquality g = - { new IPartialEqualityComparer<_> with - member x.InEqualityRelation item = - match item with - | Item.Trait _ -> true - | Item.Types(_, _ :: _) -> true - | Item.ILField(_) -> true - | Item.RecdField _ -> true - | Item.SetterArg _ -> true - | Item.TypeVar _ -> true - | Item.CustomOperation _ -> true - | Item.ModuleOrNamespaces(_ :: _) -> true - | Item.MethodGroup _ -> true - | Item.Value _ | Item.CustomBuilder _ -> true - | Item.ActivePatternCase _ -> true - | Item.DelegateCtor _ -> true - | Item.UnionCase _ -> true - | Item.ExnCase _ -> true - | Item.Event _ -> true - | Item.Property _ -> true - | Item.CtorGroup _ -> true - | Item.UnqualifiedType _ -> true - - // These are never expected to have duplicates in declaration lists etc - | Item.ActivePatternResult _ - | Item.AnonRecdField _ - | Item.OtherName _ - | Item.ImplicitOp _ - | Item.NewDef _ - | Item.UnionCaseField _ - - // These are not expected to occur - | Item.Types(_, []) - | Item.ModuleOrNamespaces [] -> false - - //| _ -> false - - member x.Equals(item1, item2) = - match item1,item2 with - | null,null -> true - | null,_ | _,null -> false - | item1,item2 -> + { new IPartialEqualityComparer<_> with + member x.InEqualityRelation item = + match item with + | Item.Trait _ -> true + | Item.Types(_, _ :: _) -> true + | Item.ILField(_) -> true + | Item.RecdField _ -> true + | Item.SetterArg _ -> true + | Item.TypeVar _ -> true + | Item.CustomOperation _ -> true + | Item.ModuleOrNamespaces(_ :: _) -> true + | Item.MethodGroup _ -> true + | Item.Value _ + | Item.CustomBuilder _ -> true + | Item.ActivePatternCase _ -> true + | Item.DelegateCtor _ -> true + | Item.UnionCase _ -> true + | Item.ExnCase _ -> true + | Item.Event _ -> true + | Item.Property _ -> true + | Item.CtorGroup _ -> true + | Item.UnqualifiedType _ -> true + + // These are never expected to have duplicates in declaration lists etc + | Item.ActivePatternResult _ + | Item.AnonRecdField _ + | Item.OtherName _ + | Item.ImplicitOp _ + | Item.NewDef _ + | Item.UnionCaseField _ + + // These are not expected to occur + | Item.Types(_, []) + | Item.ModuleOrNamespaces [] -> false + + //| _ -> false + + member x.Equals(item1, item2) = + match item1, item2 with + | null, null -> true + | null, _ + | _, null -> false + | item1, item2 -> + // This may explore assemblies that are not in the reference set. + // In this case just bail out and assume items are not equal + protectAssemblyExploration false (fun () -> + let equalHeadTypes (ty1, ty2) = + match tryTcrefOfAppTy g ty1 with + | ValueSome tcref1 -> + match tryTcrefOfAppTy g ty2 with + | ValueSome tcref2 -> tyconRefEq g tcref1 tcref2 + | _ -> typeEquiv g ty1 ty2 + | _ -> typeEquiv g ty1 ty2 + + ItemsAreEffectivelyEqual g item1 item2 + || + + // Much of this logic is already covered by 'ItemsAreEffectivelyEqual' + match item1, item2 with + | Item.DelegateCtor ty1, Item.DelegateCtor ty2 -> equalHeadTypes (ty1, ty2) + | Item.Types(dn1, ty1 :: _), Item.Types(dn2, ty2 :: _) -> + // Bug 4403: We need to compare names as well, because 'int' and 'Int32' are physically the same type, but we want to show both + dn1 = dn2 && equalHeadTypes (ty1, ty2) + + // Prefer a type to a DefaultStructCtor, a DelegateCtor and a FakeInterfaceCtor + | ItemWhereTypIsPreferred ty1, ItemWhereTypIsPreferred ty2 -> equalHeadTypes (ty1, ty2) + + | Item.ExnCase tcref1, Item.ExnCase tcref2 -> tyconRefEq g tcref1 tcref2 + | Item.ILField(fld1), Item.ILField(fld2) -> ILFieldInfo.ILFieldInfosUseIdenticalDefinitions fld1 fld2 + | Item.CustomOperation(_, _, Some minfo1), Item.CustomOperation(_, _, Some minfo2) -> + MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2 + | Item.TypeVar(nm1, tp1), Item.TypeVar(nm2, tp2) -> (nm1 = nm2) && typarRefEq tp1 tp2 + | Item.ModuleOrNamespaces(modref1 :: _), Item.ModuleOrNamespaces(modref2 :: _) -> + fullDisplayTextOfModRef modref1 = fullDisplayTextOfModRef modref2 + | Item.SetterArg(id1, _), Item.SetterArg(id2, _) -> Range.equals id1.idRange id2.idRange && id1.idText = id2.idText + | Item.MethodGroup(_, meths1, _), Item.MethodGroup(_, meths2, _) -> + Seq.zip meths1 meths2 + |> Seq.forall (fun (minfo1, minfo2) -> MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2) + | (Item.Value vref1 | Item.CustomBuilder(_, vref1)), (Item.Value vref2 | Item.CustomBuilder(_, vref2)) -> + valRefEq g vref1 vref2 + | Item.ActivePatternCase(APElemRef(_apinfo1, vref1, idx1, _)), + Item.ActivePatternCase(APElemRef(_apinfo2, vref2, idx2, _)) -> idx1 = idx2 && valRefEq g vref1 vref2 + | Item.UnionCase(UnionCaseInfo(_, ur1), _), Item.UnionCase(UnionCaseInfo(_, ur2), _) -> g.unionCaseRefEq ur1 ur2 + | Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref1, n1))), + Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref2, n2))) -> (tyconRefEq g tcref1 tcref2) && (n1 = n2) // there is no direct function as in the previous case + | Item.Property(info = pi1s), Item.Property(info = pi2s) -> + (pi1s, pi2s) ||> List.forall2 PropInfo.PropInfosUseIdenticalDefinitions + | Item.Event evt1, Item.Event evt2 -> EventInfo.EventInfosUseIdenticalDefinitions evt1 evt2 + | Item.AnonRecdField(anon1, _, i1, _), Item.AnonRecdField(anon2, _, i2, _) -> anonInfoEquiv anon1 anon2 && i1 = i2 + | Item.Trait traitInfo1, Item.Trait traitInfo2 -> (traitInfo1.MemberLogicalName = traitInfo2.MemberLogicalName) + | Item.CtorGroup(_, meths1), Item.CtorGroup(_, meths2) -> + (meths1, meths2) ||> List.forall2 MethInfo.MethInfosUseIdenticalDefinitions + | Item.UnqualifiedType tcrefs1, Item.UnqualifiedType tcrefs2 -> + (tcrefs1, tcrefs2) + ||> List.forall2 (fun tcref1 tcref2 -> tyconRefEq g tcref1 tcref2) + | Item.Types(_, [ AbbrevOrAppTy(tcref1, _) ]), Item.UnqualifiedType([ tcref2 ]) -> tyconRefEq g tcref1 tcref2 + | Item.UnqualifiedType([ tcref1 ]), Item.Types(_, [ AbbrevOrAppTy(tcref2, _) ]) -> tyconRefEq g tcref1 tcref2 + | _ -> false) + + member x.GetHashCode item = // This may explore assemblies that are not in the reference set. - // In this case just bail out and assume items are not equal - protectAssemblyExploration false (fun () -> - let equalHeadTypes(ty1, ty2) = - match tryTcrefOfAppTy g ty1 with - | ValueSome tcref1 -> - match tryTcrefOfAppTy g ty2 with - | ValueSome tcref2 -> tyconRefEq g tcref1 tcref2 - | _ -> typeEquiv g ty1 ty2 - | _ -> typeEquiv g ty1 ty2 - - ItemsAreEffectivelyEqual g item1 item2 || - - // Much of this logic is already covered by 'ItemsAreEffectivelyEqual' - match item1, item2 with - | Item.DelegateCtor ty1, Item.DelegateCtor ty2 -> equalHeadTypes(ty1, ty2) - | Item.Types(dn1, ty1 :: _), Item.Types(dn2, ty2 :: _) -> - // Bug 4403: We need to compare names as well, because 'int' and 'Int32' are physically the same type, but we want to show both - dn1 = dn2 && equalHeadTypes(ty1, ty2) - - // Prefer a type to a DefaultStructCtor, a DelegateCtor and a FakeInterfaceCtor - | ItemWhereTypIsPreferred ty1, ItemWhereTypIsPreferred ty2 -> equalHeadTypes(ty1, ty2) - - | Item.ExnCase tcref1, Item.ExnCase tcref2 -> tyconRefEq g tcref1 tcref2 - | Item.ILField(fld1), Item.ILField(fld2) -> - ILFieldInfo.ILFieldInfosUseIdenticalDefinitions fld1 fld2 - | Item.CustomOperation (_, _, Some minfo1), Item.CustomOperation (_, _, Some minfo2) -> - MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2 - | Item.TypeVar (nm1, tp1), Item.TypeVar (nm2, tp2) -> - (nm1 = nm2) && typarRefEq tp1 tp2 - | Item.ModuleOrNamespaces(modref1 :: _), Item.ModuleOrNamespaces(modref2 :: _) -> fullDisplayTextOfModRef modref1 = fullDisplayTextOfModRef modref2 - | Item.SetterArg(id1, _), Item.SetterArg(id2, _) -> Range.equals id1.idRange id2.idRange && id1.idText = id2.idText - | Item.MethodGroup(_, meths1, _), Item.MethodGroup(_, meths2, _) -> - Seq.zip meths1 meths2 |> Seq.forall (fun (minfo1, minfo2) -> - MethInfo.MethInfosUseIdenticalDefinitions minfo1 minfo2) - | (Item.Value vref1 | Item.CustomBuilder (_, vref1)), (Item.Value vref2 | Item.CustomBuilder (_, vref2)) -> - valRefEq g vref1 vref2 - | Item.ActivePatternCase(APElemRef(_apinfo1, vref1, idx1, _)), Item.ActivePatternCase(APElemRef(_apinfo2, vref2, idx2, _)) -> - idx1 = idx2 && valRefEq g vref1 vref2 - | Item.UnionCase(UnionCaseInfo(_, ur1), _), Item.UnionCase(UnionCaseInfo(_, ur2), _) -> - g.unionCaseRefEq ur1 ur2 - | Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref1, n1))), Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref2, n2))) -> - (tyconRefEq g tcref1 tcref2) && (n1 = n2) // there is no direct function as in the previous case - | Item.Property(info = pi1s), Item.Property(info = pi2s) -> - (pi1s, pi2s) ||> List.forall2 PropInfo.PropInfosUseIdenticalDefinitions - | Item.Event evt1, Item.Event evt2 -> - EventInfo.EventInfosUseIdenticalDefinitions evt1 evt2 - | Item.AnonRecdField(anon1, _, i1, _), Item.AnonRecdField(anon2, _, i2, _) -> - anonInfoEquiv anon1 anon2 && i1 = i2 - | Item.Trait traitInfo1, Item.Trait traitInfo2 -> - (traitInfo1.MemberLogicalName = traitInfo2.MemberLogicalName) - | Item.CtorGroup(_, meths1), Item.CtorGroup(_, meths2) -> - (meths1, meths2) - ||> List.forall2 MethInfo.MethInfosUseIdenticalDefinitions - | Item.UnqualifiedType tcrefs1, Item.UnqualifiedType tcrefs2 -> - (tcrefs1, tcrefs2) - ||> List.forall2 (fun tcref1 tcref2 -> tyconRefEq g tcref1 tcref2) - | Item.Types(_, [AbbrevOrAppTy(tcref1, _)]), Item.UnqualifiedType([tcref2]) -> tyconRefEq g tcref1 tcref2 - | Item.UnqualifiedType([tcref1]), Item.Types(_, [AbbrevOrAppTy(tcref2, _)]) -> tyconRefEq g tcref1 tcref2 - | _ -> false) - - member x.GetHashCode item = - // This may explore assemblies that are not in the reference set. - // In this case just bail out and use a random hash code - protectAssemblyExploration 1027 (fun () -> - match item with - | ItemWhereTypIsPreferred ty -> - match tryTcrefOfAppTy g ty with - | ValueSome tcref -> hash tcref.LogicalName - | _ -> 1010 - | Item.ILField(fld) -> - fld.ComputeHashCode() - | Item.TypeVar (nm, _tp) -> hash nm - | Item.CustomOperation (_, _, Some minfo) -> minfo.ComputeHashCode() - | Item.CustomOperation (_, _, None) -> 1 - | Item.ModuleOrNamespaces(modref :: _) -> hash (fullDisplayTextOfModRef modref) - | Item.SetterArg(id, _) -> hash (id.idRange, id.idText) - | Item.MethodGroup(_, meths, _) -> meths |> List.fold (fun st a -> st + a.ComputeHashCode()) 0 - | Item.CtorGroup(name, meths) -> name.GetHashCode() + (meths |> List.fold (fun st a -> st + a.ComputeHashCode()) 0) - | Item.Value vref | Item.CustomBuilder (_, vref) -> hash vref.LogicalName - | Item.ActivePatternCase(APElemRef(_apinfo, vref, idx, _)) -> hash (vref.LogicalName, idx) - | Item.ExnCase tcref -> hash tcref.LogicalName - | Item.UnionCase(UnionCaseInfo(_, UnionCaseRef(tcref, n)), _) -> hash(tcref.Stamp, n) - | Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref, n))) -> hash(tcref.Stamp, n) - | Item.AnonRecdField(anon, _, i, _) -> hash anon.SortedNames[i] - | Item.Trait traitInfo -> hash traitInfo.MemberLogicalName - | Item.Event evt -> evt.ComputeHashCode() - | Item.Property(info = pis) -> hash (pis |> List.map (fun pi -> pi.ComputeHashCode())) - | Item.UnqualifiedType(tcref :: _) -> hash tcref.LogicalName - - // These are not expected to occur, see InEqualityRelation and ItemWhereTypIsPreferred - | Item.ActivePatternResult _ - | Item.AnonRecdField _ - | Item.OtherName _ - | Item.ImplicitOp _ - | Item.NewDef _ - | Item.UnionCaseField _ - | Item.UnqualifiedType _ - | Item.Types _ - | Item.DelegateCtor _ - | Item.ModuleOrNamespaces [] -> 0 - ) } + // In this case just bail out and use a random hash code + protectAssemblyExploration 1027 (fun () -> + match item with + | ItemWhereTypIsPreferred ty -> + match tryTcrefOfAppTy g ty with + | ValueSome tcref -> hash tcref.LogicalName + | _ -> 1010 + | Item.ILField(fld) -> fld.ComputeHashCode() + | Item.TypeVar(nm, _tp) -> hash nm + | Item.CustomOperation(_, _, Some minfo) -> minfo.ComputeHashCode() + | Item.CustomOperation(_, _, None) -> 1 + | Item.ModuleOrNamespaces(modref :: _) -> hash (fullDisplayTextOfModRef modref) + | Item.SetterArg(id, _) -> hash (id.idRange, id.idText) + | Item.MethodGroup(_, meths, _) -> meths |> List.fold (fun st a -> st + a.ComputeHashCode()) 0 + | Item.CtorGroup(name, meths) -> + name.GetHashCode() + + (meths |> List.fold (fun st a -> st + a.ComputeHashCode()) 0) + | Item.Value vref + | Item.CustomBuilder(_, vref) -> hash vref.LogicalName + | Item.ActivePatternCase(APElemRef(_apinfo, vref, idx, _)) -> hash (vref.LogicalName, idx) + | Item.ExnCase tcref -> hash tcref.LogicalName + | Item.UnionCase(UnionCaseInfo(_, UnionCaseRef(tcref, n)), _) -> hash (tcref.Stamp, n) + | Item.RecdField(RecdFieldInfo(_, RecdFieldRef(tcref, n))) -> hash (tcref.Stamp, n) + | Item.AnonRecdField(anon, _, i, _) -> hash anon.SortedNames[i] + | Item.Trait traitInfo -> hash traitInfo.MemberLogicalName + | Item.Event evt -> evt.ComputeHashCode() + | Item.Property(info = pis) -> hash (pis |> List.map (fun pi -> pi.ComputeHashCode())) + | Item.UnqualifiedType(tcref :: _) -> hash tcref.LogicalName + + // These are not expected to occur, see InEqualityRelation and ItemWhereTypIsPreferred + | Item.ActivePatternResult _ + | Item.AnonRecdField _ + | Item.OtherName _ + | Item.ImplicitOp _ + | Item.NewDef _ + | Item.UnionCaseField _ + | Item.UnqualifiedType _ + | Item.Types _ + | Item.DelegateCtor _ + | Item.ModuleOrNamespaces [] -> 0) + } /// Remove all duplicate items let RemoveDuplicateItems g (items: ItemWithInst list) = - if isNil items then items else - items |> IPartialEqualityComparer.partialDistinctBy (IPartialEqualityComparer.On (fun item -> item.Item) (ItemDisplayPartialEquality g)) + if isNil items then + items + else + items + |> IPartialEqualityComparer.partialDistinctBy ( + IPartialEqualityComparer.On (fun item -> item.Item) (ItemDisplayPartialEquality g) + ) let IsExplicitlySuppressed (g: TcGlobals) (item: Item) = // This may explore assemblies that are not in the reference set. // In this case just assume the item is not suppressed. protectAssemblyExploration true (fun () -> match item with - | Item.Types(it, [ty]) -> + | Item.Types(it, [ ty ]) -> match tryTcrefOfAppTy g ty with | ValueSome tcr1 -> g.suppressed_types @@ -532,7 +529,8 @@ module internal SymbolHelpers = // check the display name is precisely the one we're suppressing match tryTcrefOfAppTy g generalizedSupp with | ValueSome tcr2 -> - it = supp.DisplayName && + it = supp.DisplayName + && // check if they are the same logical type (after removing all abbreviations) tyconRefEq g tcr1 tcr2 | _ -> false) @@ -544,33 +542,55 @@ module internal SymbolHelpers = items |> List.filter (fun item -> not (IsExplicitlySuppressed g item.Item)) let SimplerDisplayEnv denv = - { denv with shortConstraints=true - showStaticallyResolvedTyparAnnotations=false - showNullnessAnnotations = Some true - abbreviateAdditionalConstraints=false - suppressNestedTypes=true - maxMembers=Some EnvMisc2.maxMembers } + { denv with + shortConstraints = true + showStaticallyResolvedTyparAnnotations = false + showNullnessAnnotations = Some true + abbreviateAdditionalConstraints = false + suppressNestedTypes = true + maxMembers = Some EnvMisc2.maxMembers + } let rec FullNameOfItem g item = let denv = DisplayEnv.Empty g + match item with - | Item.ImplicitOp(_, { contents = Some(TraitConstraintSln.FSMethSln(vref=vref)) }) - | Item.Value vref | Item.CustomBuilder (_, vref) -> fullDisplayTextOfValRef vref - | Item.UnionCase (ucinfo, _) -> fullDisplayTextOfUnionCaseRef ucinfo.UnionCaseRef + | Item.ImplicitOp(_, + { + contents = Some(TraitConstraintSln.FSMethSln(vref = vref)) + }) + | Item.Value vref + | Item.CustomBuilder(_, vref) -> fullDisplayTextOfValRef vref + | Item.UnionCase(ucinfo, _) -> fullDisplayTextOfUnionCaseRef ucinfo.UnionCaseRef | Item.ActivePatternResult(apinfo, _ty, idx, _) -> apinfo.DisplayNameByIdx idx - | Item.ActivePatternCase apref -> FullNameOfItem g (Item.Value apref.ActivePatternVal) + "." + apref.DisplayName + | Item.ActivePatternCase apref -> FullNameOfItem g (Item.Value apref.ActivePatternVal) + "." + apref.DisplayName | Item.ExnCase ecref -> fullDisplayTextOfExnRef ecref | Item.AnonRecdField(anon, _argTys, i, _) -> anon.DisplayNameByIdx i - | Item.RecdField rfinfo -> fullDisplayTextOfRecdFieldRef rfinfo.RecdFieldRef + | Item.RecdField rfinfo -> fullDisplayTextOfRecdFieldRef rfinfo.RecdFieldRef | Item.NewDef id -> id.idText - | Item.ILField finfo -> buildString (fun os -> NicePrint.outputType denv os finfo.ApparentEnclosingType; bprintf os ".%s" finfo.FieldName) - | Item.Event einfo -> buildString (fun os -> NicePrint.outputTyconRef denv os einfo.DeclaringTyconRef; bprintf os ".%s" einfo.EventName) - | Item.Property(info = pinfo :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os pinfo.DeclaringTyconRef; bprintf os ".%s" pinfo.PropertyName) - | Item.CustomOperation (customOpName, _, _) -> customOpName + | Item.ILField finfo -> + buildString (fun os -> + NicePrint.outputType denv os finfo.ApparentEnclosingType + bprintf os ".%s" finfo.FieldName) + | Item.Event einfo -> + buildString (fun os -> + NicePrint.outputTyconRef denv os einfo.DeclaringTyconRef + bprintf os ".%s" einfo.EventName) + | Item.Property(info = pinfo :: _) -> + buildString (fun os -> + NicePrint.outputTyconRef denv os pinfo.DeclaringTyconRef + bprintf os ".%s" pinfo.PropertyName) + | Item.CustomOperation(customOpName, _, _) -> customOpName | Item.CtorGroup(_, minfo :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef) - | Item.MethodGroup(_, _, Some minfo) -> buildString (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef; bprintf os ".%s" minfo.DisplayName) - | Item.MethodGroup(_, minfo :: _, _) -> buildString (fun os -> NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef; bprintf os ".%s" minfo.DisplayName) - | Item.UnqualifiedType (tcref :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os tcref) + | Item.MethodGroup(_, _, Some minfo) -> + buildString (fun os -> + NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef + bprintf os ".%s" minfo.DisplayName) + | Item.MethodGroup(_, minfo :: _, _) -> + buildString (fun os -> + NicePrint.outputTyconRef denv os minfo.DeclaringTyconRef + bprintf os ".%s" minfo.DisplayName) + | Item.UnqualifiedType(tcref :: _) -> buildString (fun os -> NicePrint.outputTyconRef denv os tcref) | Item.DelegateCtor ty | Item.Types(_, ty :: _) -> match tryTcrefOfAppTy g ty with @@ -579,12 +599,16 @@ module internal SymbolHelpers = | Item.Trait traitInfo -> traitInfo.MemberLogicalName | Item.ModuleOrNamespaces(modref :: _ as modrefs) -> let definiteNamespace = modrefs |> List.forall (fun modref -> modref.IsNamespace) - if definiteNamespace then fullDisplayTextOfModRef modref else modref.DisplayName + + if definiteNamespace then + fullDisplayTextOfModRef modref + else + modref.DisplayName | Item.TypeVar _ | Item.OtherName _ -> item.DisplayName - | Item.SetterArg (_, item) -> FullNameOfItem g item + | Item.SetterArg(_, item) -> FullNameOfItem g item | Item.ImplicitOp(id, _) -> id.idText - | Item.UnionCaseField (UnionCaseInfo (_, ucref), fieldIndex) -> ucref.FieldByIndex(fieldIndex).DisplayName + | Item.UnionCaseField(UnionCaseInfo(_, ucref), fieldIndex) -> ucref.FieldByIndex(fieldIndex).DisplayName // unreachable | Item.UnqualifiedType([]) | Item.Types(_, []) @@ -596,25 +620,38 @@ module internal SymbolHelpers = /// Output the description of a language item let rec GetXmlCommentForItem (infoReader: InfoReader) m item = let g = infoReader.g + match item with | Item.ImplicitOp(_, sln) -> match sln.Value with - | Some(TraitConstraintSln.FSMethSln(vref=vref)) -> - GetXmlCommentForItem infoReader m (Item.Value vref) - | Some (TraitConstraintSln.ILMethSln _) - | Some (TraitConstraintSln.FSRecdFieldSln _) - | Some (TraitConstraintSln.FSAnonRecdFieldSln _) - | Some (TraitConstraintSln.ClosedExprSln _) + | Some(TraitConstraintSln.FSMethSln(vref = vref)) -> GetXmlCommentForItem infoReader m (Item.Value vref) + | Some(TraitConstraintSln.ILMethSln _) + | Some(TraitConstraintSln.FSRecdFieldSln _) + | Some(TraitConstraintSln.FSAnonRecdFieldSln _) + | Some(TraitConstraintSln.ClosedExprSln _) | Some TraitConstraintSln.BuiltInSln - | None -> - GetXmlCommentForItemAux None infoReader m item + | None -> GetXmlCommentForItemAux None infoReader m item + + | Item.Value vref + | Item.CustomBuilder(_, vref) -> + let doc = + if valRefInThisAssembly g.compilingFSharpCore vref || vref.XmlDoc.NonEmpty then + Some vref.XmlDoc + else + None - | Item.Value vref | Item.CustomBuilder (_, vref) -> - let doc = if valRefInThisAssembly g.compilingFSharpCore vref || vref.XmlDoc.NonEmpty then Some vref.XmlDoc else None GetXmlCommentForItemAux doc infoReader m item | Item.UnionCase(ucinfo, _) -> - let doc = if tyconRefUsesLocalXmlDoc g.compilingFSharpCore ucinfo.TyconRef || ucinfo.UnionCase.XmlDoc.NonEmpty then Some ucinfo.UnionCase.XmlDoc else None + let doc = + if + tyconRefUsesLocalXmlDoc g.compilingFSharpCore ucinfo.TyconRef + || ucinfo.UnionCase.XmlDoc.NonEmpty + then + Some ucinfo.UnionCase.XmlDoc + else + None + GetXmlCommentForItemAux doc infoReader m item | Item.ActivePatternCase apref -> @@ -622,11 +659,17 @@ module internal SymbolHelpers = GetXmlCommentForItemAux doc infoReader m item | Item.ExnCase ecref -> - let doc = if tyconRefUsesLocalXmlDoc g.compilingFSharpCore ecref || ecref.XmlDoc.NonEmpty then Some ecref.XmlDoc else None + let doc = + if tyconRefUsesLocalXmlDoc g.compilingFSharpCore ecref || ecref.XmlDoc.NonEmpty then + Some ecref.XmlDoc + else + None + GetXmlCommentForItemAux doc infoReader m item | Item.RecdField rfinfo -> let tcref = rfinfo.TyconRef + let doc = if tyconRefUsesLocalXmlDoc g.compilingFSharpCore tcref || tcref.XmlDoc.NonEmpty then if tcref.IsFSharpException then @@ -635,21 +678,32 @@ module internal SymbolHelpers = Some rfinfo.RecdField.XmlDoc else None + GetXmlCommentForItemAux doc infoReader m item | Item.Event einfo -> - let doc = if einfo.HasDirectXmlComment || einfo.XmlDoc.NonEmpty then Some einfo.XmlDoc else None + let doc = + if einfo.HasDirectXmlComment || einfo.XmlDoc.NonEmpty then + Some einfo.XmlDoc + else + None + GetXmlCommentForItemAux doc infoReader m item | Item.Property(info = pinfos) -> let pinfo = pinfos.Head - let doc = if pinfo.HasDirectXmlComment || pinfo.XmlDoc.NonEmpty then Some pinfo.XmlDoc else None + + let doc = + if pinfo.HasDirectXmlComment || pinfo.XmlDoc.NonEmpty then + Some pinfo.XmlDoc + else + None + GetXmlCommentForItemAux doc infoReader m item - | Item.CustomOperation (_, _, Some minfo) + | Item.CustomOperation(_, _, Some minfo) | Item.CtorGroup(_, minfo :: _) - | Item.MethodGroup(_, minfo :: _, _) -> - GetXmlCommentForMethInfoItem infoReader m item minfo + | Item.MethodGroup(_, minfo :: _, _) -> GetXmlCommentForMethInfoItem infoReader m item minfo | Item.Types(_, tys) -> let doc = @@ -660,6 +714,7 @@ module internal SymbolHelpers = else None | _ -> None + GetXmlCommentForItemAux doc infoReader m item | Item.UnqualifiedType(tcrefs) -> @@ -671,43 +726,60 @@ module internal SymbolHelpers = else None | _ -> None + GetXmlCommentForItemAux doc infoReader m item | Item.ModuleOrNamespaces(modref :: _ as modrefs) -> let definiteNamespace = modrefs |> List.forall (fun modref -> modref.IsNamespace) + if not definiteNamespace then - let doc = if entityRefInThisAssembly g.compilingFSharpCore modref || modref.XmlDoc.NonEmpty then Some modref.XmlDoc else None + let doc = + if entityRefInThisAssembly g.compilingFSharpCore modref || modref.XmlDoc.NonEmpty then + Some modref.XmlDoc + else + None + GetXmlCommentForItemAux doc infoReader m item else GetXmlCommentForItemAux None infoReader m item - | Item.OtherName (container = argContainer) -> + | Item.OtherName(container = argContainer) -> let doc = match argContainer with | Some(ArgumentContainer.Method minfo) -> - if minfo.HasDirectXmlComment || minfo.XmlDoc.NonEmpty then Some minfo.XmlDoc else None + if minfo.HasDirectXmlComment || minfo.XmlDoc.NonEmpty then + Some minfo.XmlDoc + else + None | Some(ArgumentContainer.Type tcref) -> - if tyconRefUsesLocalXmlDoc g.compilingFSharpCore tcref || tcref.XmlDoc.NonEmpty then Some tcref.XmlDoc else None + if tyconRefUsesLocalXmlDoc g.compilingFSharpCore tcref || tcref.XmlDoc.NonEmpty then + Some tcref.XmlDoc + else + None | _ -> None + GetXmlCommentForItemAux doc infoReader m item - | Item.UnionCaseField (ucinfo, _) -> + | Item.UnionCaseField(ucinfo, _) -> let doc = - if tyconRefUsesLocalXmlDoc g.compilingFSharpCore ucinfo.TyconRef || ucinfo.UnionCase.XmlDoc.NonEmpty then + if + tyconRefUsesLocalXmlDoc g.compilingFSharpCore ucinfo.TyconRef + || ucinfo.UnionCase.XmlDoc.NonEmpty + then Some ucinfo.UnionCase.XmlDoc else None + GetXmlCommentForItemAux doc infoReader m item - | Item.SetterArg (_, item) -> - GetXmlCommentForItem infoReader m item + | Item.SetterArg(_, item) -> GetXmlCommentForItem infoReader m item // In all these cases, there is no direct XML documentation from F# comments - | Item.MethodGroup (_, [], _) - | Item.CtorGroup (_, []) + | Item.MethodGroup(_, [], _) + | Item.CtorGroup(_, []) | Item.ModuleOrNamespaces [] - | Item.Types (_, []) - | Item.CustomOperation (_, _, None) + | Item.Types(_, []) + | Item.CustomOperation(_, _, None) | Item.UnqualifiedType [] | Item.TypeVar _ | Item.Trait _ @@ -716,7 +788,7 @@ module internal SymbolHelpers = | Item.NewDef _ | Item.ILField _ | Item.DelegateCtor _ -> - //| _ -> + //| _ -> GetXmlCommentForItemAux None infoReader m item |> GetXmlDocFromLoader infoReader @@ -725,13 +797,15 @@ module internal SymbolHelpers = try let g = infoReader.g let amap = infoReader.amap + match item with | Item.Types(_, TType_app(tcref, _, _) :: _) | Item.UnqualifiedType(tcref :: _) -> let ty = generalizedTyconRef g tcref ExistsHeadTypeInEntireHierarchy g amap range0 ty g.tcref_System_Attribute | _ -> false - with _ -> false + with _ -> + false #if !NO_TYPEPROVIDERS @@ -741,7 +815,7 @@ module internal SymbolHelpers = match item with | Item.Types(_name, tys) -> match tys with - | [AppTy g (tcref, _typeInst)] -> + | [ AppTy g (tcref, _typeInst) ] -> if tcref.IsProvidedErasedTycon || tcref.IsProvidedGeneratedTycon then ValueSome tcref else @@ -755,13 +829,19 @@ module internal SymbolHelpers = match item with | Item.Types(_name, tys) -> match tys with - | [AppTy g (tcref, _typeInst)] -> + | [ AppTy g (tcref, _typeInst) ] -> if tcref.IsProvidedErasedTycon || tcref.IsProvidedGeneratedTycon then let typeBeforeArguments = match tcref.TypeReprInfo with | TProvidedTypeRepr info -> info.ProvidedType | _ -> failwith "unreachable" - let staticParameters = typeBeforeArguments.PApplyWithProvider((fun (typeBeforeArguments, provider) -> typeBeforeArguments.GetStaticParameters provider), range=m) + + let staticParameters = + typeBeforeArguments.PApplyWithProvider( + (fun (typeBeforeArguments, provider) -> typeBeforeArguments.GetStaticParameters provider), + range = m + ) + let staticParameters = staticParameters.PApplyArray(id, "GetStaticParameters", m) ValueSome staticParameters else @@ -774,12 +854,12 @@ module internal SymbolHelpers = match item with // Prefer the static parameters from the uninstantiated method info | Item.MethodGroup(_, _, Some minfo) -> - match minfo.ProvidedStaticParameterInfo with - | Some (_, staticParameters) -> ValueSome staticParameters + match minfo.ProvidedStaticParameterInfo with + | Some(_, staticParameters) -> ValueSome staticParameters | _ -> ValueNone - | Item.MethodGroup(_, [minfo], _) -> - match minfo.ProvidedStaticParameterInfo with - | Some (_, staticParameters) -> ValueSome staticParameters + | Item.MethodGroup(_, [ minfo ], _) -> + match minfo.ProvidedStaticParameterInfo with + | Some(_, staticParameters) -> ValueSome staticParameters | _ -> ValueNone | _ -> ValueNone @@ -796,73 +876,87 @@ module internal SymbolHelpers = /// Get the "F1 Keyword" associated with an item, for looking up documentation help indexes on the web let rec GetF1Keyword (g: TcGlobals) item = - let rec getKeywordForMethInfo (minfo : MethInfo) = + let rec getKeywordForMethInfo (minfo: MethInfo) = match minfo with | FSMeth(_, _, vref, _) -> match vref.TryDeclaringEntity with | Parent tcref -> - (tcref |> ticksAndArgCountTextOfTyconRef) + "." + vref.CompiledName g.CompilerGlobalState |> Some + (tcref |> ticksAndArgCountTextOfTyconRef) + + "." + + vref.CompiledName g.CompilerGlobalState + |> Some | ParentNone -> None - | ILMeth (_, minfo, _) -> + | ILMeth(_, minfo, _) -> let typeString = minfo.DeclaringTyconRef |> ticksAndArgCountTextOfTyconRef + let paramString = let nGenericParams = minfo.RawMetadata.GenericParams.Length - if nGenericParams > 0 then "``"+(nGenericParams.ToString()) else "" + + if nGenericParams > 0 then + "``" + (nGenericParams.ToString()) + else + "" + sprintf "%s.%s%s" typeString minfo.RawMetadata.Name paramString |> Some - | MethInfoWithModifiedReturnType(mi,_) -> getKeywordForMethInfo mi - | DefaultStructCtor _ -> None + | MethInfoWithModifiedReturnType(mi, _) -> getKeywordForMethInfo mi + | DefaultStructCtor _ -> None #if !NO_TYPEPROVIDERS | ProvidedMeth _ -> None #endif match item with - | Item.Value vref | Item.CustomBuilder (_, vref) -> + | Item.Value vref + | Item.CustomBuilder(_, vref) -> let v = vref.Deref + if v.IsModuleBinding && v.HasDeclaringEntity then let tyconRef = v.DeclaringEntity + let paramsString = match v.Typars with - | [] -> "" - | l -> "``"+(List.length l).ToString() + | [] -> "" + | l -> "``" + (List.length l).ToString() - sprintf "%s.%s%s" (tyconRef |> ticksAndArgCountTextOfTyconRef) (v.CompiledName g.CompilerGlobalState) paramsString |> Some + sprintf "%s.%s%s" (tyconRef |> ticksAndArgCountTextOfTyconRef) (v.CompiledName g.CompilerGlobalState) paramsString + |> Some else None - | Item.ActivePatternCase apref -> - GetF1Keyword g (Item.Value apref.ActivePatternVal) + | Item.ActivePatternCase apref -> GetF1Keyword g (Item.Value apref.ActivePatternVal) | Item.UnionCase(ucinfo, _) -> - (ucinfo.TyconRef |> ticksAndArgCountTextOfTyconRef) + "."+ucinfo.DisplayName |> Some + (ucinfo.TyconRef |> ticksAndArgCountTextOfTyconRef) + "." + ucinfo.DisplayName + |> Some - | Item.RecdField rfi -> - (rfi.TyconRef |> ticksAndArgCountTextOfTyconRef) + "." + rfi.DisplayName |> Some + | Item.RecdField rfi -> (rfi.TyconRef |> ticksAndArgCountTextOfTyconRef) + "." + rfi.DisplayName |> Some | Item.AnonRecdField _ -> None | Item.ILField finfo -> - match finfo with - | ILFieldInfo(tinfo, fdef) -> - (tinfo.TyconRefOfRawMetadata |> ticksAndArgCountTextOfTyconRef) + "." + fdef.Name |> Some + match finfo with + | ILFieldInfo(tinfo, fdef) -> + (tinfo.TyconRefOfRawMetadata |> ticksAndArgCountTextOfTyconRef) + + "." + + fdef.Name + |> Some #if !NO_TYPEPROVIDERS - | ProvidedField _ -> None + | ProvidedField _ -> None #endif | Item.Types(_, AppTy g (tcref, _) :: _) | Item.DelegateCtor(AppTy g (tcref, _)) - | Item.UnqualifiedType (tcref :: _) + | Item.UnqualifiedType(tcref :: _) | Item.ExnCase tcref -> // strip off any abbreviation match generalizedTyconRef g tcref with - | AppTy g (tcref, _) -> Some (ticksAndArgCountTextOfTyconRef tcref) + | AppTy g (tcref, _) -> Some(ticksAndArgCountTextOfTyconRef tcref) | _ -> None // Pathological cases of the above | Item.Types _ | Item.DelegateCtor _ - | Item.UnqualifiedType [] -> - None + | Item.UnqualifiedType [] -> None | Item.ModuleOrNamespaces modrefs -> match modrefs with @@ -877,12 +971,17 @@ module internal SymbolHelpers = // works similar to generation of xml-docs at tastops.fs, probably too similar // TODO: check if this code can be implemented using xml-doc generation functionality let prefix = path.AccessPath |> Seq.map fst |> String.concat "." - let fullName = if String.IsNullOrEmpty(prefix) then modref.CompiledName else prefix + "." + modref.CompiledName - Some fullName - ) + + let fullName = + if String.IsNullOrEmpty(prefix) then + modref.CompiledName + else + prefix + "." + modref.CompiledName + + Some fullName) #endif | _ -> modref.Deref.CompiledRepresentationForNamedType.FullName |> Some - | [] -> None // Pathological case of the above + | [] -> None // Pathological case of the above | Item.Property(info = pinfo :: _) -> match pinfo with @@ -890,13 +989,12 @@ module internal SymbolHelpers = | FSProp(_, _, _, Some vref) -> // per spec, extension members in F1 keywords are qualified with definition class match vref.TryDeclaringEntity with - | Parent tcref -> - (tcref |> ticksAndArgCountTextOfTyconRef)+"."+vref.PropertyName|> Some + | Parent tcref -> (tcref |> ticksAndArgCountTextOfTyconRef) + "." + vref.PropertyName |> Some | ParentNone -> None | ILProp(ILPropInfo(tinfo, pdef)) -> let tcref = tinfo.TyconRefOfRawMetadata - (tcref |> ticksAndArgCountTextOfTyconRef)+"."+pdef.Name |> Some + (tcref |> ticksAndArgCountTextOfTyconRef) + "." + pdef.Name |> Some | FSProp _ -> None #if !NO_TYPEPROVIDERS | ProvidedProp _ -> None @@ -905,16 +1003,16 @@ module internal SymbolHelpers = | Item.Event einfo -> match einfo with - | ILEvent _ -> + | ILEvent _ -> let tcref = einfo.DeclaringTyconRef - (tcref |> ticksAndArgCountTextOfTyconRef)+"."+einfo.EventName |> Some + (tcref |> ticksAndArgCountTextOfTyconRef) + "." + einfo.EventName |> Some | FSEvent(_, pinfo, _, _) -> match pinfo.ArbitraryValRef with | Some vref -> - // per spec, members in F1 keywords are qualified with definition class - match vref.TryDeclaringEntity with - | Parent tcref -> (tcref |> ticksAndArgCountTextOfTyconRef)+"."+vref.PropertyName|> Some - | ParentNone -> None + // per spec, members in F1 keywords are qualified with definition class + match vref.TryDeclaringEntity with + | Parent tcref -> (tcref |> ticksAndArgCountTextOfTyconRef) + "." + vref.PropertyName |> Some + | ParentNone -> None | None -> None #if !NO_TYPEPROVIDERS | ProvidedEvent _ -> None @@ -923,29 +1021,29 @@ module internal SymbolHelpers = match minfos with | [] -> None | FSMeth(_, _, vref, _) :: _ -> - match vref.TryDeclaringEntity with - | Parent tcref -> (tcref |> ticksAndArgCountTextOfTyconRef) + ".#ctor"|> Some - | ParentNone -> None + match vref.TryDeclaringEntity with + | Parent tcref -> (tcref |> ticksAndArgCountTextOfTyconRef) + ".#ctor" |> Some + | ParentNone -> None #if !NO_TYPEPROVIDERS | ProvidedMeth _ :: _ -> None #endif | minfo :: _ -> let tcref = minfo.DeclaringTyconRef - (tcref |> ticksAndArgCountTextOfTyconRef)+".#ctor" |> Some - | Item.CustomOperation (_, _, Some minfo) -> getKeywordForMethInfo minfo + (tcref |> ticksAndArgCountTextOfTyconRef) + ".#ctor" |> Some + | Item.CustomOperation(_, _, Some minfo) -> getKeywordForMethInfo minfo | Item.MethodGroup(_, _, Some minfo) -> getKeywordForMethInfo minfo | Item.MethodGroup(_, minfo :: _, _) -> getKeywordForMethInfo minfo - | Item.SetterArg (_, propOrField) -> GetF1Keyword g propOrField + | Item.SetterArg(_, propOrField) -> GetF1Keyword g propOrField | Item.MethodGroup(_, [], _) - | Item.CustomOperation (_, _, None) // "into" + | Item.CustomOperation(_, _, None) // "into" | Item.NewDef _ // "let x$yz = ..." - no keyword | Item.OtherName _ // no keyword on named parameters | Item.Trait _ | Item.UnionCaseField _ | Item.TypeVar _ | Item.ImplicitOp _ - | Item.ActivePatternResult _ // "let (|Foo|Bar|) = .. Fo$o ..." - no keyword - -> None + | Item.ActivePatternResult _ -> // "let (|Foo|Bar|) = .. Fo$o ..." - no keyword + None /// Select the items that participate in a MethodGroup. // @@ -954,27 +1052,42 @@ module internal SymbolHelpers = // the VS integration. let SelectMethodGroupItems2 g (m: range) (item: ItemWithInst) : ItemWithInst list = ignore m + match item.Item with | Item.MethodGroup(nm, minfos, orig) -> - minfos |> List.map (fun minfo -> { Item = Item.MethodGroup(nm, [minfo], orig); TyparInstantiation = item.TyparInstantiation }) + minfos + |> List.map (fun minfo -> + { + Item = Item.MethodGroup(nm, [ minfo ], orig) + TyparInstantiation = item.TyparInstantiation + }) | Item.CtorGroup(nm, cinfos) -> - cinfos |> List.map (fun minfo -> { Item = Item.CtorGroup(nm, [minfo]); TyparInstantiation = item.TyparInstantiation }) - | Item.DelegateCtor _ -> [item] + cinfos + |> List.map (fun minfo -> + { + Item = Item.CtorGroup(nm, [ minfo ]) + TyparInstantiation = item.TyparInstantiation + }) + | Item.DelegateCtor _ -> [ item ] | Item.NewDef _ | Item.ILField _ -> [] | Item.Event _ -> [] - | Item.RecdField rfinfo -> if isForallFunctionTy g rfinfo.FieldType then [item] else [] - | Item.Value v -> if isForallFunctionTy g v.Type then [item] else [] - | Item.UnionCase(ucr, _) -> if not ucr.UnionCase.IsNullary then [item] else [] - | Item.ExnCase ecr -> if isNil (recdFieldsOfExnDefRef ecr) then [] else [item] + | Item.RecdField rfinfo -> + if isForallFunctionTy g rfinfo.FieldType then + [ item ] + else + [] + | Item.Value v -> if isForallFunctionTy g v.Type then [ item ] else [] + | Item.UnionCase(ucr, _) -> if not ucr.UnionCase.IsNullary then [ item ] else [] + | Item.ExnCase ecr -> if isNil (recdFieldsOfExnDefRef ecr) then [] else [ item ] | Item.Property(info = pinfos) -> let pinfo = List.head pinfos - if pinfo.IsIndexer then [item] else [] + if pinfo.IsIndexer then [ item ] else [] #if !NO_TYPEPROVIDERS - | ItemIsWithStaticArguments m g _ -> [item] // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them + | ItemIsWithStaticArguments m g _ -> [ item ] // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them #endif - | Item.CustomOperation(_name, _helpText, _minfo) -> [item] - | Item.Trait _ -> [item] + | Item.CustomOperation(_name, _helpText, _minfo) -> [ item ] + | Item.Trait _ -> [ item ] | Item.TypeVar _ -> [] | Item.CustomBuilder _ -> [] // These are not items that can participate in a method group diff --git a/src/Compiler/Symbols/SymbolPatterns.fs b/src/Compiler/Symbols/SymbolPatterns.fs index 44b77965a28..cdb38174660 100644 --- a/src/Compiler/Symbols/SymbolPatterns.fs +++ b/src/Compiler/Symbols/SymbolPatterns.fs @@ -11,124 +11,168 @@ open FSharp.Compiler.Syntax module FSharpSymbolPatterns = module Option = - let attempt f = try Some(f()) with _ -> None - - let hasModuleSuffixAttribute (entity: FSharpEntity) = - entity.TryGetAttribute() - |> Option.bind (fun a -> - Option.attempt (fun _ -> a.ConstructorArguments) - |> Option.bind (fun args -> args |> Seq.tryPick (fun (_, arg) -> + let attempt f = + try + Some(f ()) + with _ -> + None + + let hasModuleSuffixAttribute (entity: FSharpEntity) = + entity.TryGetAttribute() + |> Option.bind (fun a -> + Option.attempt (fun _ -> a.ConstructorArguments) + |> Option.bind (fun args -> + args + |> Seq.tryPick (fun (_, arg) -> let res = match arg with - | :? int32 as arg when arg = int CompilationRepresentationFlags.ModuleSuffix -> - Some() - | :? CompilationRepresentationFlags as arg when arg = CompilationRepresentationFlags.ModuleSuffix -> - Some() - | _ -> - None + | :? int32 as arg when arg = int CompilationRepresentationFlags.ModuleSuffix -> Some() + | :? CompilationRepresentationFlags as arg when arg = CompilationRepresentationFlags.ModuleSuffix -> Some() + | _ -> None + res))) - |> Option.isSome + |> Option.isSome let (|AbbreviatedType|_|) (entity: FSharpEntity) = - if entity.IsFSharpAbbreviation then Some entity.AbbreviatedType - else None + if entity.IsFSharpAbbreviation then + Some entity.AbbreviatedType + else + None let (|TypeWithDefinition|_|) (ty: FSharpType) = - if ty.HasTypeDefinition then Some ty.TypeDefinition - else None + if ty.HasTypeDefinition then + Some ty.TypeDefinition + else + None let rec getEntityAbbreviatedType (entity: FSharpEntity) = if entity.IsFSharpAbbreviation then match entity.AbbreviatedType with | TypeWithDefinition def -> getEntityAbbreviatedType def | abbreviatedTy -> entity, Some abbreviatedTy - else entity, None + else + entity, None let (|Attribute|_|) (entity: FSharpEntity) = let isAttribute (entity: FSharpEntity) = let getBaseType (entity: FSharpEntity) = - try + try match entity.BaseType with - | Some (TypeWithDefinition def) -> Some def + | Some(TypeWithDefinition def) -> Some def | _ -> None - with _ -> None + with _ -> + None let rec isAttributeType (ty: FSharpEntity option) = match ty with | None -> false | Some ty -> - try ty.FullName = "System.Attribute" || isAttributeType (getBaseType ty) - with _ -> false + try + ty.FullName = "System.Attribute" || isAttributeType (getBaseType ty) + with _ -> + false + isAttributeType (Some entity) + if isAttribute entity then Some() else None let (|ValueType|_|) (e: FSharpEntity) = - if e.IsEnum || e.IsValueType || e.HasAttribute() then Some() - else None + if + e.IsEnum + || e.IsValueType + || e.HasAttribute() + then + Some() + else + None #if !NO_TYPEPROVIDERS - let (|Class|_|) (original: FSharpEntity, abbreviated: FSharpEntity, _) = - if abbreviated.IsClass - && (not abbreviated.IsStaticInstantiation || original.IsFSharpAbbreviation) then Some() - else None + let (|Class|_|) (original: FSharpEntity, abbreviated: FSharpEntity, _) = + if + abbreviated.IsClass + && (not abbreviated.IsStaticInstantiation || original.IsFSharpAbbreviation) + then + Some() + else + None #else - let (|Class|_|) (original: FSharpEntity, abbreviated: FSharpEntity, _) = - if abbreviated.IsClass && original.IsFSharpAbbreviation then Some() - else None -#endif + let (|Class|_|) (original: FSharpEntity, abbreviated: FSharpEntity, _) = + if abbreviated.IsClass && original.IsFSharpAbbreviation then + Some() + else + None +#endif - let (|Record|_|) (e: FSharpEntity) = if e.IsFSharpRecord then Some() else None + let (|Record|_|) (e: FSharpEntity) = + if e.IsFSharpRecord then Some() else None - let (|UnionType|_|) (e: FSharpEntity) = if e.IsFSharpUnion then Some() else None + let (|UnionType|_|) (e: FSharpEntity) = + if e.IsFSharpUnion then Some() else None let (|Delegate|_|) (e: FSharpEntity) = if e.IsDelegate then Some() else None - let (|FSharpException|_|) (e: FSharpEntity) = if e.IsFSharpExceptionDeclaration then Some() else None + let (|FSharpException|_|) (e: FSharpEntity) = + if e.IsFSharpExceptionDeclaration then Some() else None let (|Interface|_|) (e: FSharpEntity) = if e.IsInterface then Some() else None let (|AbstractClass|_|) (e: FSharpEntity) = - if e.HasAttribute() then Some() else None - - let (|FSharpType|_|) (e: FSharpEntity) = - if e.IsDelegate || e.IsFSharpExceptionDeclaration || e.IsFSharpRecord || e.IsFSharpUnion - || e.IsInterface || e.IsMeasure - || (e.IsFSharp && e.IsOpaque && not e.IsFSharpModule && not e.IsNamespace) then Some() - else None + if e.HasAttribute() then + Some() + else + None + + let (|FSharpType|_|) (e: FSharpEntity) = + if + e.IsDelegate + || e.IsFSharpExceptionDeclaration + || e.IsFSharpRecord + || e.IsFSharpUnion + || e.IsInterface + || e.IsMeasure + || (e.IsFSharp && e.IsOpaque && not e.IsFSharpModule && not e.IsNamespace) + then + Some() + else + None #if !NO_TYPEPROVIDERS let (|ProvidedType|_|) (e: FSharpEntity) = - if (e.IsProvided || e.IsProvidedAndErased || e.IsProvidedAndGenerated) && e.CompiledName = e.DisplayName then + if + (e.IsProvided || e.IsProvidedAndErased || e.IsProvidedAndGenerated) + && e.CompiledName = e.DisplayName + then Some() - else None -#endif + else + None +#endif let (|ByRef|_|) (e: FSharpEntity) = if e.IsByRef then Some() else None let (|Array|_|) (e: FSharpEntity) = if e.IsArrayType then Some() else None - let (|FSharpModule|_|) (entity: FSharpEntity) = if entity.IsFSharpModule then Some() else None + let (|FSharpModule|_|) (entity: FSharpEntity) = + if entity.IsFSharpModule then Some() else None - let (|Namespace|_|) (entity: FSharpEntity) = if entity.IsNamespace then Some() else None + let (|Namespace|_|) (entity: FSharpEntity) = + if entity.IsNamespace then Some() else None -#if !NO_TYPEPROVIDERS - let (|ProvidedAndErasedType|_|) (entity: FSharpEntity) = if entity.IsProvidedAndErased then Some() else None +#if !NO_TYPEPROVIDERS + let (|ProvidedAndErasedType|_|) (entity: FSharpEntity) = + if entity.IsProvidedAndErased then Some() else None #endif let (|Enum|_|) (entity: FSharpEntity) = if entity.IsEnum then Some() else None - let (|Tuple|_|) (ty: FSharpType) = - if ty.IsTupleType then Some() else None + let (|Tuple|_|) (ty: FSharpType) = if ty.IsTupleType then Some() else None - let (|RefCell|_|) (ty: FSharpType) = + let (|RefCell|_|) (ty: FSharpType) = match ty.StripAbbreviations() with - | TypeWithDefinition def when - def.IsFSharpRecord && def.FullName = "Microsoft.FSharp.Core.FSharpRef`1" -> Some() + | TypeWithDefinition def when def.IsFSharpRecord && def.FullName = "Microsoft.FSharp.Core.FSharpRef`1" -> Some() | _ -> None - let (|FunctionType|_|) (ty: FSharpType) = - if ty.IsFunctionType then Some() - else None + let (|FunctionType|_|) (ty: FSharpType) = + if ty.IsFunctionType then Some() else None let (|Pattern|_|) (symbol: FSharpSymbol) = match symbol with @@ -138,31 +182,32 @@ module FSharpSymbolPatterns = let (|Field|_|) (symbol: FSharpSymbol) = match symbol with - | :? FSharpField as field -> Some (field, field.FieldType.StripAbbreviations()) + | :? FSharpField as field -> Some(field, field.FieldType.StripAbbreviations()) | _ -> None - let (|MutableVar|_|) (symbol: FSharpSymbol) = - let isMutable = + let (|MutableVar|_|) (symbol: FSharpSymbol) = + let isMutable = match symbol with | :? FSharpField as field -> field.IsMutable && not field.IsLiteral | :? FSharpMemberOrFunctionOrValue as func -> func.IsMutable | _ -> false + if isMutable then Some() else None /// Entity (originalEntity, abbreviatedEntity, abbreviatedTy) let (|FSharpEntity|_|) (symbol: FSharpSymbol) = match symbol with - | :? FSharpEntity as entity -> + | :? FSharpEntity as entity -> let abbreviatedEntity, abbreviatedTy = getEntityAbbreviatedType entity - Some (entity, abbreviatedEntity, abbreviatedTy) + Some(entity, abbreviatedEntity, abbreviatedTy) | _ -> None - let (|Parameter|_|) (symbol: FSharpSymbol) = + let (|Parameter|_|) (symbol: FSharpSymbol) = match symbol with | :? FSharpParameter -> Some() | _ -> None - let (|UnionCase|_|) (e: FSharpSymbol) = + let (|UnionCase|_|) (e: FSharpSymbol) = match e with | :? FSharpUnionCase as uc -> Some uc | _ -> None @@ -170,7 +215,7 @@ module FSharpSymbolPatterns = let (|RecordField|_|) (e: FSharpSymbol) = match e with | :? FSharpField as field -> - match field.DeclaringEntity with + match field.DeclaringEntity with | None -> None | Some e -> if e.IsFSharpRecord then Some field else None | _ -> None @@ -189,21 +234,28 @@ module FSharpSymbolPatterns = /// Constructor (enclosingEntity) let (|Constructor|_|) (func: FSharpMemberOrFunctionOrValue) = match func.CompiledName with - | ".ctor" | ".cctor" -> func.DeclaringEntity + | ".ctor" + | ".cctor" -> func.DeclaringEntity | _ -> None let (|Function|_|) excluded (func: FSharpMemberOrFunctionOrValue) = - try let ty = func.FullType.StripAbbreviations() - if ty.IsFunctionType - && not func.IsPropertyGetterMethod - && not func.IsPropertySetterMethod - && not excluded - && not (PrettyNaming.IsOperatorDisplayName func.DisplayName) then Some() - else None - with _ -> None + try + let ty = func.FullType.StripAbbreviations() + + if + ty.IsFunctionType + && not func.IsPropertyGetterMethod + && not func.IsPropertySetterMethod + && not excluded + && not (PrettyNaming.IsOperatorDisplayName func.DisplayName) + then + Some() + else + None + with _ -> + None let (|ExtensionMember|_|) (func: FSharpMemberOrFunctionOrValue) = if func.IsExtensionMember then Some() else None - let (|Event|_|) (func: FSharpMemberOrFunctionOrValue) = - if func.IsEvent then Some () else None \ No newline at end of file + let (|Event|_|) (func: FSharpMemberOrFunctionOrValue) = if func.IsEvent then Some() else None diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index a2407b7fad5..78ade4e14b7 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -28,36 +28,59 @@ open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TypeHierarchy open FSharp.Compiler.CheckExpressionsOps -type FSharpAccessibility(a:Accessibility, ?isProtected) = - let isProtected = defaultArg isProtected false +type FSharpAccessibility(a: Accessibility, ?isProtected) = + let isProtected = defaultArg isProtected false - let isInternalCompPath x = - match x with - | CompPath(ILScopeRef.Local, _, []) -> true + let isInternalCompPath x = + match x with + | CompPath(ILScopeRef.Local, _, []) -> true | _ -> false - let (|Public|Internal|Private|) (TAccess p) = - match p with - | [] -> Public - | _ when List.forall isInternalCompPath p -> Internal + let (|Public|Internal|Private|) (TAccess p) = + match p with + | [] -> Public + | _ when List.forall isInternalCompPath p -> Internal | _ -> Private - member _.IsPublic = not isProtected && (match a with TAccess [] -> true | _ -> false) + member _.IsPublic = + not isProtected + && (match a with + | TAccess [] -> true + | _ -> false) - member _.IsPrivate = not isProtected && (match a with Private -> true | _ -> false) + member _.IsPrivate = + not isProtected + && (match a with + | Private -> true + | _ -> false) - member _.IsInternal = not isProtected && (match a with Internal -> true | _ -> false) + member _.IsInternal = + not isProtected + && (match a with + | Internal -> true + | _ -> false) member _.IsProtected = isProtected member internal _.Contents = a - override _.ToString() = + override _.ToString() = let (TAccess paths) = a - let mangledTextOfCompPath (CompPath(scoref, _, path)) = getNameOfScopeRef scoref + "/" + textOfPath (List.map fst path) + + let mangledTextOfCompPath (CompPath(scoref, _, path)) = + getNameOfScopeRef scoref + "/" + textOfPath (List.map fst path) + String.concat ";" (List.map mangledTextOfCompPath paths) -type SymbolEnv(g: TcGlobals, thisCcu: CcuThunk, thisCcuTyp: ModuleOrNamespaceType option, tcImports: TcImports, amap: Import.ImportMap, infoReader: InfoReader) = +type SymbolEnv + ( + g: TcGlobals, + thisCcu: CcuThunk, + thisCcuTyp: ModuleOrNamespaceType option, + tcImports: TcImports, + amap: Import.ImportMap, + infoReader: InfoReader + ) = let tcVal = LightweightTcValForUsingInBuildMethodCall g @@ -75,159 +98,174 @@ type SymbolEnv(g: TcGlobals, thisCcu: CcuThunk, thisCcuTyp: ModuleOrNamespaceTyp member _.tcValF = tcVal [] -module Impl = - let protect f = - DiagnosticsLogger.protectAssemblyExplorationF - (fun (asmName, path) -> invalidOp (sprintf "The entity or value '%s' does not exist or is in an unresolved assembly. You may need to add a reference to assembly '%s'" path asmName)) - f - - let makeReadOnlyCollection (arr: seq<'T>) = +module Impl = + let protect f = + DiagnosticsLogger.protectAssemblyExplorationF + (fun (asmName, path) -> + invalidOp ( + sprintf + "The entity or value '%s' does not exist or is in an unresolved assembly. You may need to add a reference to assembly '%s'" + path + asmName + )) + f + + let makeReadOnlyCollection (arr: seq<'T>) = System.Collections.ObjectModel.ReadOnlyCollection<_>(Seq.toArray arr) :> IList<_> - - let makeXmlDoc (doc: XmlDoc) = - FSharpXmlDoc.FromXmlText doc - + + let makeXmlDoc (doc: XmlDoc) = FSharpXmlDoc.FromXmlText doc + let makeElaboratedXmlDoc (doc: XmlDoc) = makeReadOnlyCollection (doc.GetElaboratedXmlLines()) - - let rescopeEntity optViewedCcu (entity: Entity) = - match optViewedCcu with + + let rescopeEntity optViewedCcu (entity: Entity) = + match optViewedCcu with | None -> mkLocalEntityRef entity - | Some viewedCcu -> - match tryRescopeEntity viewedCcu entity with - | ValueNone -> mkLocalEntityRef entity - | ValueSome eref -> eref + | Some viewedCcu -> + match tryRescopeEntity viewedCcu entity with + | ValueNone -> mkLocalEntityRef entity + | ValueSome eref -> eref - let entityIsUnresolved(entity:EntityRef) = + let entityIsUnresolved (entity: EntityRef) = match entity with - | ERefNonLocal(NonLocalEntityRef(ccu, _)) -> - ccu.IsUnresolvedReference && entity.TryDeref.IsNone + | ERefNonLocal(NonLocalEntityRef(ccu, _)) -> ccu.IsUnresolvedReference && entity.TryDeref.IsNone | _ -> false - let checkEntityIsResolved(entity:EntityRef) = - if entityIsUnresolved entity then + let checkEntityIsResolved (entity: EntityRef) = + if entityIsUnresolved entity then let poorQualifiedName = - if entity.nlr.AssemblyName = "mscorlib" then + if entity.nlr.AssemblyName = "mscorlib" then entity.nlr.DisplayName + ", mscorlib" - else + else entity.nlr.DisplayName + ", " + entity.nlr.Ccu.AssemblyName + invalidOp (sprintf "The entity '%s' does not exist or is in an unresolved assembly." poorQualifiedName) /// Checking accessibility that arise from different compilations needs more care - this is a duplicate of the F# compiler code for this case - let checkForCrossProjectAccessibility (ilg: ILGlobals) (thisCcu2:CcuThunk, ad2) (thisCcu1, taccess1) = - match ad2 with + let checkForCrossProjectAccessibility (ilg: ILGlobals) (thisCcu2: CcuThunk, ad2) (thisCcu1, taccess1) = + match ad2 with | AccessibleFrom(cpaths2, _) -> - let nameOfScoRef (thisCcu:CcuThunk) scoref = - match scoref with - | ILScopeRef.Local -> thisCcu.AssemblyName - | ILScopeRef.Assembly aref -> aref.Name + let nameOfScoRef (thisCcu: CcuThunk) scoref = + match scoref with + | ILScopeRef.Local -> thisCcu.AssemblyName + | ILScopeRef.Assembly aref -> aref.Name | ILScopeRef.Module mref -> mref.Name | ILScopeRef.PrimaryAssembly -> ilg.primaryAssemblyName + let canAccessCompPathFromCrossProject (CompPath(scoref1, _, cpath1)) (CompPath(scoref2, _, cpath2)) = - let rec loop p1 p2 = - match p1, p2 with - | (a1, k1) :: rest1, (a2, k2) :: rest2 -> (a1=a2) && (k1=k2) && loop rest1 rest2 - | [], _ -> true + let rec loop p1 p2 = + match p1, p2 with + | (a1, k1) :: rest1, (a2, k2) :: rest2 -> (a1 = a2) && (k1 = k2) && loop rest1 rest2 + | [], _ -> true | _ -> false // cpath1 is longer - loop cpath1 cpath2 && - nameOfScoRef thisCcu1 scoref1 = nameOfScoRef thisCcu2 scoref2 - let canAccessFromCrossProject (TAccess x1) cpath2 = x1 |> List.forall (fun cpath1 -> canAccessCompPathFromCrossProject cpath1 cpath2) - cpaths2 |> List.exists (canAccessFromCrossProject taccess1) - | _ -> true // otherwise use the normal check + loop cpath1 cpath2 + && nameOfScoRef thisCcu1 scoref1 = nameOfScoRef thisCcu2 scoref2 + + let canAccessFromCrossProject (TAccess x1) cpath2 = + x1 + |> List.forall (fun cpath1 -> canAccessCompPathFromCrossProject cpath1 cpath2) + + cpaths2 |> List.exists (canAccessFromCrossProject taccess1) + | _ -> true // otherwise use the normal check /// Convert an IL member accessibility into an F# accessibility - let getApproxFSharpAccessibilityOfMember (declaringEntity: EntityRef) (ilAccess: ILMemberAccess) = - match ilAccess with + let getApproxFSharpAccessibilityOfMember (declaringEntity: EntityRef) (ilAccess: ILMemberAccess) = + match ilAccess with | ILMemberAccess.CompilerControlled - | ILMemberAccess.FamilyAndAssembly - | ILMemberAccess.Assembly -> - taccessPrivate (CompPath(declaringEntity.CompilationPath.ILScopeRef, SyntaxAccess.Unknown, [])) + | ILMemberAccess.FamilyAndAssembly + | ILMemberAccess.Assembly -> taccessPrivate (CompPath(declaringEntity.CompilationPath.ILScopeRef, SyntaxAccess.Unknown, [])) - | ILMemberAccess.Private -> - taccessPrivate declaringEntity.CompilationPath + | ILMemberAccess.Private -> taccessPrivate declaringEntity.CompilationPath // This is an approximation - the thing may actually be nested in a private class, in which case it is not actually "public" | ILMemberAccess.Public // This is an approximation - the thing is actually "protected", but F# accessibilities can't express "protected", so we report it as "public" | ILMemberAccess.FamilyOrAssembly - | ILMemberAccess.Family -> - taccessPublic + | ILMemberAccess.Family -> taccessPublic /// Convert an IL type definition accessibility into an F# accessibility - let getApproxFSharpAccessibilityOfEntity (entity: EntityRef) = - match metadataOfTycon entity.Deref with + let getApproxFSharpAccessibilityOfEntity (entity: EntityRef) = + match metadataOfTycon entity.Deref with #if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata _info -> + | ProvidedTypeMetadata _info -> // This is an approximation - for generative type providers some type definitions can be private. taccessPublic #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> - match td.Access with - | ILTypeDefAccess.Public - | ILTypeDefAccess.Nested ILMemberAccess.Public -> taccessPublic - | ILTypeDefAccess.Private -> taccessPrivate (CompPath(entity.CompilationPath.ILScopeRef, SyntaxAccess.Unknown, [])) + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> + match td.Access with + | ILTypeDefAccess.Public + | ILTypeDefAccess.Nested ILMemberAccess.Public -> taccessPublic + | ILTypeDefAccess.Private -> taccessPrivate (CompPath(entity.CompilationPath.ILScopeRef, SyntaxAccess.Unknown, [])) | ILTypeDefAccess.Nested nested -> getApproxFSharpAccessibilityOfMember entity nested - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - entity.Accessibility + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.Accessibility - let getLiteralValue = function - | Some lv -> + let getLiteralValue = + function + | Some lv -> match lv with - | Const.Bool v -> Some(box v) - | Const.SByte v -> Some(box v) - | Const.Byte v -> Some(box v) - | Const.Int16 v -> Some(box v) - | Const.UInt16 v -> Some(box v) - | Const.Int32 v -> Some(box v) - | Const.UInt32 v -> Some(box v) - | Const.Int64 v -> Some(box v) - | Const.UInt64 v -> Some(box v) - | Const.IntPtr v -> Some(box v) + | Const.Bool v -> Some(box v) + | Const.SByte v -> Some(box v) + | Const.Byte v -> Some(box v) + | Const.Int16 v -> Some(box v) + | Const.UInt16 v -> Some(box v) + | Const.Int32 v -> Some(box v) + | Const.UInt32 v -> Some(box v) + | Const.Int64 v -> Some(box v) + | Const.UInt64 v -> Some(box v) + | Const.IntPtr v -> Some(box v) | Const.UIntPtr v -> Some(box v) - | Const.Single v -> Some(box v) - | Const.Double v -> Some(box v) - | Const.Char v -> Some(box v) - | Const.String v -> Some(box v) + | Const.Single v -> Some(box v) + | Const.Double v -> Some(box v) + | Const.Char v -> Some(box v) + | Const.String v -> Some(box v) | Const.Decimal v -> Some(box v) | Const.Unit - | Const.Zero -> None + | Const.Zero -> None | None -> None - - let getXmlDocSigForEntity (cenv: SymbolEnv) (ent:EntityRef)= + let getXmlDocSigForEntity (cenv: SymbolEnv) (ent: EntityRef) = match GetXmlDocSigOfEntityRef cenv.infoReader ent.Range ent with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" -type FSharpDisplayContext(denv: TcGlobals -> DisplayEnv) = +type FSharpDisplayContext(denv: TcGlobals -> DisplayEnv) = member _.Contents g = denv g - static member Empty = FSharpDisplayContext DisplayEnv.Empty + static member Empty = FSharpDisplayContext DisplayEnv.Empty member _.WithShortTypeNames shortNames = - FSharpDisplayContext(fun g -> { denv g with shortTypeNames = shortNames }) - - member _.WithPrefixGenericParameters () = - FSharpDisplayContext(fun g -> { denv g with genericParameterStyle = GenericParameterStyle.Prefix } ) - - member _.WithSuffixGenericParameters () = - FSharpDisplayContext(fun g -> { denv g with genericParameterStyle = GenericParameterStyle.Suffix } ) + FSharpDisplayContext(fun g -> + { denv g with + shortTypeNames = shortNames + }) + + member _.WithPrefixGenericParameters() = + FSharpDisplayContext(fun g -> + { denv g with + genericParameterStyle = GenericParameterStyle.Prefix + }) + + member _.WithSuffixGenericParameters() = + FSharpDisplayContext(fun g -> + { denv g with + genericParameterStyle = GenericParameterStyle.Suffix + }) // delay the realization of 'item' in case it is unresolved type FSharpSymbol(cenv: SymbolEnv, item: unit -> Item, access: FSharpSymbol -> CcuThunk -> AccessorDomain -> bool) = - member x.Assembly = - let ccu = defaultArg (SymbolHelpers.ccuOfItem cenv.g x.Item) cenv.thisCcu + member x.Assembly = + let ccu = defaultArg (SymbolHelpers.ccuOfItem cenv.g x.Item) cenv.thisCcu FSharpAssembly(cenv, ccu) member x.IsAccessible(rights: FSharpAccessibilityRights) = access x rights.ThisCcu rights.Contents member x.IsExplicitlySuppressed = SymbolHelpers.IsExplicitlySuppressed cenv.g x.Item - member x.FullName = SymbolHelpers.FullNameOfItem cenv.g x.Item + member x.FullName = SymbolHelpers.FullNameOfItem cenv.g x.Item member x.DeclarationLocation = SymbolHelpers.rangeOfItem cenv.g None x.Item @@ -235,152 +273,163 @@ type FSharpSymbol(cenv: SymbolEnv, item: unit -> Item, access: FSharpSymbol -> C member x.SignatureLocation = SymbolHelpers.rangeOfItem cenv.g (Some true) x.Item - member x.IsEffectivelySameAs(other:FSharpSymbol) = + member x.IsEffectivelySameAs(other: FSharpSymbol) = x.Equals other || ItemsAreEffectivelyEqual cenv.g x.Item other.Item - member x.GetEffectivelySameAsHash() = ItemsAreEffectivelyEqualHash cenv.g x.Item + member x.GetEffectivelySameAsHash() = + ItemsAreEffectivelyEqualHash cenv.g x.Item member internal _.SymbolEnv = cenv - member internal _.Item = item() + member internal _.Item = item () member _.DisplayNameCore = item().DisplayNameCore member _.DisplayName = item().DisplayName - // This is actually overridden in all cases below. However some symbols are still just of type FSharpSymbol, + // This is actually overridden in all cases below. However some symbols are still just of type FSharpSymbol, // see 'FSharpSymbol.Create' further below. override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpSymbol as otherSymbol -> ItemsAreEffectivelyEqual cenv.g x.Item otherSymbol.Item - | _ -> false + box x === other + || match other with + | :? FSharpSymbol as otherSymbol -> ItemsAreEffectivelyEqual cenv.g x.Item otherSymbol.Item + | _ -> false - override x.GetHashCode() = hash x.ImplementationLocation + override x.GetHashCode() = hash x.ImplementationLocation - override x.ToString() = "symbol " + (try item().DisplayNameCore with _ -> "?") + override x.ToString() = + "symbol " + + (try + item().DisplayNameCore + with _ -> + "?") // TODO: there are several cases where we may need to report more interesting // symbol information below. By default we return a vanilla symbol. - static member Create(g, thisCcu, thisCcuTyp, tcImports, item): FSharpSymbol = + static member Create(g, thisCcu, thisCcuTyp, tcImports, item) : FSharpSymbol = FSharpSymbol.Create(SymbolEnv(g, thisCcu, Some thisCcuTyp, tcImports), item) - static member Create(cenv, item): FSharpSymbol = - let dflt() = FSharpSymbol(cenv, (fun () -> item), (fun _ _ _ -> true)) + static member Create(cenv, item) : FSharpSymbol = + let dflt () = + FSharpSymbol(cenv, (fun () -> item), (fun _ _ _ -> true)) + match item with | Item.Value v when v.Deref.IsClassConstructor -> - FSharpMemberOrFunctionOrValue(cenv, C (FSMeth(cenv.g, generalizeTyconRef cenv.g v.DeclaringEntity |> snd, v, None)), item) :> _ + FSharpMemberOrFunctionOrValue(cenv, C(FSMeth(cenv.g, generalizeTyconRef cenv.g v.DeclaringEntity |> snd, v, None)), item) :> _ | Item.Value v -> FSharpMemberOrFunctionOrValue(cenv, V v, item) :> _ - | Item.UnionCase (uinfo, _) -> FSharpUnionCase(cenv, uinfo.UnionCaseRef) :> _ - | Item.ExnCase tcref -> FSharpEntity(cenv, tcref) :>_ + | Item.UnionCase(uinfo, _) -> FSharpUnionCase(cenv, uinfo.UnionCaseRef) :> _ + | Item.ExnCase tcref -> FSharpEntity(cenv, tcref) :> _ | Item.RecdField rfinfo -> FSharpField(cenv, RecdOrClass rfinfo.RecdFieldRef) :> _ - | Item.UnionCaseField (UnionCaseInfo (_, ucref), index) -> FSharpField (cenv, Union (ucref, index)) :> _ + | Item.UnionCaseField(UnionCaseInfo(_, ucref), index) -> FSharpField(cenv, Union(ucref, index)) :> _ | Item.ILField finfo -> FSharpField(cenv, ILField finfo) :> _ - | Item.AnonRecdField (anonInfo, tinst, n, m) -> FSharpField(cenv, AnonField (anonInfo, tinst, n, m)) :> _ - - | Item.Event einfo -> - FSharpMemberOrFunctionOrValue(cenv, E einfo, item) :> _ - - | Item.Property(info = pinfo :: _) -> - FSharpMemberOrFunctionOrValue(cenv, P pinfo, item) :> _ - - | Item.MethodGroup(_, minfo :: _, _) -> - FSharpMemberOrFunctionOrValue(cenv, M minfo, item) :> _ + | Item.AnonRecdField(anonInfo, tinst, n, m) -> FSharpField(cenv, AnonField(anonInfo, tinst, n, m)) :> _ + + | Item.Event einfo -> FSharpMemberOrFunctionOrValue(cenv, E einfo, item) :> _ + + | Item.Property(info = pinfo :: _) -> FSharpMemberOrFunctionOrValue(cenv, P pinfo, item) :> _ + + | Item.MethodGroup(_, minfo :: _, _) -> FSharpMemberOrFunctionOrValue(cenv, M minfo, item) :> _ - | Item.CtorGroup(_, cinfo :: _) -> - FSharpMemberOrFunctionOrValue(cenv, C cinfo, item) :> _ + | Item.CtorGroup(_, cinfo :: _) -> FSharpMemberOrFunctionOrValue(cenv, C cinfo, item) :> _ - | Item.DelegateCtor (AbbrevOrAppTy(tcref, tyargs)) - | Item.Types(_, AbbrevOrAppTy(tcref, tyargs) :: _) -> - FSharpEntity(cenv, tcref, tyargs) :>_ + | Item.DelegateCtor(AbbrevOrAppTy(tcref, tyargs)) + | Item.Types(_, AbbrevOrAppTy(tcref, tyargs) :: _) -> FSharpEntity(cenv, tcref, tyargs) :> _ - | Item.UnqualifiedType(tcref :: _) -> - FSharpEntity(cenv, tcref) :> _ + | Item.UnqualifiedType(tcref :: _) -> FSharpEntity(cenv, tcref) :> _ - | Item.ModuleOrNamespaces(modref :: _) -> - FSharpEntity(cenv, modref) :> _ + | Item.ModuleOrNamespaces(modref :: _) -> FSharpEntity(cenv, modref) :> _ - | Item.SetterArg (_id, item) -> FSharpSymbol.Create(cenv, item) + | Item.SetterArg(_id, item) -> FSharpSymbol.Create(cenv, item) - | Item.CustomOperation (_customOpName, _, Some minfo) -> - FSharpMemberOrFunctionOrValue(cenv, M minfo, item) :> _ + | Item.CustomOperation(_customOpName, _, Some minfo) -> FSharpMemberOrFunctionOrValue(cenv, M minfo, item) :> _ - | Item.CustomBuilder (_, vref) -> - FSharpMemberOrFunctionOrValue(cenv, V vref, item) :> _ + | Item.CustomBuilder(_, vref) -> FSharpMemberOrFunctionOrValue(cenv, V vref, item) :> _ - | Item.TypeVar (_, tp) -> - FSharpGenericParameter(cenv, tp) :> _ + | Item.TypeVar(_, tp) -> FSharpGenericParameter(cenv, tp) :> _ - | Item.Trait traitInfo -> - FSharpGenericParameterMemberConstraint(cenv, traitInfo) :> _ + | Item.Trait traitInfo -> FSharpGenericParameterMemberConstraint(cenv, traitInfo) :> _ - | Item.ActivePatternCase apref -> - FSharpActivePatternCase(cenv, apref.ActivePatternInfo, apref.ActivePatternVal.Type, apref.CaseIndex, Some apref.ActivePatternVal, item) :> _ + | Item.ActivePatternCase apref -> + FSharpActivePatternCase( + cenv, + apref.ActivePatternInfo, + apref.ActivePatternVal.Type, + apref.CaseIndex, + Some apref.ActivePatternVal, + item + ) + :> _ - | Item.ActivePatternResult (apinfo, ty, n, _) -> - FSharpActivePatternCase(cenv, apinfo, ty, n, None, item) :> _ + | Item.ActivePatternResult(apinfo, ty, n, _) -> FSharpActivePatternCase(cenv, apinfo, ty, n, None, item) :> _ - | Item.OtherName(id, ty, _, argOwner, m) -> - FSharpParameter(cenv, id, ty, argOwner, m) :> _ + | Item.OtherName(id, ty, _, argOwner, m) -> FSharpParameter(cenv, id, ty, argOwner, m) :> _ - | Item.ImplicitOp(_, { contents = Some(TraitConstraintSln.FSMethSln(vref=vref)) }) -> - FSharpMemberOrFunctionOrValue(cenv, V vref, item) :> _ + | Item.ImplicitOp(_, + { + contents = Some(TraitConstraintSln.FSMethSln(vref = vref)) + }) -> FSharpMemberOrFunctionOrValue(cenv, V vref, item) :> _ // TODO: the following don't currently return any interesting subtype | Item.ImplicitOp _ - | Item.ILField _ - | Item.NewDef _ -> dflt() + | Item.ILField _ + | Item.NewDef _ -> dflt () // These cases cover unreachable cases - | Item.CustomOperation (_, _, None) + | Item.CustomOperation(_, _, None) | Item.UnqualifiedType [] | Item.ModuleOrNamespaces [] - | Item.Property (info = []) - | Item.MethodGroup (_, [], _) - | Item.CtorGroup (_, []) + | Item.Property(info = []) + | Item.MethodGroup(_, [], _) + | Item.CtorGroup(_, []) // These cases cover misc. corned cases (non-symbol types) | Item.Types _ - | Item.DelegateCtor _ -> dflt() + | Item.DelegateCtor _ -> dflt () abstract Accessibility: FSharpAccessibility default _.Accessibility = FSharpAccessibility(taccessPublic) - + abstract Attributes: IList default _.Attributes = makeReadOnlyCollection [] - member sym.HasAttribute<'T> () = + member sym.HasAttribute<'T>() = sym.Attributes |> Seq.exists (fun attr -> attr.IsAttribute<'T>()) member sym.TryGetAttribute<'T>() = sym.Attributes |> Seq.tryFind (fun attr -> attr.IsAttribute<'T>()) -type FSharpEntity(cenv: SymbolEnv, entity: EntityRef, tyargs: TType list) = - inherit FSharpSymbol(cenv, - (fun () -> - checkEntityIsResolved entity - if entity.IsModuleOrNamespace then Item.ModuleOrNamespaces [entity] - elif entity.IsFSharpException then Item.ExnCase entity - else Item.UnqualifiedType [entity]), - (fun _this thisCcu2 ad -> - checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, getApproxFSharpAccessibilityOfEntity entity)) - // && AccessibilityLogic.IsEntityAccessible cenv.amap range0 ad entity) - ) - - // If an entity is in an assembly not available to us in the resolution set, +type FSharpEntity(cenv: SymbolEnv, entity: EntityRef, tyargs: TType list) = + inherit + FSharpSymbol( + cenv, + (fun () -> + checkEntityIsResolved entity + + if entity.IsModuleOrNamespace then + Item.ModuleOrNamespaces [ entity ] + elif entity.IsFSharpException then + Item.ExnCase entity + else + Item.UnqualifiedType [ entity ]), + (fun _this thisCcu2 ad -> + checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, getApproxFSharpAccessibilityOfEntity entity)) + // && AccessibilityLogic.IsEntityAccessible cenv.amap range0 ad entity) + ) + + // If an entity is in an assembly not available to us in the resolution set, // we generally return "false" from predicates like IsClass, since we know // nothing about that type. - let isResolvedAndFSharp() = + let isResolvedAndFSharp () = match entity with | ERefNonLocal(NonLocalEntityRef(ccu, _)) -> not ccu.IsUnresolvedReference && ccu.IsFSharp | _ -> cenv.thisCcu.IsFSharp - let isUnresolved() = entityIsUnresolved entity - let isResolved() = not (isUnresolved()) - let checkIsResolved() = checkEntityIsResolved entity + let isUnresolved () = entityIsUnresolved entity + let isResolved () = not (isUnresolved ()) + let checkIsResolved () = checkEntityIsResolved entity - let isDefinedInFSharpCore() = + let isDefinedInFSharpCore () = match ccuOfTyconRef entity with | None -> false | Some ccu -> ccuEq ccu cenv.g.fslibCcu @@ -390,366 +439,410 @@ type FSharpEntity(cenv: SymbolEnv, entity: EntityRef, tyargs: TType list) = FSharpEntity(cenv, tcref, tyargs) member _.Entity = entity - - member _.LogicalName = - checkIsResolved() - entity.LogicalName - member _.CompiledName = - checkIsResolved() - entity.CompiledName + member _.LogicalName = + checkIsResolved () + entity.LogicalName - member _.DisplayNameCore = - checkIsResolved() + member _.CompiledName = + checkIsResolved () + entity.CompiledName + + member _.DisplayNameCore = + checkIsResolved () entity.DisplayNameCore - member _.DisplayName = - checkIsResolved() + member _.DisplayName = + checkIsResolved () entity.DisplayName - member _.AccessPath = - checkIsResolved() - match entity.CompilationPathOpt with - | None -> "global" - | Some (CompPath(_, _, [])) -> "global" + member _.AccessPath = + checkIsResolved () + + match entity.CompilationPathOpt with + | None -> "global" + | Some(CompPath(_, _, [])) -> "global" | Some cp -> buildAccessPath (Some cp) - - member x.DeclaringEntity = - match entity.CompilationPathOpt with + + member x.DeclaringEntity = + match entity.CompilationPathOpt with | None -> None - | Some (CompPath(_, _, [])) -> None - | Some cp -> + | Some(CompPath(_, _, [])) -> None + | Some cp -> match x.Assembly.Contents.FindEntityByPath cp.MangledPath with | Some res -> Some res - | None -> - // The declaring entity may be in this assembly, including a type possibly hidden by a signature. - match cenv.thisCcuTy with - | Some t -> - let s = FSharpAssemblySignature(cenv, None, None, t) - s.FindEntityByPath cp.MangledPath - | None -> None - - member _.Namespace = - checkIsResolved() - match entity.CompilationPathOpt with + | None -> + // The declaring entity may be in this assembly, including a type possibly hidden by a signature. + match cenv.thisCcuTy with + | Some t -> + let s = FSharpAssemblySignature(cenv, None, None, t) + s.FindEntityByPath cp.MangledPath + | None -> None + + member _.Namespace = + checkIsResolved () + + match entity.CompilationPathOpt with | None -> None - | Some (CompPath(_, _, [])) -> None - | Some cp when cp.AccessPath |> List.forall (function _, ModuleOrNamespaceKind.Namespace _ -> true | _ -> false) -> - Some (buildAccessPath (Some cp)) + | Some(CompPath(_, _, [])) -> None + | Some cp when + cp.AccessPath + |> List.forall (function + | _, ModuleOrNamespaceKind.Namespace _ -> true + | _ -> false) + -> + Some(buildAccessPath (Some cp)) | Some _ -> None member x.CompiledRepresentation = - checkIsResolved() + checkIsResolved () let fail () = invalidOp $"the type '{x.LogicalName}' does not have a qualified name" #if !NO_TYPEPROVIDERS - if entity.IsTypeAbbrev || entity.IsProvidedErasedTycon || entity.IsNamespace then fail () + if entity.IsTypeAbbrev || entity.IsProvidedErasedTycon || entity.IsNamespace then + fail () #else - if entity.IsTypeAbbrev || entity.IsNamespace then fail () + if entity.IsTypeAbbrev || entity.IsNamespace then + fail () #endif match entity.CompiledRepresentation with | CompiledTypeRepr.ILAsmNamed(tref, _, _) -> tref | CompiledTypeRepr.ILAsmOpen _ -> fail () - member x.QualifiedName = - x.CompiledRepresentation.QualifiedName + member x.QualifiedName = x.CompiledRepresentation.QualifiedName - member x.BasicQualifiedName = - x.CompiledRepresentation.BasicQualifiedName + member x.BasicQualifiedName = x.CompiledRepresentation.BasicQualifiedName + + member x.FullName = + checkIsResolved () - member x.FullName = - checkIsResolved() - match x.TryFullName with + match x.TryFullName with | None -> invalidOp (sprintf "the type '%s' does not have a qualified name" x.LogicalName) | Some nm -> nm - - member _.TryFullName = - if isUnresolved() then None + + member _.TryFullName = + if isUnresolved () then + None #if !NO_TYPEPROVIDERS - elif entity.IsTypeAbbrev || entity.IsProvidedErasedTycon then None - #else - elif entity.IsTypeAbbrev then None + elif entity.IsTypeAbbrev || entity.IsProvidedErasedTycon then + None +#else + elif entity.IsTypeAbbrev then + None #endif - elif entity.IsNamespace then Some entity.DemangledModuleOrNamespaceName + elif entity.IsNamespace then + Some entity.DemangledModuleOrNamespaceName else - match entity.CompiledRepresentation with + match entity.CompiledRepresentation with | CompiledTypeRepr.ILAsmNamed(tref, _, _) -> Some tref.FullName - | CompiledTypeRepr.ILAsmOpen _ -> None + | CompiledTypeRepr.ILAsmOpen _ -> None - member _.DeclarationLocation = - checkIsResolved() + member _.DeclarationLocation = + checkIsResolved () entity.Range - member _.GenericParameters = - checkIsResolved() - entity.TyparsNoRange |> List.map (fun tp -> FSharpGenericParameter(cenv, tp)) |> makeReadOnlyCollection + member _.GenericParameters = + checkIsResolved () + + entity.TyparsNoRange + |> List.map (fun tp -> FSharpGenericParameter(cenv, tp)) + |> makeReadOnlyCollection member _.GenericArguments = - checkIsResolved() + checkIsResolved () tyargs |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection - member _.IsMeasure = - isResolvedAndFSharp() && (entity.TypeOrMeasureKind = TyparKind.Measure) + member _.IsMeasure = + isResolvedAndFSharp () && (entity.TypeOrMeasureKind = TyparKind.Measure) + + member _.IsAbstractClass = isResolved () && isAbstractTycon entity.Deref - member _.IsAbstractClass = - isResolved() && isAbstractTycon entity.Deref + member _.IsFSharpModule = isResolvedAndFSharp () && entity.IsModule - member _.IsFSharpModule = - isResolvedAndFSharp() && entity.IsModule + member _.HasFSharpModuleSuffix = + isResolvedAndFSharp () + && entity.IsModule + && (entity.ModuleOrNamespaceType.ModuleOrNamespaceKind = ModuleOrNamespaceKind.FSharpModuleWithSuffix) - member _.HasFSharpModuleSuffix = - isResolvedAndFSharp() && - entity.IsModule && - (entity.ModuleOrNamespaceType.ModuleOrNamespaceKind = ModuleOrNamespaceKind.FSharpModuleWithSuffix) + member _.IsValueType = isResolved () && entity.IsStructOrEnumTycon - member _.IsValueType = - isResolved() && - entity.IsStructOrEnumTycon + member _.IsArrayType = isResolved () && isArrayTyconRef cenv.g entity - member _.IsArrayType = - isResolved() && - isArrayTyconRef cenv.g entity + member _.ArrayRank = + checkIsResolved () - member _.ArrayRank = - checkIsResolved() if isArrayTyconRef cenv.g entity then rankOfArrayTyconRef cenv.g entity else 0 #if !NO_TYPEPROVIDERS - member _.IsProvided = - isResolved() && - entity.IsProvided + member _.IsProvided = isResolved () && entity.IsProvided - member _.IsProvidedAndErased = - isResolved() && - entity.IsProvidedErasedTycon + member _.IsProvidedAndErased = isResolved () && entity.IsProvidedErasedTycon - member _.IsStaticInstantiation = - isResolved() && - entity.IsStaticInstantiationTycon + member _.IsStaticInstantiation = isResolved () && entity.IsStaticInstantiationTycon - member _.IsProvidedAndGenerated = - isResolved() && - entity.IsProvidedGeneratedTycon + member _.IsProvidedAndGenerated = isResolved () && entity.IsProvidedGeneratedTycon #endif - member _.IsClass = - isResolved() && - match metadataOfTycon entity.Deref with -#if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata info -> info.IsClass + member _.IsClass = + isResolved () + && match metadataOfTycon entity.Deref with +#if !NO_TYPEPROVIDERS + | ProvidedTypeMetadata info -> info.IsClass #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsClass - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.Deref.IsFSharpClassTycon + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsClass + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.Deref.IsFSharpClassTycon - member _.IsByRef = - isResolved() && - isByrefTyconRef cenv.g entity + member _.IsByRef = isResolved () && isByrefTyconRef cenv.g entity - member _.IsOpaque = - isResolved() && - entity.IsHiddenReprTycon + member _.IsOpaque = isResolved () && entity.IsHiddenReprTycon - member _.IsInterface = - isResolved() && - isInterfaceTyconRef entity + member _.IsInterface = isResolved () && isInterfaceTyconRef entity - member _.IsDelegate = - isResolved() && - match metadataOfTycon entity.Deref with + member _.IsDelegate = + isResolved () + && match metadataOfTycon entity.Deref with #if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata info -> info.IsDelegate () + | ProvidedTypeMetadata info -> info.IsDelegate() #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsDelegate - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.IsFSharpDelegateTycon + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsDelegate + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.IsFSharpDelegateTycon - member _.IsEnum = - isResolved() && - entity.IsEnumTycon - - member _.IsFSharpExceptionDeclaration = - isResolvedAndFSharp() && entity.IsFSharpException + member _.IsEnum = isResolved () && entity.IsEnumTycon - member _.IsUnresolved = - isUnresolved() + member _.IsFSharpExceptionDeclaration = + isResolvedAndFSharp () && entity.IsFSharpException - member _.IsFSharp = - isResolvedAndFSharp() + member _.IsUnresolved = isUnresolved () - member _.IsFSharpAbbreviation = - isResolvedAndFSharp() && entity.IsTypeAbbrev + member _.IsFSharp = isResolvedAndFSharp () - member _.IsFSharpRecord = - isResolvedAndFSharp() && entity.IsRecordTycon + member _.IsFSharpAbbreviation = isResolvedAndFSharp () && entity.IsTypeAbbrev - member _.IsFSharpUnion = - isResolvedAndFSharp() && entity.IsUnionTycon + member _.IsFSharpRecord = isResolvedAndFSharp () && entity.IsRecordTycon - member _.HasAssemblyCodeRepresentation = - isResolvedAndFSharp() && (entity.IsAsmReprTycon || entity.IsMeasureableReprTycon) + member _.IsFSharpUnion = isResolvedAndFSharp () && entity.IsUnionTycon + + member _.HasAssemblyCodeRepresentation = + isResolvedAndFSharp () + && (entity.IsAsmReprTycon || entity.IsMeasureableReprTycon) member _.FSharpDelegateSignature = - checkIsResolved() - match entity.TypeReprInfo with - | TFSharpTyconRepr r when entity.IsFSharpDelegateTycon -> - match r.fsobjmodel_kind with + checkIsResolved () + + match entity.TypeReprInfo with + | TFSharpTyconRepr r when entity.IsFSharpDelegateTycon -> + match r.fsobjmodel_kind with | TFSharpDelegate ss -> FSharpDelegateSignature(cenv, ss) | _ -> invalidOp "not a delegate type" | _ -> invalidOp "not a delegate type" - override _.Accessibility = - if isUnresolved() then FSharpAccessibility taccessPublic else - FSharpAccessibility(getApproxFSharpAccessibilityOfEntity entity) + override _.Accessibility = + if isUnresolved () then + FSharpAccessibility taccessPublic + else + FSharpAccessibility(getApproxFSharpAccessibilityOfEntity entity) - member _.RepresentationAccessibility = - if isUnresolved() then FSharpAccessibility taccessPublic else - FSharpAccessibility(entity.TypeReprAccessibility) + member _.RepresentationAccessibility = + if isUnresolved () then + FSharpAccessibility taccessPublic + else + FSharpAccessibility(entity.TypeReprAccessibility) - member _.DeclaredInterfaces = - if isUnresolved() then makeReadOnlyCollection [] else - let ty = generalizedTyconRef cenv.g entity - DiagnosticsLogger.protectAssemblyExploration [] (fun () -> - [ for intfTy in GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes cenv.g cenv.amap range0 ty do - yield FSharpType(cenv, intfTy) ]) - |> makeReadOnlyCollection + member _.DeclaredInterfaces = + if isUnresolved () then + makeReadOnlyCollection [] + else + let ty = generalizedTyconRef cenv.g entity + + DiagnosticsLogger.protectAssemblyExploration [] (fun () -> + [ + for intfTy in GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes cenv.g cenv.amap range0 ty do + yield FSharpType(cenv, intfTy) + ]) + |> makeReadOnlyCollection + + member _.AllInterfaces = + if isUnresolved () then + makeReadOnlyCollection [] + else + let ty = generalizedTyconRef cenv.g entity + + DiagnosticsLogger.protectAssemblyExploration [] (fun () -> + [ + for ity in AllInterfacesOfType cenv.g cenv.amap range0 AllowMultiIntfInstantiations.Yes ty do + yield FSharpType(cenv, ity) + ]) + |> makeReadOnlyCollection - member _.AllInterfaces = - if isUnresolved() then makeReadOnlyCollection [] else - let ty = generalizedTyconRef cenv.g entity - DiagnosticsLogger.protectAssemblyExploration [] (fun () -> - [ for ity in AllInterfacesOfType cenv.g cenv.amap range0 AllowMultiIntfInstantiations.Yes ty do - yield FSharpType(cenv, ity) ]) - |> makeReadOnlyCollection - member _.IsAttributeType = - if isUnresolved() then false else - let ty = generalizedTyconRef cenv.g entity - DiagnosticsLogger.protectAssemblyExploration false <| fun () -> - ExistsHeadTypeInEntireHierarchy cenv.g cenv.amap range0 ty cenv.g.tcref_System_Attribute - + if isUnresolved () then + false + else + let ty = generalizedTyconRef cenv.g entity + + DiagnosticsLogger.protectAssemblyExploration false + <| fun () -> ExistsHeadTypeInEntireHierarchy cenv.g cenv.amap range0 ty cenv.g.tcref_System_Attribute + member _.IsDisposableType = - if isUnresolved() then false else - let ty = generalizedTyconRef cenv.g entity - DiagnosticsLogger.protectAssemblyExploration false <| fun () -> - ExistsHeadTypeInEntireHierarchy cenv.g cenv.amap range0 ty cenv.g.tcref_System_IDisposable + if isUnresolved () then + false + else + let ty = generalizedTyconRef cenv.g entity + + DiagnosticsLogger.protectAssemblyExploration false + <| fun () -> ExistsHeadTypeInEntireHierarchy cenv.g cenv.amap range0 ty cenv.g.tcref_System_IDisposable - member _.BaseType = - checkIsResolved() + member _.BaseType = + checkIsResolved () let ty = generalizedTyconRef cenv.g entity + GetSuperTypeOfType cenv.g cenv.amap range0 ty - |> Option.map (fun ty -> FSharpType(cenv, ty)) - - member _.UsesPrefixDisplay = - if isUnresolved() then true else - not (isResolvedAndFSharp()) || entity.Deref.IsPrefixDisplay - - member _.IsNamespace = entity.IsNamespace - - member x.MembersFunctionsAndValues = - if isUnresolved() then makeReadOnlyCollection [] else - protect <| fun () -> - ([ let entityTy = generalizedTyconRef cenv.g entity - let createMember (minfo: MethInfo) = - if minfo.IsConstructor || minfo.IsClassConstructor then - FSharpMemberOrFunctionOrValue(cenv, C minfo, Item.CtorGroup (minfo.DisplayName, [minfo])) - else - FSharpMemberOrFunctionOrValue(cenv, M minfo, Item.MethodGroup (minfo.DisplayName, [minfo], None)) - if x.IsFSharpAbbreviation then - () - elif x.IsFSharp then - // For F# code we emit methods members in declaration order - for v in entity.MembersOfFSharpTyconSorted do - // Ignore members representing the generated .cctor - if not v.Deref.IsClassConstructor then - yield createMember (FSMeth(cenv.g, entityTy, v, None)) - else - for minfo in GetImmediateIntrinsicMethInfosOfType (None, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 entityTy do - yield createMember minfo - - let props = GetImmediateIntrinsicPropInfosOfType (None, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 entityTy - let events = cenv.infoReader.GetImmediateIntrinsicEventsOfType (None, AccessibleFromSomeFSharpCode, range0, entityTy) - - for pinfo in props do - yield FSharpMemberOrFunctionOrValue(cenv, P pinfo, Item.Property (pinfo.PropertyName, [pinfo], None)) - - for einfo in events do - yield FSharpMemberOrFunctionOrValue(cenv, E einfo, Item.Event einfo) - - // Emit the values, functions and F#-declared extension members in a module - for v in entity.ModuleOrNamespaceType.AllValsAndMembers do - if v.IsExtensionMember then - - // For F#-declared extension members, yield a value-backed member and a property info if possible - let vref = mkNestedValRef entity v - yield FSharpMemberOrFunctionOrValue(cenv, V vref, Item.Value vref) - match v.MemberInfo.Value.MemberFlags.MemberKind, v.ApparentEnclosingEntity with - | SynMemberKind.PropertyGet, Parent tcref -> - let pinfo = FSProp(cenv.g, generalizedTyconRef cenv.g tcref, Some vref, None) - yield FSharpMemberOrFunctionOrValue(cenv, P pinfo, Item.Property (pinfo.PropertyName, [pinfo], None)) - | SynMemberKind.PropertySet, Parent p -> - let pinfo = FSProp(cenv.g, generalizedTyconRef cenv.g p, None, Some vref) - yield FSharpMemberOrFunctionOrValue(cenv, P pinfo, Item.Property (pinfo.PropertyName, [pinfo], None)) - | _ -> () - - elif not v.IsMember then - let vref = mkNestedValRef entity v - yield FSharpMemberOrFunctionOrValue(cenv, V vref, Item.Value vref) ] - |> makeReadOnlyCollection) - - member _.XmlDocSig = - checkIsResolved() + |> Option.map (fun ty -> FSharpType(cenv, ty)) + + member _.UsesPrefixDisplay = + if isUnresolved () then + true + else + not (isResolvedAndFSharp ()) || entity.Deref.IsPrefixDisplay + + member _.IsNamespace = entity.IsNamespace + + member x.MembersFunctionsAndValues = + if isUnresolved () then + makeReadOnlyCollection [] + else + protect + <| fun () -> + ([ + let entityTy = generalizedTyconRef cenv.g entity + + let createMember (minfo: MethInfo) = + if minfo.IsConstructor || minfo.IsClassConstructor then + FSharpMemberOrFunctionOrValue(cenv, C minfo, Item.CtorGroup(minfo.DisplayName, [ minfo ])) + else + FSharpMemberOrFunctionOrValue(cenv, M minfo, Item.MethodGroup(minfo.DisplayName, [ minfo ], None)) + + if x.IsFSharpAbbreviation then + () + elif x.IsFSharp then + // For F# code we emit methods members in declaration order + for v in entity.MembersOfFSharpTyconSorted do + // Ignore members representing the generated .cctor + if not v.Deref.IsClassConstructor then + yield createMember (FSMeth(cenv.g, entityTy, v, None)) + else + for minfo in + GetImmediateIntrinsicMethInfosOfType (None, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 entityTy do + yield createMember minfo + + let props = + GetImmediateIntrinsicPropInfosOfType (None, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 entityTy + + let events = + cenv.infoReader.GetImmediateIntrinsicEventsOfType(None, AccessibleFromSomeFSharpCode, range0, entityTy) + + for pinfo in props do + yield FSharpMemberOrFunctionOrValue(cenv, P pinfo, Item.Property(pinfo.PropertyName, [ pinfo ], None)) + + for einfo in events do + yield FSharpMemberOrFunctionOrValue(cenv, E einfo, Item.Event einfo) + + // Emit the values, functions and F#-declared extension members in a module + for v in entity.ModuleOrNamespaceType.AllValsAndMembers do + if v.IsExtensionMember then + + // For F#-declared extension members, yield a value-backed member and a property info if possible + let vref = mkNestedValRef entity v + yield FSharpMemberOrFunctionOrValue(cenv, V vref, Item.Value vref) + + match v.MemberInfo.Value.MemberFlags.MemberKind, v.ApparentEnclosingEntity with + | SynMemberKind.PropertyGet, Parent tcref -> + let pinfo = FSProp(cenv.g, generalizedTyconRef cenv.g tcref, Some vref, None) + yield FSharpMemberOrFunctionOrValue(cenv, P pinfo, Item.Property(pinfo.PropertyName, [ pinfo ], None)) + | SynMemberKind.PropertySet, Parent p -> + let pinfo = FSProp(cenv.g, generalizedTyconRef cenv.g p, None, Some vref) + yield FSharpMemberOrFunctionOrValue(cenv, P pinfo, Item.Property(pinfo.PropertyName, [ pinfo ], None)) + | _ -> () + + elif not v.IsMember then + let vref = mkNestedValRef entity v + yield FSharpMemberOrFunctionOrValue(cenv, V vref, Item.Value vref) + ] + |> makeReadOnlyCollection) + + member _.XmlDocSig = + checkIsResolved () getXmlDocSigForEntity cenv entity - - member _.XmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeXmlDoc else - entity.XmlDoc |> makeXmlDoc - member _.ElaboratedXmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeElaboratedXmlDoc else - entity.XmlDoc |> makeElaboratedXmlDoc + member _.XmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeXmlDoc + else + entity.XmlDoc |> makeXmlDoc + + member _.ElaboratedXmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeElaboratedXmlDoc + else + entity.XmlDoc |> makeElaboratedXmlDoc - member x.StaticParameters = - match entity.TypeReprInfo with + member x.StaticParameters = + match entity.TypeReprInfo with #if !NO_TYPEPROVIDERS - | TProvidedTypeRepr info -> + | TProvidedTypeRepr info -> let m = x.DeclarationLocation - let typeBeforeArguments = info.ProvidedType - let staticParameters = typeBeforeArguments.PApplyWithProvider((fun (typeBeforeArguments, provider) -> typeBeforeArguments.GetStaticParameters provider), range=m) + let typeBeforeArguments = info.ProvidedType + + let staticParameters = + typeBeforeArguments.PApplyWithProvider( + (fun (typeBeforeArguments, provider) -> typeBeforeArguments.GetStaticParameters provider), + range = m + ) + let staticParameters = staticParameters.PApplyArray(id, "GetStaticParameters", m) [| for p in staticParameters -> FSharpStaticParameter(cenv, p, m) |] #endif - | _ -> [| |] - |> makeReadOnlyCollection - - member _.NestedEntities = - if isUnresolved() then makeReadOnlyCollection [] else - entity.ModuleOrNamespaceType.AllEntities - |> QueueList.toList - |> List.map (fun x -> FSharpEntity(cenv, entity.NestedTyconRef x, tyargs)) + | _ -> [||] |> makeReadOnlyCollection - member _.UnionCases = - if isUnresolved() then makeReadOnlyCollection [] else - entity.UnionCasesAsRefList - |> List.map (fun x -> FSharpUnionCase(cenv, x)) - |> makeReadOnlyCollection + member _.NestedEntities = + if isUnresolved () then + makeReadOnlyCollection [] + else + entity.ModuleOrNamespaceType.AllEntities + |> QueueList.toList + |> List.map (fun x -> FSharpEntity(cenv, entity.NestedTyconRef x, tyargs)) + |> makeReadOnlyCollection + + member _.UnionCases = + if isUnresolved () then + makeReadOnlyCollection [] + else + entity.UnionCasesAsRefList + |> List.map (fun x -> FSharpUnionCase(cenv, x)) + |> makeReadOnlyCollection member _.FSharpFields = - if isUnresolved() then makeReadOnlyCollection [] else - - if entity.IsILEnumTycon then + if isUnresolved () then + makeReadOnlyCollection [] + else if + + entity.IsILEnumTycon + then let (TILObjectReprData(_scoref, _enc, tdef)) = entity.ILTyconInfo let formalTypars = entity.Typars range0 let formalTypeInst = generalizeTypars formalTypars let ty = TType_app(entity, formalTypeInst, cenv.g.knownWithoutNull) let formalTypeInfo = ILTypeInfo.FromType cenv.g ty + tdef.Fields.AsList() |> List.map (fun tdef -> let ilFieldInfo = ILFieldInfo(formalTypeInfo, tdef) - FSharpField(cenv, FSharpFieldData.ILField ilFieldInfo )) + FSharpField(cenv, FSharpFieldData.ILField ilFieldInfo)) |> makeReadOnlyCollection else @@ -757,8 +850,8 @@ type FSharpEntity(cenv: SymbolEnv, entity: EntityRef, tyargs: TType list) = |> List.map (fun x -> FSharpField(cenv, mkRecdFieldRef entity x.LogicalName)) |> makeReadOnlyCollection - member _.AbbreviatedType = - checkIsResolved() + member _.AbbreviatedType = + checkIsResolved () match entity.TypeAbbrev with | None -> invalidOp "not a type abbreviation" @@ -768,24 +861,29 @@ type FSharpEntity(cenv: SymbolEnv, entity: EntityRef, tyargs: TType list) = let ty = generalizedTyconRef cenv.g entity FSharpType(cenv, ty) - override _.Attributes = - if isUnresolved() then makeReadOnlyCollection [] else - GetAttribInfosOfEntity cenv.g cenv.amap range0 entity - |> List.map (fun a -> FSharpAttribute(cenv, a)) - |> makeReadOnlyCollection + override _.Attributes = + if isUnresolved () then + makeReadOnlyCollection [] + else + GetAttribInfosOfEntity cenv.g cenv.amap range0 entity + |> List.map (fun a -> FSharpAttribute(cenv, a)) + |> makeReadOnlyCollection member _.AllCompilationPaths = - checkIsResolved() + checkIsResolved () let (CompPath(_, _, parts)) = entity.CompilationPath + let partsList = - [ yield parts - match parts with - | ("Microsoft", ModuleOrNamespaceKind.Namespace _) :: rest when isDefinedInFSharpCore() -> yield rest - | _ -> ()] + [ + yield parts + match parts with + | ("Microsoft", ModuleOrNamespaceKind.Namespace _) :: rest when isDefinedInFSharpCore () -> yield rest + | _ -> () + ] let mapEachCurrentPath (paths: string list list) path = match paths with - | [] -> [[path]] + | [] -> [ [ path ] ] | _ -> paths |> List.map (fun x -> path :: x) let walkParts (parts: (string * ModuleOrNamespaceKind) list) = @@ -795,283 +893,314 @@ type FSharpEntity(cenv: SymbolEnv, entity: EntityRef, tyargs: TType list) = | (name: string, kind) :: rest -> match kind with | ModuleOrNamespaceKind.FSharpModuleWithSuffix -> - [ yield! loop (mapEachCurrentPath currentPaths name) rest - yield! loop (mapEachCurrentPath currentPaths name[..name.Length - 7]) rest ] - | _ -> - loop (mapEachCurrentPath currentPaths name) rest + [ + yield! loop (mapEachCurrentPath currentPaths name) rest + yield! loop (mapEachCurrentPath currentPaths name[.. name.Length - 7]) rest + ] + | _ -> loop (mapEachCurrentPath currentPaths name) rest + loop [] parts |> List.map (List.rev >> String.concat ".") - + let res = - [ for parts in partsList do - yield! walkParts parts ] + [ + for parts in partsList do + yield! walkParts parts + ] + res member x.ActivePatternCases = - protect <| fun () -> + protect + <| fun () -> ActivePatternElemsOfModuleOrNamespace cenv.g x.Entity |> Map.toList |> List.map (fun (_, apref) -> let item = Item.ActivePatternCase apref - FSharpActivePatternCase(cenv, apref.ActivePatternInfo, apref.ActivePatternVal.Type, apref.CaseIndex, Some apref.ActivePatternVal, item)) + + FSharpActivePatternCase( + cenv, + apref.ActivePatternInfo, + apref.ActivePatternVal.Type, + apref.CaseIndex, + Some apref.ActivePatternVal, + item + )) member x.TryGetFullName() = - try x.TryFullName - with _ -> - try Some(String.Join(".", x.AccessPath, x.DisplayName)) - with _ -> None + try + x.TryFullName + with _ -> + try + Some(String.Join(".", x.AccessPath, x.DisplayName)) + with _ -> + None member x.TryGetFullDisplayName() = let fullName = x.TryGetFullName() |> Option.map (fun fullName -> fullName.Split '.') - let res = + + let res = match fullName with | Some fullName -> match Option.attempt (fun _ -> x.DisplayName) with | Some shortDisplayName when not (shortDisplayName.Contains ".") -> - Some (fullName |> Array.replace (fullName.Length - 1) shortDisplayName) + Some(fullName |> Array.replace (fullName.Length - 1) shortDisplayName) | _ -> Some fullName - | None -> None - |> Option.map (fun fullDisplayName -> String.Join (".", fullDisplayName)) + | None -> None + |> Option.map (fun fullDisplayName -> String.Join(".", fullDisplayName)) //debug "GetFullDisplayName: FullName = %A, Result = %A" fullName res res member x.TryGetFullCompiledName() = let fullName = x.TryGetFullName() |> Option.map (fun fullName -> fullName.Split '.') - let res = + + let res = match fullName with | Some fullName -> match Option.attempt (fun _ -> x.CompiledName) with | Some shortCompiledName when not (shortCompiledName.Contains ".") -> - Some (fullName |> Array.replace (fullName.Length - 1) shortCompiledName) + Some(fullName |> Array.replace (fullName.Length - 1) shortCompiledName) | _ -> Some fullName - | None -> None - |> Option.map (fun fullDisplayName -> String.Join (".", fullDisplayName)) + | None -> None + |> Option.map (fun fullDisplayName -> String.Join(".", fullDisplayName)) //debug "GetFullCompiledName: FullName = %A, Result = %A" fullName res res member x.GetPublicNestedEntities() = x.NestedEntities |> Seq.filter (fun entity -> entity.Accessibility.IsPublic) - member x.TryGetMembersFunctionsAndValues() = - try x.MembersFunctionsAndValues with _ -> [||] :> _ + member x.TryGetMembersFunctionsAndValues() = + try + x.MembersFunctionsAndValues + with _ -> + [||] :> _ member this.TryGetMetadataText() = match entity.TryDeref with | ValueSome _ -> - if entity.IsNamespace then None + if entity.IsNamespace then + None else - let denv = DisplayEnv.InitialForSigFileGeneration cenv.g - - let extraOpenPath = - match entity.CompilationPathOpt with - | Some cpath -> - let rec getOpenPath accessPath acc = - match accessPath with - | [] -> acc - | (name, ModuleOrNamespaceKind.ModuleOrType) :: accessPath -> - getOpenPath accessPath (name :: acc) - | (name, ModuleOrNamespaceKind.Namespace _) :: accessPath -> - getOpenPath accessPath (name :: acc) - | (name, ModuleOrNamespaceKind.FSharpModuleWithSuffix) :: accessPath -> - getOpenPath accessPath (name :: acc) - - getOpenPath cpath.AccessPath [] - | _ -> - [] - |> List.rev - - let needOpenType = - match entity.CompilationPathOpt with - | Some cpath -> - match cpath.AccessPath with - | (_, ModuleOrNamespaceKind.ModuleOrType) :: _ -> - match this.DeclaringEntity with - | Some (declaringEntity: FSharpEntity) -> not declaringEntity.IsFSharpModule + let denv = DisplayEnv.InitialForSigFileGeneration cenv.g + + let extraOpenPath = + match entity.CompilationPathOpt with + | Some cpath -> + let rec getOpenPath accessPath acc = + match accessPath with + | [] -> acc + | (name, ModuleOrNamespaceKind.ModuleOrType) :: accessPath -> getOpenPath accessPath (name :: acc) + | (name, ModuleOrNamespaceKind.Namespace _) :: accessPath -> getOpenPath accessPath (name :: acc) + | (name, ModuleOrNamespaceKind.FSharpModuleWithSuffix) :: accessPath -> getOpenPath accessPath (name :: acc) + + getOpenPath cpath.AccessPath [] + | _ -> [] + |> List.rev + + let needOpenType = + match entity.CompilationPathOpt with + | Some cpath -> + match cpath.AccessPath with + | (_, ModuleOrNamespaceKind.ModuleOrType) :: _ -> + match this.DeclaringEntity with + | Some(declaringEntity: FSharpEntity) -> not declaringEntity.IsFSharpModule + | _ -> false | _ -> false | _ -> false - | _ -> - false - let denv = denv.AddOpenPath extraOpenPath + let denv = denv.AddOpenPath extraOpenPath - let infoReader = cenv.infoReader + let infoReader = cenv.infoReader - let assemblyInfoL = - Layout.aboveListL - [ - (Layout.(^^) - (Layout.wordL (TaggedText.tagUnknownEntity "// ")) - (Layout.wordL (TaggedText.tagUnknownEntity this.Assembly.QualifiedName))) - match this.Assembly.FileName with - | Some fn -> + let assemblyInfoL = + Layout.aboveListL + [ (Layout.(^^) (Layout.wordL (TaggedText.tagUnknownEntity "// ")) - (Layout.wordL (TaggedText.tagUnknownEntity fn))) - | None -> Layout.emptyL - ] + (Layout.wordL (TaggedText.tagUnknownEntity this.Assembly.QualifiedName))) + match this.Assembly.FileName with + | Some fn -> + (Layout.(^^) + (Layout.wordL (TaggedText.tagUnknownEntity "// ")) + (Layout.wordL (TaggedText.tagUnknownEntity fn))) + | None -> Layout.emptyL + ] + + let openPathL = + extraOpenPath + |> List.map (fun x -> Layout.wordL (TaggedText.tagUnknownEntity x)) + + let pathL = + if List.isEmpty extraOpenPath then + Layout.emptyL + else + Layout.sepListL (Layout.sepL TaggedText.dot) openPathL - let openPathL = - extraOpenPath - |> List.map (fun x -> Layout.wordL (TaggedText.tagUnknownEntity x)) + let headerL = + if List.isEmpty extraOpenPath then + Layout.emptyL + else + Layout.(^^) (Layout.wordL (TaggedText.tagKeyword "namespace")) pathL - let pathL = - if List.isEmpty extraOpenPath then - Layout.emptyL - else - Layout.sepListL (Layout.sepL TaggedText.dot) openPathL - - let headerL = - if List.isEmpty extraOpenPath then - Layout.emptyL - else - Layout.(^^) - (Layout.wordL (TaggedText.tagKeyword "namespace")) - pathL + let openL = + if List.isEmpty openPathL then + Layout.emptyL + else + let openKeywordL = + if needOpenType then + Layout.(^^) (Layout.wordL (TaggedText.tagKeyword "open")) (Layout.wordL TaggedText.keywordType) + else + Layout.wordL (TaggedText.tagKeyword "open") - let openL = - if List.isEmpty openPathL then Layout.emptyL - else - let openKeywordL = - if needOpenType then - Layout.(^^) - (Layout.wordL (TaggedText.tagKeyword "open")) - (Layout.wordL TaggedText.keywordType) - else - Layout.wordL (TaggedText.tagKeyword "open") - Layout.(^^) - openKeywordL - pathL - - Layout.aboveListL - [ - (Layout.(^^) assemblyInfoL (Layout.sepL TaggedText.lineBreak)) - (Layout.(^^) headerL (Layout.sepL TaggedText.lineBreak)) - (Layout.(^^) openL (Layout.sepL TaggedText.lineBreak)) - (NicePrint.layoutEntityDefn denv infoReader AccessibleFromSomewhere range0 entity) - ] - |> LayoutRender.showL - |> SourceText.ofString - |> Some - | _ -> - None + Layout.(^^) openKeywordL pathL + + Layout.aboveListL + [ + (Layout.(^^) assemblyInfoL (Layout.sepL TaggedText.lineBreak)) + (Layout.(^^) headerL (Layout.sepL TaggedText.lineBreak)) + (Layout.(^^) openL (Layout.sepL TaggedText.lineBreak)) + (NicePrint.layoutEntityDefn denv infoReader AccessibleFromSomewhere range0 entity) + ] + |> LayoutRender.showL + |> SourceText.ofString + |> Some + | _ -> None override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpEntity as otherEntity -> tyconRefEq cenv.g entity otherEntity.Entity - | _ -> false + box x === other + || match other with + | :? FSharpEntity as otherEntity -> tyconRefEq cenv.g entity otherEntity.Entity + | _ -> false override x.GetHashCode() = - checkIsResolved() + checkIsResolved () ((hash entity.Stamp) <<< 1) + 1 override x.ToString() = x.CompiledName type FSharpUnionCase(cenv, v: UnionCaseRef) = - inherit FSharpSymbol (cenv, - (fun () -> - checkEntityIsResolved v.TyconRef - Item.UnionCase(UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange, v), false)), - (fun _this thisCcu2 ad -> - checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, v.UnionCase.Accessibility)) - //&& AccessibilityLogic.IsUnionCaseAccessible cenv.amap range0 ad v) - ) - - - let isUnresolved() = - entityIsUnresolved v.TyconRef || v.TryUnionCase.IsNone - - let checkIsResolved() = + inherit + FSharpSymbol( + cenv, + (fun () -> + checkEntityIsResolved v.TyconRef + Item.UnionCase(UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange, v), false)), + (fun _this thisCcu2 ad -> checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, v.UnionCase.Accessibility)) + //&& AccessibilityLogic.IsUnionCaseAccessible cenv.amap range0 ad v) + ) + + let isUnresolved () = + entityIsUnresolved v.TyconRef || v.TryUnionCase.IsNone + + let checkIsResolved () = checkEntityIsResolved v.TyconRef - if v.TryUnionCase.IsNone then + + if v.TryUnionCase.IsNone then invalidOp (sprintf "The union case '%s' could not be found in the target type" v.CaseName) - member _.IsUnresolved = - isUnresolved() + member _.IsUnresolved = isUnresolved () - member _.Name = - checkIsResolved() + member _.Name = + checkIsResolved () v.UnionCase.LogicalName - member _.DeclarationLocation = - checkIsResolved() + member _.DeclarationLocation = + checkIsResolved () v.Range member _.DeclaringEntity = - checkIsResolved() + checkIsResolved () FSharpEntity(cenv, v.TyconRef) member _.HasFields = - if isUnresolved() then false else - v.UnionCase.RecdFieldsArray.Length <> 0 + if isUnresolved () then + false + else + v.UnionCase.RecdFieldsArray.Length <> 0 - member _.Fields = - if isUnresolved() then makeReadOnlyCollection [] else - v.UnionCase.RecdFieldsArray |> Array.mapi (fun i _ -> FSharpField(cenv, FSharpFieldData.Union (v, i))) |> makeReadOnlyCollection + member _.Fields = + if isUnresolved () then + makeReadOnlyCollection [] + else + v.UnionCase.RecdFieldsArray + |> Array.mapi (fun i _ -> FSharpField(cenv, FSharpFieldData.Union(v, i))) + |> makeReadOnlyCollection - member _.ReturnType = - checkIsResolved() + member _.ReturnType = + checkIsResolved () FSharpType(cenv, v.ReturnType) member _.CompiledName = - checkIsResolved() + checkIsResolved () v.UnionCase.CompiledName - member _.XmlDocSig = - checkIsResolved() + member _.XmlDocSig = + checkIsResolved () let unionCase = UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange, v) + match GetXmlDocSigOfUnionCaseRef unionCase.UnionCaseRef with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" - member _.XmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeXmlDoc else - v.UnionCase.XmlDoc |> makeXmlDoc + member _.XmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeXmlDoc + else + v.UnionCase.XmlDoc |> makeXmlDoc - member _.ElaboratedXmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeElaboratedXmlDoc else - v.UnionCase.XmlDoc |> makeElaboratedXmlDoc + member _.ElaboratedXmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeElaboratedXmlDoc + else + v.UnionCase.XmlDoc |> makeElaboratedXmlDoc - override _.Attributes = - if isUnresolved() then makeReadOnlyCollection [] else - v.Attribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) |> makeReadOnlyCollection + override _.Attributes = + if isUnresolved () then + makeReadOnlyCollection [] + else + v.Attribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + |> makeReadOnlyCollection - override _.Accessibility = - if isUnresolved() then FSharpAccessibility taccessPublic else - FSharpAccessibility(v.UnionCase.Accessibility) + override _.Accessibility = + if isUnresolved () then + FSharpAccessibility taccessPublic + else + FSharpAccessibility(v.UnionCase.Accessibility) member private x.V = v + override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpUnionCase as uc -> v === uc.V - | _ -> false + box x === other + || match other with + | :? FSharpUnionCase as uc -> v === uc.V + | _ -> false override x.GetHashCode() = hash v.CaseName override x.ToString() = x.CompiledName -type FSharpFieldData = +type FSharpFieldData = | AnonField of AnonRecdTypeInfo * TTypes * int * range | ILField of ILFieldInfo | RecdOrClass of RecdFieldRef | Union of UnionCaseRef * int member x.TryRecdField = - match x with - | AnonField (anonInfo, tinst, n, m) -> (anonInfo, tinst, n, m) |> Choice3Of3 + match x with + | AnonField(anonInfo, tinst, n, m) -> (anonInfo, tinst, n, m) |> Choice3Of3 | RecdOrClass v -> v.RecdField |> Choice1Of3 - | Union (v, n) -> v.FieldByIndex n |> Choice1Of3 + | Union(v, n) -> v.FieldByIndex n |> Choice1Of3 | ILField f -> f |> Choice2Of3 member x.TryDeclaringTyconRef = - match x with + match x with | RecdOrClass v -> Some v.TyconRef | ILField f -> Some f.DeclaringTyconRef | _ -> None -type FSharpAnonRecordTypeDetails(cenv: SymbolEnv, anonInfo: AnonRecdTypeInfo) = - member _.Assembly = FSharpAssembly (cenv, anonInfo.Assembly) +type FSharpAnonRecordTypeDetails(cenv: SymbolEnv, anonInfo: AnonRecdTypeInfo) = + member _.Assembly = FSharpAssembly(cenv, anonInfo.Assembly) /// Names of any enclosing types of the compiled form of the anonymous type (if the anonymous type was defined as a nested type) member _.EnclosingCompiledTypeNames = anonInfo.ILTypeRef.Enclosing @@ -1082,241 +1211,276 @@ type FSharpAnonRecordTypeDetails(cenv: SymbolEnv, anonInfo: AnonRecdTypeInfo) = /// The sorted labels of the anonymous type member _.SortedFieldNames = anonInfo.SortedNames -type FSharpField(cenv: SymbolEnv, d: FSharpFieldData) = - inherit FSharpSymbol (cenv, - (fun () -> - match d with - | AnonField (anonInfo, tinst, n, m) -> - Item.AnonRecdField(anonInfo, tinst, n, m) - | RecdOrClass v -> - checkEntityIsResolved v.TyconRef - Item.RecdField(RecdFieldInfo(generalizeTypars v.TyconRef.TyparsNoRange, v)) - | Union (v, fieldIndex) -> - checkEntityIsResolved v.TyconRef - Item.UnionCaseField (UnionCaseInfo (generalizeTypars v.TyconRef.TyparsNoRange, v), fieldIndex) - | ILField f -> - Item.ILField f), - (fun this thisCcu2 ad -> - checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, (this :?> FSharpField).Accessibility.Contents)) - //&& - //match d with - //| Recd v -> AccessibilityLogic.IsRecdFieldAccessible cenv.amap range0 ad v - //| Union (v, _) -> AccessibilityLogic.IsUnionCaseAccessible cenv.amap range0 ad v) - ) - - let isUnresolved() = - d.TryDeclaringTyconRef |> Option.exists entityIsUnresolved || +type FSharpField(cenv: SymbolEnv, d: FSharpFieldData) = + inherit + FSharpSymbol( + cenv, + (fun () -> + match d with + | AnonField(anonInfo, tinst, n, m) -> Item.AnonRecdField(anonInfo, tinst, n, m) + | RecdOrClass v -> + checkEntityIsResolved v.TyconRef + Item.RecdField(RecdFieldInfo(generalizeTypars v.TyconRef.TyparsNoRange, v)) + | Union(v, fieldIndex) -> + checkEntityIsResolved v.TyconRef + Item.UnionCaseField(UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange, v), fieldIndex) + | ILField f -> Item.ILField f), + (fun this thisCcu2 ad -> + checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, (this :?> FSharpField).Accessibility.Contents)) + //&& + //match d with + //| Recd v -> AccessibilityLogic.IsRecdFieldAccessible cenv.amap range0 ad v + //| Union (v, _) -> AccessibilityLogic.IsUnionCaseAccessible cenv.amap range0 ad v) + ) + + let isUnresolved () = + d.TryDeclaringTyconRef |> Option.exists entityIsUnresolved + || match d with + | AnonField _ -> false + | RecdOrClass v -> v.TryRecdField.IsNone + | Union(v, _) -> v.TryUnionCase.IsNone + | ILField _ -> false + + let checkIsResolved () = + d.TryDeclaringTyconRef |> Option.iter checkEntityIsResolved + match d with - | AnonField _ -> false - | RecdOrClass v -> v.TryRecdField.IsNone - | Union (v, _) -> v.TryUnionCase.IsNone - | ILField _ -> false - - let checkIsResolved() = - d.TryDeclaringTyconRef |> Option.iter checkEntityIsResolved - match d with | AnonField _ -> () - | RecdOrClass v -> - if v.TryRecdField.IsNone then + | RecdOrClass v -> + if v.TryRecdField.IsNone then invalidOp (sprintf "The record field '%s' could not be found in the target type" v.FieldName) - | Union (v, _) -> - if v.TryUnionCase.IsNone then + | Union(v, _) -> + if v.TryUnionCase.IsNone then invalidOp (sprintf "The union case '%s' could not be found in the target type" v.CaseName) | ILField _ -> () - new (cenv, ucref: UnionCaseRef, n) = FSharpField(cenv, FSharpFieldData.Union(ucref, n)) + new(cenv, ucref: UnionCaseRef, n) = FSharpField(cenv, FSharpFieldData.Union(ucref, n)) - new (cenv, rfref: RecdFieldRef) = FSharpField(cenv, FSharpFieldData.RecdOrClass rfref) + new(cenv, rfref: RecdFieldRef) = FSharpField(cenv, FSharpFieldData.RecdOrClass rfref) - member _.DeclaringEntity = + member _.DeclaringEntity = d.TryDeclaringTyconRef |> Option.map (fun tcref -> FSharpEntity(cenv, tcref)) - member _.IsUnresolved = - isUnresolved() - - member _.IsMutable = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.IsMutable - | Choice2Of3 f -> not f.IsInitOnly && f.LiteralValue.IsNone - | Choice3Of3 _ -> false - - member _.IsLiteral = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.LiteralValue.IsSome - | Choice2Of3 f -> f.LiteralValue.IsSome - | Choice3Of3 _ -> false - - member _.LiteralValue = - if isUnresolved() then None else - match d.TryRecdField with - | Choice1Of3 r -> getLiteralValue r.LiteralValue - | Choice2Of3 f -> f.LiteralValue |> Option.map (fun v -> v.AsObject()) - | Choice3Of3 _ -> None - - member _.IsVolatile = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.IsVolatile - | Choice2Of3 _ -> false // F# doesn't actually respect "volatile" from other assemblies in any case - | Choice3Of3 _ -> false - - member _.IsDefaultValue = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.IsZeroInit - | Choice2Of3 _ -> false - | Choice3Of3 _ -> false - - member _.IsAnonRecordField = - match d with + member _.IsUnresolved = isUnresolved () + + member _.IsMutable = + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.IsMutable + | Choice2Of3 f -> not f.IsInitOnly && f.LiteralValue.IsNone + | Choice3Of3 _ -> false + + member _.IsLiteral = + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.LiteralValue.IsSome + | Choice2Of3 f -> f.LiteralValue.IsSome + | Choice3Of3 _ -> false + + member _.LiteralValue = + if isUnresolved () then + None + else + match d.TryRecdField with + | Choice1Of3 r -> getLiteralValue r.LiteralValue + | Choice2Of3 f -> f.LiteralValue |> Option.map (fun v -> v.AsObject()) + | Choice3Of3 _ -> None + + member _.IsVolatile = + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.IsVolatile + | Choice2Of3 _ -> false // F# doesn't actually respect "volatile" from other assemblies in any case + | Choice3Of3 _ -> false + + member _.IsDefaultValue = + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.IsZeroInit + | Choice2Of3 _ -> false + | Choice3Of3 _ -> false + + member _.IsAnonRecordField = + match d with | AnonField _ -> true | _ -> false - member _.AnonRecordFieldDetails = - match d with - | AnonField (anonInfo, types, n, _) -> FSharpAnonRecordTypeDetails(cenv, anonInfo), [| for ty in types -> FSharpType(cenv, ty) |], n + member _.AnonRecordFieldDetails = + match d with + | AnonField(anonInfo, types, n, _) -> FSharpAnonRecordTypeDetails(cenv, anonInfo), [| for ty in types -> FSharpType(cenv, ty) |], n | _ -> invalidOp "not an anonymous record field" - member _.IsUnionCaseField = - match d with + member _.IsUnionCaseField = + match d with | Union _ -> true | _ -> false member _.DeclaringUnionCase = match d with - | Union (v, _) -> Some (FSharpUnionCase (cenv, v)) + | Union(v, _) -> Some(FSharpUnionCase(cenv, v)) | _ -> None - member _.XmlDocSig = - checkIsResolved() + member _.XmlDocSig = + checkIsResolved () + let xmlsig = - match d with - | RecdOrClass v -> + match d with + | RecdOrClass v -> let recd = RecdFieldInfo(generalizeTypars v.TyconRef.TyparsNoRange, v) GetXmlDocSigOfRecdFieldRef recd.RecdFieldRef - | Union (v, _) -> + | Union(v, _) -> let unionCase = UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange, v) GetXmlDocSigOfUnionCaseRef unionCase.UnionCaseRef - | ILField f -> - GetXmlDocSigOfILFieldInfo cenv.infoReader range0 f + | ILField f -> GetXmlDocSigOfILFieldInfo cenv.infoReader range0 f | AnonField _ -> None + match xmlsig with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" - member _.XmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeXmlDoc else - match d.TryRecdField with - | Choice1Of3 r -> r.XmlDoc - | Choice2Of3 _ -> XmlDoc.Empty - | Choice3Of3 _ -> XmlDoc.Empty - |> makeXmlDoc + member _.XmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeXmlDoc + else + match d.TryRecdField with + | Choice1Of3 r -> r.XmlDoc + | Choice2Of3 _ -> XmlDoc.Empty + | Choice3Of3 _ -> XmlDoc.Empty + |> makeXmlDoc + + member _.ElaboratedXmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeElaboratedXmlDoc + else + match d.TryRecdField with + | Choice1Of3 r -> r.XmlDoc + | Choice2Of3 _ -> XmlDoc.Empty + | Choice3Of3 _ -> XmlDoc.Empty + |> makeElaboratedXmlDoc - member _.ElaboratedXmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeElaboratedXmlDoc else - match d.TryRecdField with - | Choice1Of3 r -> r.XmlDoc - | Choice2Of3 _ -> XmlDoc.Empty - | Choice3Of3 _ -> XmlDoc.Empty - |> makeElaboratedXmlDoc + member _.FieldType = + checkIsResolved () - member _.FieldType = - checkIsResolved() - let fty = - match d.TryRecdField with + let fty = + match d.TryRecdField with | Choice1Of3 r -> r.FormalType | Choice2Of3 f -> f.FieldType(cenv.amap, range0) - | Choice3Of3 (_,tinst,n,_) -> tinst[n] + | Choice3Of3(_, tinst, n, _) -> tinst[n] + FSharpType(cenv, fty) - member _.IsStatic = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.IsStatic - | Choice2Of3 f -> f.IsStatic - | Choice3Of3 _ -> false + member _.IsStatic = + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.IsStatic + | Choice2Of3 f -> f.IsStatic + | Choice3Of3 _ -> false + + member _.Name = + checkIsResolved () - member _.Name = - checkIsResolved() - match d.TryRecdField with + match d.TryRecdField with | Choice1Of3 r -> r.LogicalName | Choice2Of3 f -> f.FieldName - | Choice3Of3 (anonInfo, _tinst, n, _) -> anonInfo.SortedNames[n] + | Choice3Of3(anonInfo, _tinst, n, _) -> anonInfo.SortedNames[n] - member _.IsCompilerGenerated = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.IsCompilerGenerated - | Choice2Of3 _ -> false - | Choice3Of3 _ -> false + member _.IsCompilerGenerated = + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.IsCompilerGenerated + | Choice2Of3 _ -> false + | Choice3Of3 _ -> false member _.IsNameGenerated = - if isUnresolved() then false else - match d.TryRecdField with - | Choice1Of3 r -> r.rfield_name_generated - | _ -> false + if isUnresolved () then + false + else + match d.TryRecdField with + | Choice1Of3 r -> r.rfield_name_generated + | _ -> false + + member _.DeclarationLocation = + checkIsResolved () - member _.DeclarationLocation = - checkIsResolved() - match d.TryRecdField with + match d.TryRecdField with | Choice1Of3 r -> r.Range | Choice2Of3 _ -> range0 - | Choice3Of3 (_anonInfo, _tinst, _n, m) -> m - - member _.FieldAttributes = - if isUnresolved() then makeReadOnlyCollection [] else - match d.TryRecdField with - | Choice1Of3 r -> r.FieldAttribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) - | Choice2Of3 _ -> [] - | Choice3Of3 _ -> [] - |> makeReadOnlyCollection + | Choice3Of3(_anonInfo, _tinst, _n, m) -> m - member _.PropertyAttributes = - if isUnresolved() then makeReadOnlyCollection [] else - match d.TryRecdField with - | Choice1Of3 r -> r.PropertyAttribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) - | Choice2Of3 _ -> [] - | Choice3Of3 _ -> [] - |> makeReadOnlyCollection + member _.FieldAttributes = + if isUnresolved () then + makeReadOnlyCollection [] + else + match d.TryRecdField with + | Choice1Of3 r -> + r.FieldAttribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + | Choice2Of3 _ -> [] + | Choice3Of3 _ -> [] + |> makeReadOnlyCollection - override _.Accessibility: FSharpAccessibility = - if isUnresolved() then FSharpAccessibility taccessPublic else - let access = - match d.TryRecdField with - | Choice1Of3 r -> r.Accessibility - | Choice2Of3 _ -> taccessPublic - | Choice3Of3 _ -> taccessPublic - FSharpAccessibility access + member _.PropertyAttributes = + if isUnresolved () then + makeReadOnlyCollection [] + else + match d.TryRecdField with + | Choice1Of3 r -> + r.PropertyAttribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + | Choice2Of3 _ -> [] + | Choice3Of3 _ -> [] + |> makeReadOnlyCollection + + override _.Accessibility: FSharpAccessibility = + if isUnresolved () then + FSharpAccessibility taccessPublic + else + let access = + match d.TryRecdField with + | Choice1Of3 r -> r.Accessibility + | Choice2Of3 _ -> taccessPublic + | Choice3Of3 _ -> taccessPublic + + FSharpAccessibility access member private x.V = d override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpField as uc -> - match d, uc.V with - | RecdOrClass r1, RecdOrClass r2 -> recdFieldRefOrder.Compare(r1, r2) = 0 - | Union (u1, n1), Union (u2, n2) -> cenv.g.unionCaseRefEq u1 u2 && n1 = n2 - | AnonField (anonInfo1, _, _, _), AnonField (anonInfo2, _, _, _) -> x.Name = uc.Name && anonInfoEquiv anonInfo1 anonInfo2 - | _ -> false - | _ -> false + box x === other + || match other with + | :? FSharpField as uc -> + match d, uc.V with + | RecdOrClass r1, RecdOrClass r2 -> recdFieldRefOrder.Compare(r1, r2) = 0 + | Union(u1, n1), Union(u2, n2) -> cenv.g.unionCaseRefEq u1 u2 && n1 = n2 + | AnonField(anonInfo1, _, _, _), AnonField(anonInfo2, _, _, _) -> x.Name = uc.Name && anonInfoEquiv anonInfo1 anonInfo2 + | _ -> false + | _ -> false override x.GetHashCode() = hash x.Name override x.ToString() = "field " + x.Name -type [] FSharpAccessibilityRights(thisCcu: CcuThunk, ad:AccessorDomain) = +[] +type FSharpAccessibilityRights(thisCcu: CcuThunk, ad: AccessorDomain) = member internal _.ThisCcu = thisCcu member internal _.Contents = ad -type FSharpActivePatternCase(cenv, apinfo: ActivePatternInfo, ty, n, valOpt: ValRef option, item) = +type FSharpActivePatternCase(cenv, apinfo: ActivePatternInfo, ty, n, valOpt: ValRef option, item) = - inherit FSharpSymbol (cenv, - (fun () -> item), - (fun _ _ _ -> true)) + inherit FSharpSymbol(cenv, (fun () -> item), (fun _ _ _ -> true)) member _.Name = apinfo.ActiveTags[n] @@ -1326,24 +1490,25 @@ type FSharpActivePatternCase(cenv, apinfo: ActivePatternInfo, ty, n, valOpt: Val member _.Group = FSharpActivePatternGroup(cenv, apinfo, ty, valOpt) - member _.XmlDoc = + member _.XmlDoc = defaultArg (valOpt |> Option.map (fun vref -> vref.XmlDoc)) XmlDoc.Empty |> makeXmlDoc - member _.ElaboratedXmlDoc = + member _.ElaboratedXmlDoc = defaultArg (valOpt |> Option.map (fun vref -> vref.XmlDoc)) XmlDoc.Empty |> makeElaboratedXmlDoc - member _.XmlDocSig = - let xmlsig = + member _.XmlDocSig = + let xmlsig = match valOpt with | Some valref -> GetXmlDocSigOfValRef cenv.g valref | None -> None + match xmlsig with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" -type FSharpActivePatternGroup(cenv, apinfo:ActivePatternInfo, ty, valOpt) = +type FSharpActivePatternGroup(cenv, apinfo: ActivePatternInfo, ty, valOpt) = member _.Name = valOpt |> Option.map (fun vref -> vref.LogicalName) @@ -1353,18 +1518,16 @@ type FSharpActivePatternGroup(cenv, apinfo:ActivePatternInfo, ty, valOpt) = member _.OverallType = FSharpType(cenv, ty) - member _.DeclaringEntity = - valOpt - |> Option.bind (fun vref -> - match vref.TryDeclaringEntity with + member _.DeclaringEntity = + valOpt + |> Option.bind (fun vref -> + match vref.TryDeclaringEntity with | ParentNone -> None - | Parent tcref -> Some (FSharpEntity(cenv, tcref))) + | Parent tcref -> Some(FSharpEntity(cenv, tcref))) -type FSharpGenericParameter(cenv, v:Typar) = +type FSharpGenericParameter(cenv, v: Typar) = - inherit FSharpSymbol (cenv, - (fun () -> Item.TypeVar(v.Name, v)), - (fun _ _ _ad -> true)) + inherit FSharpSymbol(cenv, (fun () -> Item.TypeVar(v.Name, v)), (fun _ _ _ad -> true)) member _.Range = v.Range @@ -1373,7 +1536,7 @@ type FSharpGenericParameter(cenv, v:Typar) = member _.DeclarationLocation = v.Range member _.IsCompilerGenerated = v.IsCompilerGenerated - + member _.IsMeasure = (v.Kind = TyparKind.Measure) member _.XmlDoc = v.XmlDoc |> makeXmlDoc @@ -1382,41 +1545,48 @@ type FSharpGenericParameter(cenv, v:Typar) = member _.IsSolveAtCompileTime = (v.StaticReq = TyparStaticReq.HeadType) - override _.Attributes = - // INCOMPLETENESS: If the type parameter comes from .NET then the .NET metadata for the type parameter - // has been lost (it is not accessible via Typar). So we can't easily report the attributes in this - // case. - v.Attribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) |> makeReadOnlyCollection - member _.Constraints = v.Constraints |> List.map (fun a -> FSharpGenericParameterConstraint(cenv, a)) |> makeReadOnlyCollection - + override _.Attributes = + // INCOMPLETENESS: If the type parameter comes from .NET then the .NET metadata for the type parameter + // has been lost (it is not accessible via Typar). So we can't easily report the attributes in this + // case. + v.Attribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + |> makeReadOnlyCollection + + member _.Constraints = + v.Constraints + |> List.map (fun a -> FSharpGenericParameterConstraint(cenv, a)) + |> makeReadOnlyCollection + member internal x.TypeParameter = v override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpGenericParameter as p -> typarRefEq v p.TypeParameter - | _ -> false + box x === other + || match other with + | :? FSharpGenericParameter as p -> typarRefEq v p.TypeParameter + | _ -> false override x.GetHashCode() = (hash v.Stamp) override x.ToString() = "generic parameter " + x.Name -type FSharpDelegateSignature(cenv, info: SlotSig) = +type FSharpDelegateSignature(cenv, info: SlotSig) = - member _.DelegateArguments = + member _.DelegateArguments = info.FormalParams.Head |> List.map (fun (TSlotParam(nm, ty, _, _, _, _)) -> nm, FSharpType(cenv, ty)) |> makeReadOnlyCollection - member _.DelegateReturnType = + member _.DelegateReturnType = match info.FormalReturnType with | None -> FSharpType(cenv, cenv.g.unit_ty) | Some ty -> FSharpType(cenv, ty) + override x.ToString() = "" type FSharpAbstractParameter(cenv, info: SlotParam) = - member _.Name = + member _.Name = let (TSlotParam(name, _, _, _, _, _)) = info name @@ -1436,181 +1606,187 @@ type FSharpAbstractParameter(cenv, info: SlotParam) = member _.Attributes = let (TSlotParam(_, _, _, _, _, attribs)) = info - attribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + + attribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) |> makeReadOnlyCollection type FSharpAbstractSignature(cenv, info: SlotSig) = - member _.AbstractArguments = + member _.AbstractArguments = info.FormalParams |> List.map (List.map (fun p -> FSharpAbstractParameter(cenv, p)) >> makeReadOnlyCollection) |> makeReadOnlyCollection - member _.AbstractReturnType = + member _.AbstractReturnType = match info.FormalReturnType with | None -> FSharpType(cenv, cenv.g.unit_ty) | Some ty -> FSharpType(cenv, ty) member _.DeclaringTypeGenericParameters = - info.ClassTypars + info.ClassTypars |> List.map (fun t -> FSharpGenericParameter(cenv, t)) |> makeReadOnlyCollection - + member _.MethodGenericParameters = - info.MethodTypars + info.MethodTypars |> List.map (fun t -> FSharpGenericParameter(cenv, t)) |> makeReadOnlyCollection - member _.Name = info.Name - + member _.Name = info.Name + member _.DeclaringType = FSharpType(cenv, info.DeclaringType) -type FSharpGenericParameterMemberConstraint(cenv, info: TraitConstraintInfo) = - inherit FSharpSymbol (cenv, - (fun () -> Item.Trait(info)), - (fun _ _ _ad -> true)) +type FSharpGenericParameterMemberConstraint(cenv, info: TraitConstraintInfo) = + inherit FSharpSymbol(cenv, (fun () -> Item.Trait(info)), (fun _ _ _ad -> true)) - member _.MemberSources = - info.SupportTypes |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection + member _.MemberSources = + info.SupportTypes + |> List.map (fun ty -> FSharpType(cenv, ty)) + |> makeReadOnlyCollection member _.MemberName = info.MemberLogicalName member _.MemberIsStatic = not info.MemberFlags.IsInstance member _.MemberArgumentTypes = - info.CompiledObjectAndArgumentTypes |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection + info.CompiledObjectAndArgumentTypes + |> List.map (fun ty -> FSharpType(cenv, ty)) + |> makeReadOnlyCollection member _.MemberReturnType = - match info.CompiledReturnType with - | None -> FSharpType(cenv, cenv.g.unit_ty) - | Some ty -> FSharpType(cenv, ty) - override x.ToString() = "" + match info.CompiledReturnType with + | None -> FSharpType(cenv, cenv.g.unit_ty) + | Some ty -> FSharpType(cenv, ty) + override x.ToString() = "" -type FSharpGenericParameterDelegateConstraint(cenv, tupledArgTy: TType, retTy: TType) = +type FSharpGenericParameterDelegateConstraint(cenv, tupledArgTy: TType, retTy: TType) = member _.DelegateTupledArgumentType = FSharpType(cenv, tupledArgTy) - member _.DelegateReturnType = FSharpType(cenv, retTy) + member _.DelegateReturnType = FSharpType(cenv, retTy) override x.ToString() = "" -type FSharpGenericParameterDefaultsToConstraint(cenv, pri:int, ty:TType) = - member _.DefaultsToPriority = pri - member _.DefaultsToTarget = FSharpType(cenv, ty) +type FSharpGenericParameterDefaultsToConstraint(cenv, pri: int, ty: TType) = + member _.DefaultsToPriority = pri + member _.DefaultsToTarget = FSharpType(cenv, ty) override x.ToString() = "" -type FSharpGenericParameterConstraint(cenv, cx: TyparConstraint) = +type FSharpGenericParameterConstraint(cenv, cx: TyparConstraint) = - member _.IsCoercesToConstraint = - match cx with - | TyparConstraint.CoercesTo _ -> true + member _.IsCoercesToConstraint = + match cx with + | TyparConstraint.CoercesTo _ -> true | _ -> false - member _.CoercesToTarget = - match cx with - | TyparConstraint.CoercesTo(ty, _) -> FSharpType(cenv, ty) + member _.CoercesToTarget = + match cx with + | TyparConstraint.CoercesTo(ty, _) -> FSharpType(cenv, ty) | _ -> invalidOp "not a coerces-to constraint" - member _.IsDefaultsToConstraint = - match cx with - | TyparConstraint.DefaultsTo _ -> true + member _.IsDefaultsToConstraint = + match cx with + | TyparConstraint.DefaultsTo _ -> true | _ -> false - member _.DefaultsToConstraintData = - match cx with - | TyparConstraint.DefaultsTo(pri, ty, _) -> FSharpGenericParameterDefaultsToConstraint(cenv, pri, ty) + member _.DefaultsToConstraintData = + match cx with + | TyparConstraint.DefaultsTo(pri, ty, _) -> FSharpGenericParameterDefaultsToConstraint(cenv, pri, ty) | _ -> invalidOp "not a 'defaults-to' constraint" - member _.IsSupportsNullConstraint = match cx with TyparConstraint.SupportsNull _ -> true | _ -> false + member _.IsSupportsNullConstraint = + match cx with + | TyparConstraint.SupportsNull _ -> true + | _ -> false - member _.IsMemberConstraint = - match cx with - | TyparConstraint.MayResolveMember _ -> true + member _.IsMemberConstraint = + match cx with + | TyparConstraint.MayResolveMember _ -> true | _ -> false - member _.MemberConstraintData = - match cx with - | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) + member _.MemberConstraintData = + match cx with + | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) | _ -> invalidOp "not a member constraint" - member _.IsNonNullableValueTypeConstraint = - match cx with - | TyparConstraint.IsNonNullableStruct _ -> true + member _.IsNonNullableValueTypeConstraint = + match cx with + | TyparConstraint.IsNonNullableStruct _ -> true | _ -> false - - member _.IsReferenceTypeConstraint = - match cx with - | TyparConstraint.IsReferenceType _ -> true + + member _.IsReferenceTypeConstraint = + match cx with + | TyparConstraint.IsReferenceType _ -> true | _ -> false - member _.IsSimpleChoiceConstraint = - match cx with - | TyparConstraint.SimpleChoice _ -> true + member _.IsSimpleChoiceConstraint = + match cx with + | TyparConstraint.SimpleChoice _ -> true | _ -> false - member _.SimpleChoices = - match cx with - | TyparConstraint.SimpleChoice (tys, _) -> - tys |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection + member _.SimpleChoices = + match cx with + | TyparConstraint.SimpleChoice(tys, _) -> tys |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection | _ -> invalidOp "incorrect constraint kind" - member _.IsRequiresDefaultConstructorConstraint = - match cx with - | TyparConstraint.RequiresDefaultConstructor _ -> true + member _.IsRequiresDefaultConstructorConstraint = + match cx with + | TyparConstraint.RequiresDefaultConstructor _ -> true | _ -> false - member _.IsEnumConstraint = - match cx with - | TyparConstraint.IsEnum _ -> true + member _.IsEnumConstraint = + match cx with + | TyparConstraint.IsEnum _ -> true | _ -> false - member _.EnumConstraintTarget = - match cx with + member _.EnumConstraintTarget = + match cx with | TyparConstraint.IsEnum(ty, _) -> FSharpType(cenv, ty) | _ -> invalidOp "incorrect constraint kind" - - member _.IsComparisonConstraint = - match cx with - | TyparConstraint.SupportsComparison _ -> true + + member _.IsComparisonConstraint = + match cx with + | TyparConstraint.SupportsComparison _ -> true | _ -> false - member _.IsNotSupportsNullConstraint = - match cx with - | TyparConstraint.NotSupportsNull _ -> true + member _.IsNotSupportsNullConstraint = + match cx with + | TyparConstraint.NotSupportsNull _ -> true | _ -> false - member _.IsEqualityConstraint = - match cx with - | TyparConstraint.SupportsEquality _ -> true + member _.IsEqualityConstraint = + match cx with + | TyparConstraint.SupportsEquality _ -> true | _ -> false - member _.IsUnmanagedConstraint = - match cx with - | TyparConstraint.IsUnmanaged _ -> true + member _.IsUnmanagedConstraint = + match cx with + | TyparConstraint.IsUnmanaged _ -> true | _ -> false - member _.IsDelegateConstraint = - match cx with - | TyparConstraint.IsDelegate _ -> true + member _.IsDelegateConstraint = + match cx with + | TyparConstraint.IsDelegate _ -> true | _ -> false - member _.DelegateConstraintData = - match cx with - | TyparConstraint.IsDelegate(ty1, ty2, _) -> FSharpGenericParameterDelegateConstraint(cenv, ty1, ty2) + member _.DelegateConstraintData = + match cx with + | TyparConstraint.IsDelegate(ty1, ty2, _) -> FSharpGenericParameterDelegateConstraint(cenv, ty1, ty2) | _ -> invalidOp "not a delegate constraint" - member _.IsAllowsRefStructConstraint = - match cx with - | TyparConstraint.AllowsRefStruct _ -> true + member _.IsAllowsRefStructConstraint = + match cx with + | TyparConstraint.AllowsRefStruct _ -> true | _ -> false override x.ToString() = "" -type FSharpInlineAnnotation = - | AlwaysInline - | OptionalInline - | NeverInline - | AggressiveInline +type FSharpInlineAnnotation = + | AlwaysInline + | OptionalInline + | NeverInline + | AggressiveInline -type FSharpMemberOrValData = +type FSharpMemberOrValData = | E of EventInfo | P of PropInfo | M of MethInfo @@ -1619,78 +1795,93 @@ type FSharpMemberOrValData = type FSharpMemberOrVal = FSharpMemberOrFunctionOrValue -type FSharpMemberFunctionOrValue = FSharpMemberOrFunctionOrValue - -type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = - - inherit FSharpSymbol(cenv, - (fun () -> item), - (fun this thisCcu2 ad -> - let this = this :?> FSharpMemberOrFunctionOrValue - checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, this.Accessibility.Contents)) - //&& - //match d with - //| E e -> - // match e with - // | EventInfo.ILEvent (_, e) -> AccessibilityLogic.IsILEventInfoAccessible g cenv.amap range0 ad e - // | EventInfo.FSEvent (_, _, vref, _) -> AccessibilityLogic.IsValAccessible ad vref - // | _ -> true - //| M m -> AccessibilityLogic.IsMethInfoAccessible cenv.amap range0 ad m - //| P p -> AccessibilityLogic.IsPropInfoAccessible g cenv.amap range0 ad p - //| V v -> AccessibilityLogic.IsValAccessible ad v - ) - - let fsharpInfo() = - match d with - | M m | C m -> m.ArbitraryValRef - | P p -> p.ArbitraryValRef - | E e -> e.ArbitraryValRef +type FSharpMemberFunctionOrValue = FSharpMemberOrFunctionOrValue + +type FSharpMemberOrFunctionOrValue(cenv, d: FSharpMemberOrValData, item) = + + inherit + FSharpSymbol( + cenv, + (fun () -> item), + (fun this thisCcu2 ad -> + let this = this :?> FSharpMemberOrFunctionOrValue + checkForCrossProjectAccessibility cenv.g.ilg (thisCcu2, ad) (cenv.thisCcu, this.Accessibility.Contents)) + //&& + //match d with + //| E e -> + // match e with + // | EventInfo.ILEvent (_, e) -> AccessibilityLogic.IsILEventInfoAccessible g cenv.amap range0 ad e + // | EventInfo.FSEvent (_, _, vref, _) -> AccessibilityLogic.IsValAccessible ad vref + // | _ -> true + //| M m -> AccessibilityLogic.IsMethInfoAccessible cenv.amap range0 ad m + //| P p -> AccessibilityLogic.IsPropInfoAccessible g cenv.amap range0 ad p + //| V v -> AccessibilityLogic.IsValAccessible ad v + ) + + let fsharpInfo () = + match d with + | M m + | C m -> m.ArbitraryValRef + | P p -> p.ArbitraryValRef + | E e -> e.ArbitraryValRef | V v -> Some v - - let isUnresolved() = - match fsharpInfo() with + + let isUnresolved () = + match fsharpInfo () with | None -> false | Some v -> v.TryDeref.IsNone - let checkIsResolved() = - if isUnresolved() then - let v = (fsharpInfo()).Value - let nm = (match v with VRefNonLocal n -> n.ItemKey.PartialKey.LogicalName | _ -> "") + let checkIsResolved () = + if isUnresolved () then + let v = (fsharpInfo ()).Value + + let nm = + (match v with + | VRefNonLocal n -> n.ItemKey.PartialKey.LogicalName + | _ -> "") + invalidOp (sprintf "The value or member '%s' does not exist or is in an unresolved assembly." nm) - let mkMethSym minfo = FSharpMemberOrFunctionOrValue(cenv, M minfo, Item.MethodGroup (minfo.DisplayName, [minfo], None)) - let mkEventSym einfo = FSharpMemberOrFunctionOrValue(cenv, E einfo, Item.Event einfo) + let mkMethSym minfo = + FSharpMemberOrFunctionOrValue(cenv, M minfo, Item.MethodGroup(minfo.DisplayName, [ minfo ], None)) + + let mkEventSym einfo = + FSharpMemberOrFunctionOrValue(cenv, E einfo, Item.Event einfo) - new (cenv, vref) = FSharpMemberFunctionOrValue(cenv, V vref, Item.Value vref) + new(cenv, vref) = FSharpMemberFunctionOrValue(cenv, V vref, Item.Value vref) - new (cenv, minfo: MethInfo) = + new(cenv, minfo: MethInfo) = if minfo.IsConstructor || minfo.IsClassConstructor then - FSharpMemberFunctionOrValue(cenv, C minfo, Item.CtorGroup(minfo.LogicalName, [minfo])) + FSharpMemberFunctionOrValue(cenv, C minfo, Item.CtorGroup(minfo.LogicalName, [ minfo ])) else - FSharpMemberFunctionOrValue(cenv, M minfo, Item.MethodGroup(minfo.LogicalName, [minfo], None)) + FSharpMemberFunctionOrValue(cenv, M minfo, Item.MethodGroup(minfo.LogicalName, [ minfo ], None)) - member _.IsUnresolved = - isUnresolved() + member _.IsUnresolved = isUnresolved () - member _.DeclarationLocationOpt = - checkIsResolved() - match fsharpInfo() with + member _.DeclarationLocationOpt = + checkIsResolved () + + match fsharpInfo () with | Some v -> Some v.Range - | None -> base.DeclarationLocation + | None -> base.DeclarationLocation member x.GetOverloads matchParameterNumber = - checkIsResolved() + checkIsResolved () + match d with - | M m | C m -> + | M m + | C m -> match item with - | Item.MethodGroup (_, methodInfos, _) - | Item.CtorGroup (_, methodInfos) -> + | Item.MethodGroup(_, methodInfos, _) + | Item.CtorGroup(_, methodInfos) -> let isConstructor = x.IsConstructor + let methods = if matchParameterNumber then + methodInfos |> List.filter (fun methodInfo -> methodInfo.NumArgs <> m.NumArgs) + else methodInfos - |> List.filter (fun methodInfo -> methodInfo.NumArgs <> m.NumArgs ) - else methodInfos + methods |> List.map (fun mi -> if isConstructor then @@ -1702,65 +1893,79 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | _ -> None | _ -> None - member x.DeclarationLocation = - checkIsResolved() - match x.DeclarationLocationOpt with + member x.DeclarationLocation = + checkIsResolved () + + match x.DeclarationLocationOpt with | Some v -> v | None -> failwith "DeclarationLocation property not available" - member _.DeclaringEntity: FSharpEntity option = - checkIsResolved() - match d with + member _.DeclaringEntity: FSharpEntity option = + checkIsResolved () + + match d with | E e -> FSharpEntity(cenv, e.DeclaringTyconRef) |> Some | P p -> FSharpEntity(cenv, p.DeclaringTyconRef) |> Some - | M m | C m -> FSharpEntity(cenv, m.DeclaringTyconRef) |> Some - | V v -> - match v.TryDeclaringEntity with - | ParentNone -> None - | Parent p -> FSharpEntity(cenv, p) |> Some + | M m + | C m -> FSharpEntity(cenv, m.DeclaringTyconRef) |> Some + | V v -> + match v.TryDeclaringEntity with + | ParentNone -> None + | Parent p -> FSharpEntity(cenv, p) |> Some - member _.ApparentEnclosingEntity: FSharpEntity = + member _.ApparentEnclosingEntity: FSharpEntity = let createEntity (ttype: TType) = let tcref, tyargs = destAppTy cenv.g ttype FSharpEntity(cenv, tcref, tyargs) - checkIsResolved() - match d with + checkIsResolved () + + match d with | E e -> createEntity e.ApparentEnclosingType | P p -> createEntity p.ApparentEnclosingType - | M m | C m -> createEntity m.ApparentEnclosingType - | V v -> - match v.ApparentEnclosingEntity with - | ParentNone -> invalidOp "the value or member doesn't have a logical parent" - | Parent p -> FSharpEntity(cenv, p) - - member _.GenericParameters = - checkIsResolved() - let tps = - match d with + | M m + | C m -> createEntity m.ApparentEnclosingType + | V v -> + match v.ApparentEnclosingEntity with + | ParentNone -> invalidOp "the value or member doesn't have a logical parent" + | Parent p -> FSharpEntity(cenv, p) + + member _.GenericParameters = + checkIsResolved () + + let tps = + match d with | E _ -> [] | P _ -> [] - | M m | C m -> m.FormalMethodTypars - | V v -> v.Typars - tps |> List.map (fun tp -> FSharpGenericParameter(cenv, tp)) |> makeReadOnlyCollection - - member _.FullType = - checkIsResolved() - let ty = - match d with + | M m + | C m -> m.FormalMethodTypars + | V v -> v.Typars + + tps + |> List.map (fun tp -> FSharpGenericParameter(cenv, tp)) + |> makeReadOnlyCollection + + member _.FullType = + checkIsResolved () + + let ty = + match d with | E e -> e.GetDelegateType(cenv.amap, range0) | P p -> p.GetPropertyType(cenv.amap, range0) - | M m | C m -> + | M m + | C m -> let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) - let argTysl = m.GetParamTypes(cenv.amap, range0, m.FormalMethodInst) + let argTysl = m.GetParamTypes(cenv.amap, range0, m.FormalMethodInst) mkIteratedFunTy cenv.g (List.map (mkRefTupledTy cenv.g) argTysl) retTy | V v -> v.TauType + FSharpType(cenv, ty) member _.HasGetterMethod = - if isUnresolved() then false + if isUnresolved () then + false else - match d with + match d with | P p -> p.HasGetter | E _ | M _ @@ -1768,15 +1973,20 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | V _ -> false member _.GetterMethod = - checkIsResolved() - match d with + checkIsResolved () + + match d with | P p -> mkMethSym p.GetterMethod - | E _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated getter method" + | E _ + | M _ + | C _ + | V _ -> invalidOp "the value or member doesn't have an associated getter method" member _.HasSetterMethod = - if isUnresolved() then false + if isUnresolved () then + false else - match d with + match d with | P p -> p.HasSetter | E _ | M _ @@ -1784,522 +1994,800 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | V _ -> false member _.SetterMethod = - checkIsResolved() - match d with + checkIsResolved () + + match d with | P p -> mkMethSym p.SetterMethod - | E _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated setter method" + | E _ + | M _ + | C _ + | V _ -> invalidOp "the value or member doesn't have an associated setter method" member _.IsUnionCaseTester = - checkIsResolved() + checkIsResolved () + match d with | P p -> p.IsUnionCaseTester | M m -> m.IsUnionCaseTester | V v -> - v.IsPropertyGetterMethod && - v.LogicalName.StartsWith("get_Is") && - v.IsImplied && v.MemberApparentEntity.IsUnionTycon - | E _ | C _ -> false + v.IsPropertyGetterMethod + && v.LogicalName.StartsWith("get_Is") + && v.IsImplied + && v.MemberApparentEntity.IsUnionTycon + | E _ + | C _ -> false member _.EventAddMethod = - checkIsResolved() - match d with + checkIsResolved () + + match d with | E e -> mkMethSym e.AddMethod - | P _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated add method" + | P _ + | M _ + | C _ + | V _ -> invalidOp "the value or member doesn't have an associated add method" member _.EventRemoveMethod = - checkIsResolved() - match d with + checkIsResolved () + + match d with | E e -> mkMethSym e.RemoveMethod - | P _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated remove method" + | P _ + | M _ + | C _ + | V _ -> invalidOp "the value or member doesn't have an associated remove method" member _.EventDelegateType = - checkIsResolved() - match d with + checkIsResolved () + + match d with | E e -> FSharpType(cenv, e.GetDelegateType(cenv.amap, range0)) - | P _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated event delegate type" + | P _ + | M _ + | C _ + | V _ -> invalidOp "the value or member doesn't have an associated event delegate type" member _.EventIsStandard = - checkIsResolved() - match d with - | E e -> + checkIsResolved () + + match d with + | E e -> let dty = e.GetDelegateType(cenv.amap, range0) - TryDestStandardDelegateType cenv.infoReader range0 AccessibleFromSomewhere dty |> Option.isSome - | P _ | M _ | C _ | V _ -> invalidOp "the value or member is not an event" - member _.IsCompilerGenerated = - if isUnresolved() then false else - match fsharpInfo() with - | None -> false - | Some v -> - v.IsCompilerGenerated - - member _.InlineAnnotation = - if isUnresolved() then FSharpInlineAnnotation.OptionalInline else - match fsharpInfo() with - | None -> FSharpInlineAnnotation.OptionalInline - | Some v -> - match v.InlineInfo with - | ValInline.Always -> FSharpInlineAnnotation.AlwaysInline - | ValInline.Optional -> FSharpInlineAnnotation.OptionalInline - | ValInline.Never -> FSharpInlineAnnotation.NeverInline - - member _.IsMutable = - if isUnresolved() then false else - match d with - | M _ | C _ | P _ | E _ -> false - | V v -> v.IsMutable - - member _.IsModuleValueOrMember = - if isUnresolved() then false else - match d with - | M _ | C _ | P _ | E _ -> true - | V v -> v.IsMember || v.IsModuleBinding - - member _.IsMember = - if isUnresolved() then false else - match d with - | M _ | C _ | P _ | E _ -> true - | V v -> v.IsMember - - member _.IsDispatchSlot = - if isUnresolved() then false else - match d with - | E e -> e.AddMethod.IsDispatchSlot - | P p -> p.IsDispatchSlot - | M m | C m -> m.IsDispatchSlot - | V v -> v.IsDispatchSlot + TryDestStandardDelegateType cenv.infoReader range0 AccessibleFromSomewhere dty + |> Option.isSome + | P _ + | M _ + | C _ + | V _ -> invalidOp "the value or member is not an event" + + member _.IsCompilerGenerated = + if isUnresolved () then + false + else + match fsharpInfo () with + | None -> false + | Some v -> v.IsCompilerGenerated + + member _.InlineAnnotation = + if isUnresolved () then + FSharpInlineAnnotation.OptionalInline + else + match fsharpInfo () with + | None -> FSharpInlineAnnotation.OptionalInline + | Some v -> + match v.InlineInfo with + | ValInline.Always -> FSharpInlineAnnotation.AlwaysInline + | ValInline.Optional -> FSharpInlineAnnotation.OptionalInline + | ValInline.Never -> FSharpInlineAnnotation.NeverInline + + member _.IsMutable = + if isUnresolved () then + false + else + match d with + | M _ + | C _ + | P _ + | E _ -> false + | V v -> v.IsMutable + + member _.IsModuleValueOrMember = + if isUnresolved () then + false + else + match d with + | M _ + | C _ + | P _ + | E _ -> true + | V v -> v.IsMember || v.IsModuleBinding + + member _.IsMember = + if isUnresolved () then + false + else + match d with + | M _ + | C _ + | P _ + | E _ -> true + | V v -> v.IsMember + + member _.IsDispatchSlot = + if isUnresolved () then + false + else + match d with + | E e -> e.AddMethod.IsDispatchSlot + | P p -> p.IsDispatchSlot + | M m + | C m -> m.IsDispatchSlot + | V v -> v.IsDispatchSlot member _.IsMethod = match d with | M _ -> true | _ -> false - member x.IsProperty = - match d with + member x.IsProperty = + match d with | P _ -> true | _ -> false member x.HasSignatureFile = - match fsharpInfo() with + match fsharpInfo () with | None -> false | Some vref -> match vref.TryDeref with | ValueNone -> false | ValueSome v -> v.HasSignatureFile - - member _.IsEvent = - match d with + + member _.IsEvent = + match d with | E _ -> true | _ -> false - member _.EventForFSharpProperty = - match d with - | P p when p.IsFSharpEventProperty -> - let minfos1 = GetImmediateIntrinsicMethInfosOfType (Some("add_"+p.PropertyName), AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 p.ApparentEnclosingType - let minfos2 = GetImmediateIntrinsicMethInfosOfType (Some("remove_"+p.PropertyName), AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 p.ApparentEnclosingType - match minfos1, minfos2 with - | [addMeth], [removeMeth] -> - match addMeth.ArbitraryValRef, removeMeth.ArbitraryValRef with - | Some addVal, Some removeVal -> Some (mkEventSym (FSEvent(cenv.g, p, addVal, removeVal))) + member _.EventForFSharpProperty = + match d with + | P p when p.IsFSharpEventProperty -> + let minfos1 = + GetImmediateIntrinsicMethInfosOfType + (Some("add_" + p.PropertyName), AccessibleFromSomeFSharpCode) + cenv.g + cenv.amap + range0 + p.ApparentEnclosingType + + let minfos2 = + GetImmediateIntrinsicMethInfosOfType + (Some("remove_" + p.PropertyName), AccessibleFromSomeFSharpCode) + cenv.g + cenv.amap + range0 + p.ApparentEnclosingType + + match minfos1, minfos2 with + | [ addMeth ], [ removeMeth ] -> + match addMeth.ArbitraryValRef, removeMeth.ArbitraryValRef with + | Some addVal, Some removeVal -> Some(mkEventSym (FSEvent(cenv.g, p, addVal, removeVal))) | _ -> None | _ -> None | _ -> None - member _.IsEventAddMethod = - if isUnresolved() then false else - match d with - | M m -> - let logicalName = m.LogicalName - logicalName.Length > 4 && logicalName.StartsWithOrdinal("add_") && - - let eventName = logicalName[4..] - let entityTy = generalizedTyconRef cenv.g m.DeclaringTyconRef - not (isNil (cenv.infoReader.GetImmediateIntrinsicEventsOfType (Some eventName, AccessibleFromSomeFSharpCode, range0, entityTy))) || - let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef - match GetImmediateIntrinsicPropInfosOfType (Some eventName, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 declaringTy with - | pinfo :: _ -> pinfo.IsFSharpEventProperty - | _ -> false - - | _ -> false + member _.IsEventAddMethod = + if isUnresolved () then + false + else + match d with + | M m -> + let logicalName = m.LogicalName + + logicalName.Length > 4 + && logicalName.StartsWithOrdinal("add_") + && + + let eventName = logicalName[4..] in + let entityTy = generalizedTyconRef cenv.g m.DeclaringTyconRef in + + not ( + isNil ( + cenv.infoReader.GetImmediateIntrinsicEventsOfType(Some eventName, AccessibleFromSomeFSharpCode, range0, entityTy) + ) + ) + || let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef in + + match + GetImmediateIntrinsicPropInfosOfType + (Some eventName, AccessibleFromSomeFSharpCode) + cenv.g + cenv.amap + range0 + declaringTy + with + | pinfo :: _ -> pinfo.IsFSharpEventProperty + | _ -> false - member _.IsEventRemoveMethod = - if isUnresolved() then false else - match d with - | M m -> - let logicalName = m.LogicalName - logicalName.Length > 4 && logicalName.StartsWithOrdinal("remove_") && - - let eventName = logicalName[7..] - let entityTy = generalizedTyconRef cenv.g m.DeclaringTyconRef - not (isNil (cenv.infoReader.GetImmediateIntrinsicEventsOfType (Some eventName, AccessibleFromSomeFSharpCode, range0, entityTy))) || - let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef - match GetImmediateIntrinsicPropInfosOfType (Some eventName, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 declaringTy with - | pinfo :: _ -> pinfo.IsFSharpEventProperty | _ -> false - | _ -> false - - member _.IsPropertyGetterMethod = - if isUnresolved() then false else - match d with - | M m -> - let logicalName = m.LogicalName - logicalName.Length > 4 && logicalName.StartsWithOrdinal("get_") && - let propName = ChopPropertyName(logicalName) - let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef - not (isNil (GetImmediateIntrinsicPropInfosOfType (Some propName, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 declaringTy)) - | V v -> v.IsPropertyGetterMethod - | _ -> false + member _.IsEventRemoveMethod = + if isUnresolved () then + false + else + match d with + | M m -> + let logicalName = m.LogicalName + + logicalName.Length > 4 + && logicalName.StartsWithOrdinal("remove_") + && + + let eventName = logicalName[7..] in + let entityTy = generalizedTyconRef cenv.g m.DeclaringTyconRef in + + not ( + isNil ( + cenv.infoReader.GetImmediateIntrinsicEventsOfType(Some eventName, AccessibleFromSomeFSharpCode, range0, entityTy) + ) + ) + || let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef in + + match + GetImmediateIntrinsicPropInfosOfType + (Some eventName, AccessibleFromSomeFSharpCode) + cenv.g + cenv.amap + range0 + declaringTy + with + | pinfo :: _ -> pinfo.IsFSharpEventProperty + | _ -> false + | _ -> false - member _.IsPropertySetterMethod = - if isUnresolved() then false else - match d with - | M m -> - let logicalName = m.LogicalName - logicalName.Length > 4 && logicalName.StartsWithOrdinal("set_") && + member _.IsPropertyGetterMethod = + if isUnresolved () then + false + else + match d with + | M m -> + let logicalName = m.LogicalName + + logicalName.Length > 4 + && logicalName.StartsWithOrdinal("get_") + && + + let propName = ChopPropertyName(logicalName) in + let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef in + + not ( + isNil ( + GetImmediateIntrinsicPropInfosOfType + (Some propName, AccessibleFromSomeFSharpCode) + cenv.g + cenv.amap + range0 + declaringTy + ) + ) + | V v -> v.IsPropertyGetterMethod + | _ -> false - let propName = ChopPropertyName(logicalName) - let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef - not (isNil (GetImmediateIntrinsicPropInfosOfType (Some propName, AccessibleFromSomeFSharpCode) cenv.g cenv.amap range0 declaringTy)) - | V v -> v.IsPropertySetterMethod - | _ -> false + member _.IsPropertySetterMethod = + if isUnresolved () then + false + else + match d with + | M m -> + let logicalName = m.LogicalName + + logicalName.Length > 4 + && logicalName.StartsWithOrdinal("set_") + && + + let propName = ChopPropertyName(logicalName) in + let declaringTy = generalizedTyconRef cenv.g m.DeclaringTyconRef in + + not ( + isNil ( + GetImmediateIntrinsicPropInfosOfType + (Some propName, AccessibleFromSomeFSharpCode) + cenv.g + cenv.amap + range0 + declaringTy + ) + ) + | V v -> v.IsPropertySetterMethod + | _ -> false - member _.IsInstanceMember = - if isUnresolved() then false else - match d with - | E e -> not e.IsStatic - | P p -> not p.IsStatic - | M m | C m -> m.IsInstance - | V v -> v.IsInstanceMember - - member x.IsInstanceMemberInCompiledCode = - if isUnresolved() then false else - x.IsInstanceMember && - match d with - | E e -> match e.ArbitraryValRef with Some vref -> ValRefIsCompiledAsInstanceMember cenv.g vref | None -> true - | P p -> match p.ArbitraryValRef with Some vref -> ValRefIsCompiledAsInstanceMember cenv.g vref | None -> true - | M m | C m -> match m.ArbitraryValRef with Some vref -> ValRefIsCompiledAsInstanceMember cenv.g vref | None -> true - | V vref -> ValRefIsCompiledAsInstanceMember cenv.g vref - - member _.IsExtensionMember = - if isUnresolved() then false else - match d with - | E e -> e.AddMethod.IsExtensionMember - | P p -> p.IsExtensionMember - | M m -> m.IsExtensionMember - | V v -> v.IsExtensionMember - | C _ -> false + member _.IsInstanceMember = + if isUnresolved () then + false + else + match d with + | E e -> not e.IsStatic + | P p -> not p.IsStatic + | M m + | C m -> m.IsInstance + | V v -> v.IsInstanceMember + + member x.IsInstanceMemberInCompiledCode = + if isUnresolved () then + false + else + x.IsInstanceMember + && match d with + | E e -> + match e.ArbitraryValRef with + | Some vref -> ValRefIsCompiledAsInstanceMember cenv.g vref + | None -> true + | P p -> + match p.ArbitraryValRef with + | Some vref -> ValRefIsCompiledAsInstanceMember cenv.g vref + | None -> true + | M m + | C m -> + match m.ArbitraryValRef with + | Some vref -> ValRefIsCompiledAsInstanceMember cenv.g vref + | None -> true + | V vref -> ValRefIsCompiledAsInstanceMember cenv.g vref + + member _.IsExtensionMember = + if isUnresolved () then + false + else + match d with + | E e -> e.AddMethod.IsExtensionMember + | P p -> p.IsExtensionMember + | M m -> m.IsExtensionMember + | V v -> v.IsExtensionMember + | C _ -> false member _.IsOverrideOrExplicitInterfaceImplementation = - if isUnresolved() then false else - match d with - | E e -> e.AddMethod.IsDefiniteFSharpOverride - | P p -> p.IsDefiniteFSharpOverride - | M m -> m.IsDefiniteFSharpOverride - | V v -> - v.MemberInfo.IsSome && v.IsDefiniteFSharpOverrideMember - | C _ -> false + if isUnresolved () then + false + else + match d with + | E e -> e.AddMethod.IsDefiniteFSharpOverride + | P p -> p.IsDefiniteFSharpOverride + | M m -> m.IsDefiniteFSharpOverride + | V v -> v.MemberInfo.IsSome && v.IsDefiniteFSharpOverrideMember + | C _ -> false member _.IsExplicitInterfaceImplementation = - if isUnresolved() then false else - match d with - | E e -> e.AddMethod.IsFSharpExplicitInterfaceImplementation - | P p -> p.IsFSharpExplicitInterfaceImplementation - | M m -> m.IsFSharpExplicitInterfaceImplementation - | V v -> v.IsFSharpExplicitInterfaceImplementation cenv.g - | C _ -> false + if isUnresolved () then + false + else + match d with + | E e -> e.AddMethod.IsFSharpExplicitInterfaceImplementation + | P p -> p.IsFSharpExplicitInterfaceImplementation + | M m -> m.IsFSharpExplicitInterfaceImplementation + | V v -> v.IsFSharpExplicitInterfaceImplementation cenv.g + | C _ -> false member _.ImplementedAbstractSignatures = - checkIsResolved() + checkIsResolved () + let sigs = match d with | E e -> e.AddMethod.ImplementedSlotSignatures | P p -> p.ImplementedSlotSignatures - | M m | C m -> m.ImplementedSlotSignatures + | M m + | C m -> m.ImplementedSlotSignatures | V v -> v.ImplementedSlotSignatures - sigs |> List.map (fun s -> FSharpAbstractSignature (cenv, s)) + + sigs + |> List.map (fun s -> FSharpAbstractSignature(cenv, s)) |> makeReadOnlyCollection - member _.IsImplicitConstructor = - if isUnresolved() then false else - match fsharpInfo() with - | None -> false - | Some v -> v.IsIncrClassConstructor - - member _.IsTypeFunction = - if isUnresolved() then false else - match fsharpInfo() with - | None -> false - | Some v -> v.IsTypeFunction + member _.IsImplicitConstructor = + if isUnresolved () then + false + else + match fsharpInfo () with + | None -> false + | Some v -> v.IsIncrClassConstructor - member _.IsActivePattern = - if isUnresolved() then false else - match fsharpInfo() with - | Some v -> ActivePatternInfoOfValName v.DisplayNameCoreMangled v.Range |> Option.isSome - | None -> false + member _.IsTypeFunction = + if isUnresolved () then + false + else + match fsharpInfo () with + | None -> false + | Some v -> v.IsTypeFunction + + member _.IsActivePattern = + if isUnresolved () then + false + else + match fsharpInfo () with + | Some v -> ActivePatternInfoOfValName v.DisplayNameCoreMangled v.Range |> Option.isSome + | None -> false + + member x.CompiledName = + checkIsResolved () - member x.CompiledName = - checkIsResolved() - match fsharpInfo() with + match fsharpInfo () with | Some v -> v.CompiledName cenv.g.CompilerGlobalState | None -> x.LogicalName - member _.LogicalName = - checkIsResolved() - match d with + member _.LogicalName = + checkIsResolved () + + match d with | E e -> e.EventName | P p -> p.PropertyName - | M m | C m -> m.LogicalName + | M m + | C m -> m.LogicalName | V v -> v.LogicalName - member _.DisplayName = - checkIsResolved() - match d with + member _.DisplayName = + checkIsResolved () + + match d with | E e -> e.EventName | P p -> p.PropertyName - | M m | C m -> m.DisplayName + | M m + | C m -> m.DisplayName | V v -> v.DisplayName - member sym.XmlDocSig = - checkIsResolved() - - match d with + member sym.XmlDocSig = + checkIsResolved () + + match d with | E e -> let range = defaultArg sym.DeclarationLocationOpt range0 + match GetXmlDocSigOfEvent cenv.infoReader range e with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" | P p -> let range = defaultArg sym.DeclarationLocationOpt range0 + match GetXmlDocSigOfProp cenv.infoReader range p with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" - | M m | C m -> + | M m + | C m -> let range = defaultArg sym.DeclarationLocationOpt range0 + match GetXmlDocSigOfMethInfo cenv.infoReader range m with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" | V v -> - match v.TryDeclaringEntity with - | Parent entityRef -> + match v.TryDeclaringEntity with + | Parent entityRef -> match GetXmlDocSigOfScopedValRef cenv.g entityRef v with - | Some (_, docsig) -> docsig + | Some(_, docsig) -> docsig | _ -> "" - | ParentNone -> "" - - member _.XmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeXmlDoc else - match d with - | E e -> e.XmlDoc |> makeXmlDoc - | P p -> p.XmlDoc |> makeXmlDoc - | M m | C m -> m.XmlDoc |> makeXmlDoc - | V v -> v.XmlDoc |> makeXmlDoc - - member _.ElaboratedXmlDoc = - if isUnresolved() then XmlDoc.Empty |> makeElaboratedXmlDoc else - match d with - | E e -> e.XmlDoc |> makeElaboratedXmlDoc - | P p -> p.XmlDoc |> makeElaboratedXmlDoc - | M m | C m -> m.XmlDoc |> makeElaboratedXmlDoc - | V v -> v.XmlDoc |> makeElaboratedXmlDoc - - member x.CurriedParameterGroups = - checkIsResolved() - match d with - | P p -> - [ [ for ParamData(isParamArrayArg, isInArg, isOutArg, optArgInfo, _callerInfo, nmOpt, _reflArgInfo, pty) in p.GetParamDatas(cenv.amap, range0) do - // INCOMPLETENESS: Attribs is empty here, so we can't look at attributes for - // either .NET or F# parameters - let argInfo: ArgReprInfo = { Name=nmOpt; Attribs=[]; OtherRange=None } - let m = - match nmOpt with - | Some v -> v.idRange - | None -> - - defaultArg x.DeclarationLocationOpt range0 - - yield FSharpParameter(cenv, pty, argInfo, None, m, isParamArrayArg, isInArg, isOutArg, optArgInfo.IsOptional, false) ] - |> makeReadOnlyCollection ] - |> makeReadOnlyCollection - - | E _ -> [] |> makeReadOnlyCollection - | M m | C m -> - [ for argTys in m.GetParamDatas(cenv.amap, range0, m.FormalMethodInst) do - yield - [ for ParamData(isParamArrayArg, isInArg, isOutArg, optArgInfo, _callerInfo, nmOpt, _reflArgInfo, pty) in argTys do - // INCOMPLETENESS: Attribs is empty here, so we can't look at attributes for - // either .NET or F# parameters - let argInfo: ArgReprInfo = { Name=nmOpt; Attribs=[]; OtherRange=None } + | ParentNone -> "" + + member _.XmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeXmlDoc + else + match d with + | E e -> e.XmlDoc |> makeXmlDoc + | P p -> p.XmlDoc |> makeXmlDoc + | M m + | C m -> m.XmlDoc |> makeXmlDoc + | V v -> v.XmlDoc |> makeXmlDoc + + member _.ElaboratedXmlDoc = + if isUnresolved () then + XmlDoc.Empty |> makeElaboratedXmlDoc + else + match d with + | E e -> e.XmlDoc |> makeElaboratedXmlDoc + | P p -> p.XmlDoc |> makeElaboratedXmlDoc + | M m + | C m -> m.XmlDoc |> makeElaboratedXmlDoc + | V v -> v.XmlDoc |> makeElaboratedXmlDoc + + member x.CurriedParameterGroups = + checkIsResolved () + + match d with + | P p -> + [ + [ + for ParamData(isParamArrayArg, isInArg, isOutArg, optArgInfo, _callerInfo, nmOpt, _reflArgInfo, pty) in + p.GetParamDatas(cenv.amap, range0) do + // INCOMPLETENESS: Attribs is empty here, so we can't look at attributes for + // either .NET or F# parameters + let argInfo: ArgReprInfo = + { + Name = nmOpt + Attribs = [] + OtherRange = None + } + let m = match nmOpt with | Some v -> v.idRange | None -> - defaultArg x.DeclarationLocationOpt range0 - yield FSharpParameter(cenv, pty, argInfo, None, m, isParamArrayArg, isInArg, isOutArg, optArgInfo.IsOptional, false) ] - |> makeReadOnlyCollection ] - |> makeReadOnlyCollection - - | V v -> - match tryGetArityOfValForDisplay v.Deref with - | None -> - let _, tau = v.GeneralizedType - if isFunTy cenv.g tau then - let argTysl, _typ = stripFunTy cenv.g tau - [ for ty in argTysl do - let allArguments = - if isRefTupleTy cenv.g ty - then tryDestRefTupleTy cenv.g ty - else [ty] - let m = defaultArg x.DeclarationLocationOpt range0 + defaultArg x.DeclarationLocationOpt range0 + + yield FSharpParameter(cenv, pty, argInfo, None, m, isParamArrayArg, isInArg, isOutArg, optArgInfo.IsOptional, false) + ] + |> makeReadOnlyCollection + ] + |> makeReadOnlyCollection + + | E _ -> [] |> makeReadOnlyCollection + | M m + | C m -> + [ + for argTys in m.GetParamDatas(cenv.amap, range0, m.FormalMethodInst) do yield - allArguments - |> List.map (fun arg -> FSharpParameter(cenv, arg, ValReprInfo.unnamedTopArg1, m)) - |> makeReadOnlyCollection ] + [ + for ParamData(isParamArrayArg, isInArg, isOutArg, optArgInfo, _callerInfo, nmOpt, _reflArgInfo, pty) in argTys do + // INCOMPLETENESS: Attribs is empty here, so we can't look at attributes for + // either .NET or F# parameters + let argInfo: ArgReprInfo = + { + Name = nmOpt + Attribs = [] + OtherRange = None + } + + let m = + match nmOpt with + | Some v -> v.idRange + | None -> + + defaultArg x.DeclarationLocationOpt range0 + + yield + FSharpParameter( + cenv, + pty, + argInfo, + None, + m, + isParamArrayArg, + isInArg, + isOutArg, + optArgInfo.IsOptional, + false + ) + ] + |> makeReadOnlyCollection + ] + |> makeReadOnlyCollection + + | V v -> + match tryGetArityOfValForDisplay v.Deref with + | None -> + let _, tau = v.GeneralizedType + + if isFunTy cenv.g tau then + let argTysl, _typ = stripFunTy cenv.g tau + + [ + for ty in argTysl do + let allArguments = + if isRefTupleTy cenv.g ty then + tryDestRefTupleTy cenv.g ty + else + [ ty ] + + let m = defaultArg x.DeclarationLocationOpt range0 + + yield + allArguments + |> List.map (fun arg -> FSharpParameter(cenv, arg, ValReprInfo.unnamedTopArg1, m)) + |> makeReadOnlyCollection + ] + |> makeReadOnlyCollection + else + makeReadOnlyCollection [] + | Some(ValReprInfo(_typars, curriedArgInfos, _retInfo)) -> + let tau = v.TauType + let argTysl, _ = GetTopTauTypeInFSharpForm cenv.g curriedArgInfos tau range0 + let argTysl = if v.IsInstanceMember then argTysl.Tail else argTysl + + [ + for argTys in argTysl do + yield + [ + for argTy, argInfo in argTys do + let isParamArrayArg = + HasFSharpAttribute cenv.g cenv.g.attrib_ParamArrayAttribute argInfo.Attribs + + let isInArg = + HasFSharpAttribute cenv.g cenv.g.attrib_InAttribute argInfo.Attribs + && isByrefTy cenv.g argTy + + let isOutArg = + HasFSharpAttribute cenv.g cenv.g.attrib_OutAttribute argInfo.Attribs + && isByrefTy cenv.g argTy + + let isOptionalArg = + HasFSharpAttribute cenv.g cenv.g.attrib_OptionalArgumentAttribute argInfo.Attribs + + let m = + match argInfo.Name with + | Some v -> v.idRange + | None -> defaultArg x.DeclarationLocationOpt range0 + + yield + FSharpParameter( + cenv, + argTy, + argInfo, + None, + m, + isParamArrayArg, + isInArg, + isOutArg, + isOptionalArg, + false + ) + ] + |> makeReadOnlyCollection + ] |> makeReadOnlyCollection - else makeReadOnlyCollection [] - | Some (ValReprInfo(_typars, curriedArgInfos, _retInfo)) -> - let tau = v.TauType - let argTysl, _ = GetTopTauTypeInFSharpForm cenv.g curriedArgInfos tau range0 - let argTysl = if v.IsInstanceMember then argTysl.Tail else argTysl - [ for argTys in argTysl do - yield - [ for argTy, argInfo in argTys do - let isParamArrayArg = HasFSharpAttribute cenv.g cenv.g.attrib_ParamArrayAttribute argInfo.Attribs - let isInArg = HasFSharpAttribute cenv.g cenv.g.attrib_InAttribute argInfo.Attribs && isByrefTy cenv.g argTy - let isOutArg = HasFSharpAttribute cenv.g cenv.g.attrib_OutAttribute argInfo.Attribs && isByrefTy cenv.g argTy - let isOptionalArg = HasFSharpAttribute cenv.g cenv.g.attrib_OptionalArgumentAttribute argInfo.Attribs - let m = - match argInfo.Name with - | Some v -> v.idRange - | None -> defaultArg x.DeclarationLocationOpt range0 - yield FSharpParameter(cenv, argTy, argInfo, None, m, isParamArrayArg, isInArg, isOutArg, isOptionalArg, false) ] - |> makeReadOnlyCollection ] - |> makeReadOnlyCollection - - member x.ReturnParameter = - checkIsResolved() - match d with - | E einfo -> + + member x.ReturnParameter = + checkIsResolved () + + match d with + | E einfo -> // INCOMPLETENESS: Attribs is empty here, so we can't look at return attributes for .NET or F# methods let m = defaultArg x.DeclarationLocationOpt range0 - let retTy = - try PropTypeOfEventInfo cenv.infoReader m AccessibleFromSomewhere einfo - with _ -> + + let retTy = + try + PropTypeOfEventInfo cenv.infoReader m AccessibleFromSomewhere einfo + with _ -> // For non-standard events, just use the delegate type as the ReturnParameter type einfo.GetDelegateType(cenv.amap, m) - FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) - | P pinfo -> + FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) + + | P pinfo -> // INCOMPLETENESS: Attribs is empty here, so we can't look at return attributes for .NET or F# methods let m = defaultArg x.DeclarationLocationOpt range0 let retTy = pinfo.GetPropertyType(cenv.amap, m) - FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) + FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) - | M minfo | C minfo -> + | M minfo + | C minfo -> // INCOMPLETENESS: Attribs is empty here, so we can't look at return attributes for .NET or F# methods let m = defaultArg x.DeclarationLocationOpt range0 let retTy = minfo.GetFSharpReturnType(cenv.amap, m, minfo.FormalMethodInst) - FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) - - | V v -> - match v.ValReprInfo with - | None -> - let _, tau = v.GeneralizedType - let _argTysl, retTy = stripFunTy cenv.g tau - let m = defaultArg x.DeclarationLocationOpt range0 FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) - | Some (ValReprInfo(_typars, argInfos, retInfo)) -> - let tau = v.TauType - let m = defaultArg x.DeclarationLocationOpt range0 - let _c, retTy = GetTopTauTypeInFSharpForm cenv.g argInfos tau m - FSharpParameter(cenv, retTy, retInfo, m) - - - override _.Attributes = - if isUnresolved() then makeReadOnlyCollection [] else - let m = range0 - match d with - | E einfo -> - GetAttribInfosOfEvent cenv.amap m einfo |> List.map (fun a -> FSharpAttribute(cenv, a)) - | P pinfo -> - GetAttribInfosOfProp cenv.amap m pinfo |> List.map (fun a -> FSharpAttribute(cenv, a)) - | M minfo | C minfo -> - GetAttribInfosOfMethod cenv.amap m minfo |> List.map (fun a -> FSharpAttribute(cenv, a)) - | V v -> - v.Attribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) - |> makeReadOnlyCollection - + + | V v -> + match v.ValReprInfo with + | None -> + let _, tau = v.GeneralizedType + let _argTysl, retTy = stripFunTy cenv.g tau + let m = defaultArg x.DeclarationLocationOpt range0 + FSharpParameter(cenv, retTy, ValReprInfo.unnamedRetVal, m) + | Some(ValReprInfo(_typars, argInfos, retInfo)) -> + let tau = v.TauType + let m = defaultArg x.DeclarationLocationOpt range0 + let _c, retTy = GetTopTauTypeInFSharpForm cenv.g argInfos tau m + FSharpParameter(cenv, retTy, retInfo, m) + + override _.Attributes = + if isUnresolved () then + makeReadOnlyCollection [] + else + let m = range0 + + match d with + | E einfo -> + GetAttribInfosOfEvent cenv.amap m einfo + |> List.map (fun a -> FSharpAttribute(cenv, a)) + | P pinfo -> + GetAttribInfosOfProp cenv.amap m pinfo + |> List.map (fun a -> FSharpAttribute(cenv, a)) + | M minfo + | C minfo -> + GetAttribInfosOfMethod cenv.amap m minfo + |> List.map (fun a -> FSharpAttribute(cenv, a)) + | V v -> + v.Attribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + |> makeReadOnlyCollection + /// Is this "base" in "base.M(...)" member _.IsBaseValue = - if isUnresolved() then false else - match d with - | M _ | C _ | P _ | E _ -> false - | V v -> v.IsBaseVal + if isUnresolved () then + false + else + match d with + | M _ + | C _ + | P _ + | E _ -> false + | V v -> v.IsBaseVal /// Is this the "x" in "type C() as x = ..." member _.IsConstructorThisValue = - if isUnresolved() then false else - match d with - | M _ | C _| P _ | E _ -> false - | V v -> v.IsCtorThisVal + if isUnresolved () then + false + else + match d with + | M _ + | C _ + | P _ + | E _ -> false + | V v -> v.IsCtorThisVal /// Is this the "x" in "member x.M = ..." member _.IsMemberThisValue = - if isUnresolved() then false else - match d with - | M _ | C _ | P _ | E _ -> false - | V v -> v.IsMemberThisVal + if isUnresolved () then + false + else + match d with + | M _ + | C _ + | P _ + | E _ -> false + | V v -> v.IsMemberThisVal /// Is this a [] value, and if so what value? (may be null) member _.LiteralValue = - if isUnresolved() then None else - match d with - | M _ | C _ | P _ | E _ -> None - | V v -> getLiteralValue v.LiteralValue - - /// How visible is this? - override this.Accessibility: FSharpAccessibility = - if isUnresolved() then FSharpAccessibility taccessPublic else - match fsharpInfo() with - | Some v -> FSharpAccessibility(v.Accessibility) - | None -> - - // Note, returning "public" is wrong for IL members that are private - match d with - | E e -> - // For IL events, we get an approximate accessibility that at least reports "internal" as "internal" and "private" as "private" - let access = - match e with - | ILEvent ileinfo -> - let ilAccess = GetILAccessOfILEventInfo ileinfo - getApproxFSharpAccessibilityOfMember this.DeclaringEntity.Value.Entity ilAccess - | _ -> taccessPublic - - FSharpAccessibility access - - | P p -> - // For IL properties, we get an approximate accessibility that at least reports "internal" as "internal" and "private" as "private" - let access = - match p with - | ILProp ilpinfo -> - let ilAccess = GetILAccessOfILPropInfo ilpinfo - getApproxFSharpAccessibilityOfMember this.DeclaringEntity.Value.Entity ilAccess - | _ -> taccessPublic - - FSharpAccessibility access - - | M m | C m -> - - // For IL methods, we get an approximate accessibility that at least reports "internal" as "internal" and "private" as "private" - let access = - match m with - | ILMeth (_, x, _) -> getApproxFSharpAccessibilityOfMember x.DeclaringTyconRef x.RawMetadata.Access - | _ -> taccessPublic - - FSharpAccessibility(access, isProtected=m.IsProtectedAccessibility) - - | V v -> FSharpAccessibility(v.Accessibility) + if isUnresolved () then + None + else + match d with + | M _ + | C _ + | P _ + | E _ -> None + | V v -> getLiteralValue v.LiteralValue + + /// How visible is this? + override this.Accessibility: FSharpAccessibility = + if isUnresolved () then + FSharpAccessibility taccessPublic + else + match fsharpInfo () with + | Some v -> FSharpAccessibility(v.Accessibility) + | None -> + + // Note, returning "public" is wrong for IL members that are private + match d with + | E e -> + // For IL events, we get an approximate accessibility that at least reports "internal" as "internal" and "private" as "private" + let access = + match e with + | ILEvent ileinfo -> + let ilAccess = GetILAccessOfILEventInfo ileinfo + getApproxFSharpAccessibilityOfMember this.DeclaringEntity.Value.Entity ilAccess + | _ -> taccessPublic + + FSharpAccessibility access + + | P p -> + // For IL properties, we get an approximate accessibility that at least reports "internal" as "internal" and "private" as "private" + let access = + match p with + | ILProp ilpinfo -> + let ilAccess = GetILAccessOfILPropInfo ilpinfo + getApproxFSharpAccessibilityOfMember this.DeclaringEntity.Value.Entity ilAccess + | _ -> taccessPublic + + FSharpAccessibility access + + | M m + | C m -> + + // For IL methods, we get an approximate accessibility that at least reports "internal" as "internal" and "private" as "private" + let access = + match m with + | ILMeth(_, x, _) -> getApproxFSharpAccessibilityOfMember x.DeclaringTyconRef x.RawMetadata.Access + | _ -> taccessPublic + + FSharpAccessibility(access, isProtected = m.IsProtectedAccessibility) + + | V v -> FSharpAccessibility(v.Accessibility) member _.IsConstructor = match d with @@ -2335,52 +2823,68 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | _ -> false override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpMemberOrFunctionOrValue as other -> - match d, other.Data with - | E evt1, E evt2 -> EventInfo.EventInfosUseIdenticalDefinitions evt1 evt2 - | P p1, P p2 -> PropInfo.PropInfosUseIdenticalDefinitions p1 p2 - | M m1, M m2 - | C m1, C m2 -> MethInfo.MethInfosUseIdenticalDefinitions m1 m2 - | V v1, V v2 -> valRefEq cenv.g v1 v2 - | _ -> false - | _ -> false + box x === other + || match other with + | :? FSharpMemberOrFunctionOrValue as other -> + match d, other.Data with + | E evt1, E evt2 -> EventInfo.EventInfosUseIdenticalDefinitions evt1 evt2 + | P p1, P p2 -> PropInfo.PropInfosUseIdenticalDefinitions p1 p2 + | M m1, M m2 + | C m1, C m2 -> MethInfo.MethInfosUseIdenticalDefinitions m1 m2 + | V v1, V v2 -> valRefEq cenv.g v1 v2 + | _ -> false + | _ -> false override x.GetHashCode() = hash (box x.LogicalName) - override x.ToString() = - try - let prefix = (if x.IsEvent then "event " elif x.IsProperty then "property " elif x.IsMember then "member " else "val ") + + override x.ToString() = + try + let prefix = + (if x.IsEvent then "event " + elif x.IsProperty then "property " + elif x.IsMember then "member " + else "val ") + prefix + x.LogicalName - with _ -> "??" + with _ -> + "??" - member x.FormatLayout (displayContext: FSharpDisplayContext) = + member x.FormatLayout(displayContext: FSharpDisplayContext) = match x.IsMember, d with | true, V v -> - NicePrint.prettyLayoutOfMemberNoInstShort { (displayContext.Contents cenv.g) with showMemberContainers=true } v.Deref + NicePrint.prettyLayoutOfMemberNoInstShort + { (displayContext.Contents cenv.g) with + showMemberContainers = true + } + v.Deref |> LayoutRender.toArray - | _,_ -> - checkIsResolved() - let ty = - match d with + | _, _ -> + checkIsResolved () + + let ty = + match d with | E e -> e.GetDelegateType(cenv.amap, range0) | P p -> p.GetPropertyType(cenv.amap, range0) - | M m | C m -> + | M m + | C m -> let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) - let argTysl = m.GetParamTypes(cenv.amap, range0, m.FormalMethodInst) + let argTysl = m.GetParamTypes(cenv.amap, range0, m.FormalMethodInst) mkIteratedFunTy cenv.g (List.map (mkRefTupledTy cenv.g) argTysl) retTy | V v -> v.TauType + NicePrint.prettyLayoutOfTypeNoCx (displayContext.Contents cenv.g) ty |> LayoutRender.toArray - member x.GetReturnTypeLayout (displayContext: FSharpDisplayContext) = - checkIsResolved() - match d with + member x.GetReturnTypeLayout(displayContext: FSharpDisplayContext) = + checkIsResolved () + + match d with | E _ | P _ | C _ -> None | M m -> let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) + NicePrint.layoutType (displayContext.Contents cenv.g) retTy |> LayoutRender.toArray |> Some @@ -2388,10 +2892,15 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = NicePrint.layoutOfValReturnType (displayContext.Contents cenv.g) v |> LayoutRender.toArray |> Some - - member x.GetValSignatureText (displayContext: FSharpDisplayContext, m: range) = - checkIsResolved() - let displayEnv = { displayContext.Contents cenv.g with includeStaticParametersInTypeNames = true; suppressInlineKeyword = false } + + member x.GetValSignatureText(displayContext: FSharpDisplayContext, m: range) = + checkIsResolved () + + let displayEnv = + { displayContext.Contents cenv.g with + includeStaticParametersInTypeNames = true + suppressInlineKeyword = false + } let stringValOfMethInfo (methInfo: MethInfo) = match methInfo with @@ -2401,6 +2910,7 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = let stringValOfPropInfo (p: PropInfo) = let supportAccessModifiersBeforeGetSet = cenv.g.langVersion.SupportsFeature Features.LanguageFeature.AllowAccessModifiersToAutoPropertiesGettersAndSetters + if not supportAccessModifiersBeforeGetSet then match p with | DifferentGetterAndSetter(getValRef, setValRef) -> @@ -2408,7 +2918,11 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = let s = NicePrint.stringValOrMember displayEnv cenv.infoReader setValRef $"{g}\n{s}" | _ -> - let t = p.GetPropertyType(cenv.amap, m) |> NicePrint.layoutType displayEnv |> LayoutRender.showL + let t = + p.GetPropertyType(cenv.amap, m) + |> NicePrint.layoutType displayEnv + |> LayoutRender.showL + let withGetSet = if p.HasGetter && p.HasSetter then "with get, set" elif p.HasGetter then "with get" @@ -2418,187 +2932,228 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = $"member %s{p.DisplayName}: %s{t} %s{withGetSet}" else let layoutAccessibilityCore (denv: DisplayEnv) accessibility = - let isInternalCompPath x = - match x with - | CompPath(ILScopeRef.Local, _, []) -> true + let isInternalCompPath x = + match x with + | CompPath(ILScopeRef.Local, _, []) -> true | _ -> false - let (|Public|Internal|Private|) (TAccess p) = - match p with - | [] -> Public - | _ when List.forall isInternalCompPath p -> Internal + + let (|Public|Internal|Private|) (TAccess p) = + match p with + | [] -> Public + | _ when List.forall isInternalCompPath p -> Internal | _ -> Private + match denv.contextAccessibility, accessibility with | Public, Internal -> "internal " | Public, Private -> "private " | Internal, Private -> "private " | _ -> String.Empty - let getterAccess, setterAccess = + let getterAccess, setterAccess = layoutAccessibilityCore displayEnv (Option.defaultValue taccessPublic p.GetterAccessibility), layoutAccessibilityCore displayEnv (Option.defaultValue taccessPublic p.SetterAccessibility) - let t = p.GetPropertyType(cenv.amap, m) |> NicePrint.layoutType displayEnv |> LayoutRender.showL + + let t = + p.GetPropertyType(cenv.amap, m) + |> NicePrint.layoutType displayEnv + |> LayoutRender.showL + let withGetSet = match p.HasGetter, p.HasSetter with - | true, false -> - $"with %s{getterAccess}get" - | false, true -> - $"with %s{setterAccess}set" - | true, true -> - $"with %s{getterAccess}get, %s{setterAccess}set" - | false, false -> - String.Empty + | true, false -> $"with %s{getterAccess}get" + | false, true -> $"with %s{setterAccess}set" + | true, true -> $"with %s{getterAccess}get, %s{setterAccess}set" + | false, false -> String.Empty $"member %s{p.DisplayName}: %s{t} %s{withGetSet}" match d with | E _ -> None - | V v -> - NicePrint.stringValOrMember displayEnv cenv.infoReader v - |> Some + | V v -> NicePrint.stringValOrMember displayEnv cenv.infoReader v |> Some | C methInfo | M methInfo -> stringValOfMethInfo methInfo |> Some | P p -> stringValOfPropInfo p |> Some + member x.GetWitnessPassingInfo() = + let witnessInfos = + match d with + | M(FSMeth(_, _, vref, _)) -> + let _tps, witnessInfos, _curriedArgInfos, _retTy, _ = + GetTypeOfMemberInMemberForm cenv.g vref - member x.GetWitnessPassingInfo() = - let witnessInfos = - match d with - | M (FSMeth(_, _, vref, _)) -> - let _tps, witnessInfos, _curriedArgInfos, _retTy, _ = GetTypeOfMemberInMemberForm cenv.g vref witnessInfos - | V vref -> + | V vref -> let arities = arityOfVal vref.Deref let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref - let _tps, witnessInfos, _curriedArgInfos, _retTy, _ = GetValReprTypeInCompiledForm cenv.g arities numEnclosingTypars vref.Type vref.DefinitionRange + + let _tps, witnessInfos, _curriedArgInfos, _retTy, _ = + GetValReprTypeInCompiledForm cenv.g arities numEnclosingTypars vref.Type vref.DefinitionRange + witnessInfos - | E _ | P _ | M _ | C _ -> [] - match witnessInfos with + | E _ + | P _ + | M _ + | C _ -> [] + + match witnessInfos with | [] -> None | _ when not (cenv.g.langVersion.SupportsFeature(Features.LanguageFeature.WitnessPassing)) -> None | _ -> - let witnessParams = - ((Set.empty, 0), witnessInfos) ||> List.mapFold (fun (used,i) witnessInfo -> - let paramTy = GenWitnessTy cenv.g witnessInfo - let nm = String.uncapitalize witnessInfo.MemberName - let nm = if used.Contains nm then nm + string i else nm - let m = x.DeclarationLocation - let argReprInfo : ArgReprInfo = { Attribs=[]; Name=Some (mkSynId m nm); OtherRange=None } - let p = FSharpParameter(cenv, paramTy, argReprInfo, None, m, false, false, false, false, true) - p, (used.Add nm, i + 1)) - |> fst - let witnessMethName = ExtraWitnessMethodName x.CompiledName - Some (witnessMethName, makeReadOnlyCollection witnessParams) - - // FullType may raise exceptions (see https://github.com/fsharp/fsharp/issues/307). + let witnessParams = + ((Set.empty, 0), witnessInfos) + ||> List.mapFold (fun (used, i) witnessInfo -> + let paramTy = GenWitnessTy cenv.g witnessInfo + let nm = String.uncapitalize witnessInfo.MemberName + let nm = if used.Contains nm then nm + string i else nm + let m = x.DeclarationLocation + + let argReprInfo: ArgReprInfo = + { + Attribs = [] + Name = Some(mkSynId m nm) + OtherRange = None + } + + let p = + FSharpParameter(cenv, paramTy, argReprInfo, None, m, false, false, false, false, true) + + p, (used.Add nm, i + 1)) + |> fst + + let witnessMethName = ExtraWitnessMethodName x.CompiledName + Some(witnessMethName, makeReadOnlyCollection witnessParams) + + // FullType may raise exceptions (see https://github.com/fsharp/fsharp/issues/307). member x.FullTypeSafe = Option.attempt (fun _ -> x.FullType) member x.TryGetFullDisplayName() = let fullName = Option.attempt (fun _ -> x.FullName.Split '.') + match fullName with | Some fullName -> match Option.attempt (fun _ -> x.DisplayName) with | Some shortDisplayName when not (shortDisplayName.Contains ".") -> - Some (fullName |> Array.replace (fullName.Length - 1) shortDisplayName) + Some(fullName |> Array.replace (fullName.Length - 1) shortDisplayName) | _ -> Some fullName | None -> None - |> Option.map (fun fullDisplayName -> String.Join (".", fullDisplayName)) + |> Option.map (fun fullDisplayName -> String.Join(".", fullDisplayName)) member x.TryGetFullCompiledOperatorNameIdents() : string[] option = // For operator ++ displayName is ( ++ ) compiledName is op_PlusPlus if IsOperatorDisplayName x.DisplayName && x.DisplayName <> x.CompiledName then x.DeclaringEntity |> Option.bind (fun e -> e.TryGetFullName()) - |> Option.map (fun enclosingEntityFullName -> - Array.append (enclosingEntityFullName.Split '.') [| x.CompiledName |]) - else None - -type FSharpType(cenv, ty:TType) = - - let isUnresolved() = - DiagnosticsLogger.protectAssemblyExploration true <| fun () -> - match stripTyparEqns ty with - | TType_app (tcref, tyargs, _) -> FSharpEntity(cenv, tcref, tyargs).IsUnresolved - | TType_measure (Measure.Const(tyconRef= tcref)) -> FSharpEntity(cenv, tcref).IsUnresolved - | TType_measure (Measure.Prod _) -> FSharpEntity(cenv, cenv.g.measureproduct_tcr).IsUnresolved - | TType_measure (Measure.One _) -> FSharpEntity(cenv, cenv.g.measureone_tcr).IsUnresolved - | TType_measure (Measure.Inv _) -> FSharpEntity(cenv, cenv.g.measureinverse_tcr).IsUnresolved - | _ -> false - - let isResolved() = not (isUnresolved()) + |> Option.map (fun enclosingEntityFullName -> Array.append (enclosingEntityFullName.Split '.') [| x.CompiledName |]) + else + None - new (g, thisCcu, thisCcuTyp, tcImports, ty) = FSharpType(SymbolEnv(g, thisCcu, Some thisCcuTyp, tcImports), ty) +type FSharpType(cenv, ty: TType) = + + let isUnresolved () = + DiagnosticsLogger.protectAssemblyExploration true + <| fun () -> + match stripTyparEqns ty with + | TType_app(tcref, tyargs, _) -> FSharpEntity(cenv, tcref, tyargs).IsUnresolved + | TType_measure(Measure.Const(tyconRef = tcref)) -> FSharpEntity(cenv, tcref).IsUnresolved + | TType_measure(Measure.Prod _) -> FSharpEntity(cenv, cenv.g.measureproduct_tcr).IsUnresolved + | TType_measure(Measure.One _) -> FSharpEntity(cenv, cenv.g.measureone_tcr).IsUnresolved + | TType_measure(Measure.Inv _) -> FSharpEntity(cenv, cenv.g.measureinverse_tcr).IsUnresolved + | _ -> false - member _.IsUnresolved = isUnresolved() + let isResolved () = not (isUnresolved ()) - member _.HasTypeDefinition = - isResolved() && - protect <| fun () -> - match stripTyparEqns ty with - | TType_app _ | TType_measure (Measure.Const _ | Measure.Prod _ | Measure.Inv _ | Measure.One _) -> true - | _ -> false + new(g, thisCcu, thisCcuTyp, tcImports, ty) = FSharpType(SymbolEnv(g, thisCcu, Some thisCcuTyp, tcImports), ty) - member _.IsMeasureType = - isResolved() && - protect <| fun () -> - match stripTyparEqns ty with - | TType_measure _ -> true - | _ -> false + member _.IsUnresolved = isUnresolved () - member _.IsTupleType = - isResolved() && - protect <| fun () -> - match stripTyparEqns ty with - | TType_tuple _ -> true - | _ -> false + member _.HasTypeDefinition = + isResolved () + && protect + <| fun () -> + match stripTyparEqns ty with + | TType_app _ + | TType_measure(Measure.Const _ | Measure.Prod _ | Measure.Inv _ | Measure.One _) -> true + | _ -> false - member _.IsStructTupleType = - isResolved() && - protect <| fun () -> - match stripTyparEqns ty with - | TType_tuple (tupInfo, _) -> evalTupInfoIsStruct tupInfo - | _ -> false + member _.IsMeasureType = + isResolved () + && protect + <| fun () -> + match stripTyparEqns ty with + | TType_measure _ -> true + | _ -> false + + member _.IsTupleType = + isResolved () + && protect + <| fun () -> + match stripTyparEqns ty with + | TType_tuple _ -> true + | _ -> false + + member _.IsStructTupleType = + isResolved () + && protect + <| fun () -> + match stripTyparEqns ty with + | TType_tuple(tupInfo, _) -> evalTupInfoIsStruct tupInfo + | _ -> false + + member _.TypeDefinition = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_app(tcref, tyargs, _) -> FSharpEntity(cenv, tcref, tyargs) + | TType_measure(Measure.Const(tyconRef = tcref)) -> FSharpEntity(cenv, tcref) + | TType_measure(Measure.Prod _) -> FSharpEntity(cenv, cenv.g.measureproduct_tcr) + | TType_measure(Measure.One _) -> FSharpEntity(cenv, cenv.g.measureone_tcr) + | TType_measure(Measure.Inv _) -> FSharpEntity(cenv, cenv.g.measureinverse_tcr) + | _ -> invalidOp "not a named type" + + member _.HasNullAnnotation = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_var(_, nullness) + | TType_app(_, _, nullness) + | TType_fun(_, _, nullness) -> + match nullness.Evaluate() with + | NullnessInfo.WithNull -> true + | _ -> false + | TType_tuple(_, _) -> false + | _ -> false - member _.TypeDefinition = - protect <| fun () -> - match stripTyparEqns ty with - | TType_app (tcref, tyargs, _) -> FSharpEntity(cenv, tcref, tyargs) - | TType_measure (Measure.Const(tyconRef= tcref)) -> FSharpEntity(cenv, tcref) - | TType_measure (Measure.Prod _) -> FSharpEntity(cenv, cenv.g.measureproduct_tcr) - | TType_measure (Measure.One _) -> FSharpEntity(cenv, cenv.g.measureone_tcr) - | TType_measure (Measure.Inv _) -> FSharpEntity(cenv, cenv.g.measureinverse_tcr) - | _ -> invalidOp "not a named type" - - member _.HasNullAnnotation = - protect <| fun () -> - match stripTyparEqns ty with - | TType_var (_, nullness) - | TType_app (_, _, nullness) - | TType_fun(_, _, nullness) -> match nullness.Evaluate() with NullnessInfo.WithNull -> true | _ -> false - | TType_tuple (_, _) -> false - | _ -> false + member _.IsNullAmbivalent = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_app(_, _, nullness) + | TType_fun(_, _, nullness) -> + match nullness.Evaluate() with + | NullnessInfo.AmbivalentToNull -> true + | _ -> false + | TType_tuple(_, _) -> false + | _ -> false - member _.IsNullAmbivalent = - protect <| fun () -> - match stripTyparEqns ty with - | TType_app (_, _, nullness) - | TType_fun(_, _, nullness) -> match nullness.Evaluate() with NullnessInfo.AmbivalentToNull -> true | _ -> false - | TType_tuple (_, _) -> false - | _ -> false + member _.GenericArguments = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_anon(_, tyargs) + | TType_app(_, tyargs, _) + | TType_tuple(_, tyargs) -> (tyargs |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection) + | TType_fun(domainTy, rangeTy, _) -> + [| FSharpType(cenv, domainTy); FSharpType(cenv, rangeTy) |] + |> makeReadOnlyCollection + | TType_measure(Measure.Const _) -> [||] |> makeReadOnlyCollection + | TType_measure(Measure.Prod(measure1 = t1; measure2 = t2)) -> + [| FSharpType(cenv, TType_measure t1); FSharpType(cenv, TType_measure t2) |] + |> makeReadOnlyCollection + | TType_measure(Measure.One _) -> [||] |> makeReadOnlyCollection + | TType_measure(Measure.Inv t1) -> [| FSharpType(cenv, TType_measure t1) |] |> makeReadOnlyCollection + | _ -> invalidOp "not a named type" - member _.GenericArguments = - protect <| fun () -> - match stripTyparEqns ty with - | TType_anon (_, tyargs) - | TType_app (_, tyargs, _) - | TType_tuple (_, tyargs) -> (tyargs |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection) - | TType_fun(domainTy, rangeTy, _) -> [| FSharpType(cenv, domainTy); FSharpType(cenv, rangeTy) |] |> makeReadOnlyCollection - | TType_measure (Measure.Const _) -> [| |] |> makeReadOnlyCollection - | TType_measure (Measure.Prod(measure1= t1; measure2 = t2)) -> [| FSharpType(cenv, TType_measure t1); FSharpType(cenv, TType_measure t2) |] |> makeReadOnlyCollection - | TType_measure (Measure.One _) -> [| |] |> makeReadOnlyCollection - | TType_measure (Measure.Inv t1) -> [| FSharpType(cenv, TType_measure t1) |] |> makeReadOnlyCollection - | _ -> invalidOp "not a named type" - -(* + (* member _.ProvidedArguments = let typeName, argNamesAndValues = try @@ -2607,279 +3162,337 @@ type FSharpType(cenv, ty:TType) = error(Error(FSComp.SR.etProvidedTypeReferenceInvalidText(piece), range0)) *) - member ty.IsAbbreviation = - isResolved() && ty.HasTypeDefinition && ty.TypeDefinition.IsFSharpAbbreviation - - member _.AbbreviatedType = - protect <| fun () -> FSharpType(cenv, stripTyEqns cenv.g ty) - - member _.IsFunctionType = - isResolved() && - protect <| fun () -> - match stripTyparEqns ty with - | TType_fun _ -> true - | _ -> false - - member _.IsAnonRecordType = - isResolved() && - protect <| fun () -> - match stripTyparEqns ty with - | TType_anon _ -> true - | _ -> false - - member _.AnonRecordTypeDetails = - protect <| fun () -> - match stripTyparEqns ty with - | TType_anon (anonInfo, _) -> FSharpAnonRecordTypeDetails(cenv, anonInfo) - | _ -> invalidOp "not an anonymous record type" - - member _.IsGenericParameter = - protect <| fun () -> - match stripTyparEqns ty with - | TType_var _ -> true - | TType_measure (Measure.Var _) -> true - | _ -> false + member ty.IsAbbreviation = + isResolved () && ty.HasTypeDefinition && ty.TypeDefinition.IsFSharpAbbreviation + + member _.AbbreviatedType = protect <| fun () -> FSharpType(cenv, stripTyEqns cenv.g ty) + + member _.IsFunctionType = + isResolved () + && protect + <| fun () -> + match stripTyparEqns ty with + | TType_fun _ -> true + | _ -> false + + member _.IsAnonRecordType = + isResolved () + && protect + <| fun () -> + match stripTyparEqns ty with + | TType_anon _ -> true + | _ -> false + + member _.AnonRecordTypeDetails = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_anon(anonInfo, _) -> FSharpAnonRecordTypeDetails(cenv, anonInfo) + | _ -> invalidOp "not an anonymous record type" + + member _.IsGenericParameter = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_var _ -> true + | TType_measure(Measure.Var _) -> true + | _ -> false - member _.GenericParameter = - protect <| fun () -> - match stripTyparEqns ty with - | TType_var (tp, _) - | TType_measure (Measure.Var tp) -> - FSharpGenericParameter (cenv, tp) - | _ -> invalidOp "not a generic parameter type" - - member _.AllInterfaces = - if isUnresolved() then makeReadOnlyCollection [] else - [ for ty in AllInterfacesOfType cenv.g cenv.amap range0 AllowMultiIntfInstantiations.Yes ty do - yield FSharpType(cenv, ty) ] - |> makeReadOnlyCollection + member _.GenericParameter = + protect + <| fun () -> + match stripTyparEqns ty with + | TType_var(tp, _) + | TType_measure(Measure.Var tp) -> FSharpGenericParameter(cenv, tp) + | _ -> invalidOp "not a generic parameter type" + + member _.AllInterfaces = + if isUnresolved () then + makeReadOnlyCollection [] + else + [ + for ty in AllInterfacesOfType cenv.g cenv.amap range0 AllowMultiIntfInstantiations.Yes ty do + yield FSharpType(cenv, ty) + ] + |> makeReadOnlyCollection - member _.BaseType = + member _.BaseType = GetSuperTypeOfType cenv.g cenv.amap range0 ty - |> Option.map (fun ty -> FSharpType(cenv, ty)) + |> Option.map (fun ty -> FSharpType(cenv, ty)) - member x.ErasedType= - FSharpType(cenv, stripTyEqnsWrtErasure EraseAll cenv.g ty) + member x.ErasedType = FSharpType(cenv, stripTyEqnsWrtErasure EraseAll cenv.g ty) member x.BasicQualifiedName = let fail () = invalidOp $"the type '{x}' does not have a qualified name" - protect <| fun () -> - match stripTyparEqns ty with + protect + <| fun () -> + match stripTyparEqns ty with | TType_app(tcref, _, _) -> - match tcref.CompiledRepresentation with + match tcref.CompiledRepresentation with | CompiledTypeRepr.ILAsmNamed(tref, _, _) -> tref.BasicQualifiedName - | CompiledTypeRepr.ILAsmOpen _ -> fail () + | CompiledTypeRepr.ILAsmOpen _ -> fail () | _ -> fail () - member _.Instantiate(instantiation:(FSharpGenericParameter * FSharpType) list) = - let resTy = instType (instantiation |> List.map (fun (tyv, ty) -> tyv.TypeParameter, ty.Type)) ty + member _.Instantiate(instantiation: (FSharpGenericParameter * FSharpType) list) = + let resTy = + instType (instantiation |> List.map (fun (tyv, ty) -> tyv.TypeParameter, ty.Type)) ty + FSharpType(cenv, resTy) member _.Type = ty member private x.cenv = cenv - member private ty.AdjustType t = - FSharpType(ty.cenv, t) + member private ty.AdjustType t = FSharpType(ty.cenv, t) // Note: This equivalence relation is modulo type abbreviations override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpType as t -> typeEquiv cenv.g ty t.Type - | _ -> false + box x === other + || match other with + | :? FSharpType as t -> typeEquiv cenv.g ty t.Type + | _ -> false // Note: This equivalence relation is modulo type abbreviations. The hash is less than perfect. - override _.GetHashCode() = - let rec hashType ty = + override _.GetHashCode() = + let rec hashType ty = let ty = stripTyEqnsWrtErasure EraseNone cenv.g ty + match ty with - | TType_forall _ -> 10000 - | TType_var (tp, _) -> 10100 + int32 tp.Stamp - | TType_app (tc1, b1, _) -> 10200 + int32 tc1.Stamp + List.sumBy hashType b1 - | TType_ucase _ -> 10300 // shouldn't occur in symbols - | TType_tuple (_, l1) -> 10400 + List.sumBy hashType l1 - | TType_fun (domainTy, rangeTy, _) -> 10500 + hashType domainTy + hashType rangeTy - | TType_measure _ -> 10600 - | TType_anon (_,l1) -> 10800 + List.sumBy hashType l1 + | TType_forall _ -> 10000 + | TType_var(tp, _) -> 10100 + int32 tp.Stamp + | TType_app(tc1, b1, _) -> 10200 + int32 tc1.Stamp + List.sumBy hashType b1 + | TType_ucase _ -> 10300 // shouldn't occur in symbols + | TType_tuple(_, l1) -> 10400 + List.sumBy hashType l1 + | TType_fun(domainTy, rangeTy, _) -> 10500 + hashType domainTy + hashType rangeTy + | TType_measure _ -> 10600 + | TType_anon(_, l1) -> 10800 + List.sumBy hashType l1 + hashType ty - member _.Format(context: FSharpDisplayContext) = - protect <| fun () -> - NicePrint.prettyStringOfTyNoCx (context.Contents cenv.g) ty + member _.Format(context: FSharpDisplayContext) = + protect <| fun () -> NicePrint.prettyStringOfTyNoCx (context.Contents cenv.g) ty - member _.FormatWithConstraints(context: FSharpDisplayContext) = - protect <| fun () -> - NicePrint.prettyStringOfTy (context.Contents cenv.g) ty + member _.FormatWithConstraints(context: FSharpDisplayContext) = + protect <| fun () -> NicePrint.prettyStringOfTy (context.Contents cenv.g) ty member _.FormatLayout(context: FSharpDisplayContext) = - protect <| fun () -> + protect + <| fun () -> NicePrint.prettyLayoutOfTypeNoCx (context.Contents cenv.g) ty |> LayoutRender.toArray member _.FormatLayoutWithConstraints(context: FSharpDisplayContext) = - protect <| fun () -> + protect + <| fun () -> NicePrint.prettyLayoutOfType (context.Contents cenv.g) ty |> LayoutRender.toArray - override _.ToString() = - protect <| fun () -> - "type " + NicePrint.prettyStringOfTyNoCx (DisplayEnv.Empty(cenv.g)) ty + override _.ToString() = + protect + <| fun () -> "type " + NicePrint.prettyStringOfTyNoCx (DisplayEnv.Empty(cenv.g)) ty - static member Prettify(ty: FSharpType) = - let prettyTy = PrettyTypes.PrettifyType ty.cenv.g ty.Type |> fst + static member Prettify(ty: FSharpType) = + let prettyTy = PrettyTypes.PrettifyType ty.cenv.g ty.Type |> fst ty.AdjustType prettyTy - static member Prettify(types: IList) = + static member Prettify(types: IList) = let xs = types |> List.ofSeq - match xs with + + match xs with | [] -> [] - | h :: _ -> + | h :: _ -> let cenv = h.cenv let prettyTys = PrettyTypes.PrettifyTypes cenv.g [ for t in xs -> t.Type ] |> fst (xs, prettyTys) ||> List.map2 (fun p pty -> p.AdjustType pty) |> makeReadOnlyCollection - static member Prettify(parameter: FSharpParameter) = + static member Prettify(parameter: FSharpParameter) = let prettyTy = parameter.V |> PrettyTypes.PrettifyType parameter.cenv.g |> fst parameter.AdjustType prettyTy - static member Prettify(parameters: IList) = + static member Prettify(parameters: IList) = let parameters = parameters |> List.ofSeq - match parameters with + + match parameters with | [] -> [] - | h :: _ -> + | h :: _ -> let cenv = h.cenv - let prettyTys = parameters |> List.map (fun p -> p.V) |> PrettyTypes.PrettifyTypes cenv.g |> fst + + let prettyTys = + parameters |> List.map (fun p -> p.V) |> PrettyTypes.PrettifyTypes cenv.g |> fst + (parameters, prettyTys) ||> List.map2 (fun p pty -> p.AdjustType pty) |> makeReadOnlyCollection - static member Prettify(parameters: IList>) = + static member Prettify(parameters: IList>) = let xs = parameters |> List.ofSeq |> List.map List.ofSeq - let hOpt = xs |> List.tryPick (function h :: _ -> Some h | _ -> None) - match hOpt with + + let hOpt = + xs + |> List.tryPick (function + | h :: _ -> Some h + | _ -> None) + + match hOpt with | None -> xs - | Some h -> + | Some h -> let cenv = h.cenv - let prettyTys = xs |> List.mapSquared (fun p -> p.V) |> PrettyTypes.PrettifyCurriedTypes cenv.g |> fst + + let prettyTys = + xs + |> List.mapSquared (fun p -> p.V) + |> PrettyTypes.PrettifyCurriedTypes cenv.g + |> fst + (xs, prettyTys) ||> List.map2 (List.map2 (fun p pty -> p.AdjustType pty)) - |> List.map makeReadOnlyCollection |> makeReadOnlyCollection + |> List.map makeReadOnlyCollection + |> makeReadOnlyCollection - static member Prettify(parameters: IList>, returnParameter: FSharpParameter) = + static member Prettify(parameters: IList>, returnParameter: FSharpParameter) = let xs = parameters |> List.ofSeq |> List.map List.ofSeq let cenv = returnParameter.cenv - let prettyTys, prettyRetTy = xs |> List.mapSquared (fun p -> p.V) |> (fun tys -> PrettyTypes.PrettifyCurriedSigTypes cenv.g (tys, returnParameter.V) )|> fst - let ps = (xs, prettyTys) ||> List.map2 (List.map2 (fun p pty -> p.AdjustType pty)) |> List.map makeReadOnlyCollection |> makeReadOnlyCollection + + let prettyTys, prettyRetTy = + xs + |> List.mapSquared (fun p -> p.V) + |> (fun tys -> PrettyTypes.PrettifyCurriedSigTypes cenv.g (tys, returnParameter.V)) + |> fst + + let ps = + (xs, prettyTys) + ||> List.map2 (List.map2 (fun p pty -> p.AdjustType pty)) + |> List.map makeReadOnlyCollection + |> makeReadOnlyCollection + ps, returnParameter.AdjustType prettyRetTy member x.StripAbbreviations() = if x.IsAbbreviation then x.AbbreviatedType.StripAbbreviations() - else x + else + x -type FSharpAttribute(cenv: SymbolEnv, attrib: AttribInfo) = +type FSharpAttribute(cenv: SymbolEnv, attrib: AttribInfo) = let rec resolveArgObj (arg: objnull) = match arg with - | :? TType as t -> box (FSharpType(cenv, t)) + | :? TType as t -> box (FSharpType(cenv, t)) | :? (obj[]) as a -> a |> Array.map resolveArgObj |> box | _ -> arg - member _.AttributeType = - FSharpEntity(cenv, attrib.TyconRef) + member _.AttributeType = FSharpEntity(cenv, attrib.TyconRef) - member _.IsUnresolved = entityIsUnresolved(attrib.TyconRef) + member _.IsUnresolved = entityIsUnresolved (attrib.TyconRef) - member _.ConstructorArguments = - attrib.ConstructorArguments + member _.ConstructorArguments = + attrib.ConstructorArguments |> List.map (fun (ty, obj) -> FSharpType(cenv, ty), resolveArgObj obj) |> makeReadOnlyCollection - member _.NamedArguments = - attrib.NamedArguments + member _.NamedArguments = + attrib.NamedArguments |> List.map (fun (ty, nm, isField, obj) -> FSharpType(cenv, ty), nm, isField, resolveArgObj obj) |> makeReadOnlyCollection - member _.Format(context: FSharpDisplayContext) = - protect <| fun () -> + member _.Format(context: FSharpDisplayContext) = + protect + <| fun () -> match attrib with - | AttribInfo.FSAttribInfo(g, attrib) -> - NicePrint.stringOfFSAttrib (context.Contents g) attrib - | AttribInfo.ILAttribInfo (g, _, _scoref, cattr, _) -> - let params_, _args = decodeILAttribData cattr + | AttribInfo.FSAttribInfo(g, attrib) -> NicePrint.stringOfFSAttrib (context.Contents g) attrib + | AttribInfo.ILAttribInfo(g, _, _scoref, cattr, _) -> + let params_, _args = decodeILAttribData cattr NicePrint.stringOfILAttrib (context.Contents g) (cattr.Method.DeclaringType, params_) member _.Range = attrib.Range - override _.ToString() = - if entityIsUnresolved attrib.TyconRef then "attribute ???" else "attribute " + attrib.TyconRef.CompiledName + "(...)" + override _.ToString() = + if entityIsUnresolved attrib.TyconRef then + "attribute ???" + else + "attribute " + attrib.TyconRef.CompiledName + "(...)" - member attr.IsAttribute<'T> () = + member attr.IsAttribute<'T>() = // CompiledName throws exception on DataContractAttribute generated by SQLProvider - try attr.AttributeType.CompiledName = typeof<'T>.Name with _ -> false - -#if !NO_TYPEPROVIDERS -type FSharpStaticParameter(cenv, sp: Tainted< TypeProviders.ProvidedParameterInfo >, m) = - inherit FSharpSymbol(cenv, - (fun () -> - protect <| fun () -> - let paramTy = Import.ImportProvidedType cenv.amap m (sp.PApply((fun x -> x.ParameterType), m)) - let nm = sp.PUntaint((fun p -> p.Name), m) - let id = mkSynId m nm - Item.OtherName(Some id, paramTy, None, None, m)), - (fun _ _ _ -> true)) - - member _.Name = - protect <| fun () -> - sp.PUntaint((fun p -> p.Name), m) + try + attr.AttributeType.CompiledName = typeof<'T>.Name + with _ -> + false + +#if !NO_TYPEPROVIDERS +type FSharpStaticParameter(cenv, sp: Tainted, m) = + inherit + FSharpSymbol( + cenv, + (fun () -> + protect + <| fun () -> + let paramTy = + Import.ImportProvidedType cenv.amap m (sp.PApply((fun x -> x.ParameterType), m)) + + let nm = sp.PUntaint((fun p -> p.Name), m) + let id = mkSynId m nm + Item.OtherName(Some id, paramTy, None, None, m)), + (fun _ _ _ -> true) + ) + + member _.Name = protect <| fun () -> sp.PUntaint((fun p -> p.Name), m) member _.DeclarationLocation = m - member _.Kind = - protect <| fun () -> - let ty = Import.ImportProvidedType cenv.amap m (sp.PApply((fun x -> x.ParameterType), m)) + member _.Kind = + protect + <| fun () -> + let ty = + Import.ImportProvidedType cenv.amap m (sp.PApply((fun x -> x.ParameterType), m)) + FSharpType(cenv, ty) - member _.IsOptional = - protect <| fun () -> sp.PUntaint((fun x -> x.IsOptional), m) + member _.IsOptional = protect <| fun () -> sp.PUntaint((fun x -> x.IsOptional), m) - member _.HasDefaultValue = + member _.HasDefaultValue = protect <| fun () -> sp.PUntaint((fun x -> x.HasDefaultValue), m) - member _.DefaultValue = + member _.DefaultValue = protect <| fun () -> sp.PUntaint((fun x -> x.RawDefaultValue), m) member _.Range = m override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpStaticParameter as p -> x.Name = p.Name && equals x.DeclarationLocation p.DeclarationLocation - | _ -> false + box x === other + || match other with + | :? FSharpStaticParameter as p -> x.Name = p.Name && equals x.DeclarationLocation p.DeclarationLocation + | _ -> false override x.GetHashCode() = hash x.Name - override x.ToString() = - "static parameter " + x.Name + override x.ToString() = "static parameter " + x.Name #endif -type FSharpParameter(cenv, paramTy: TType, topArgInfo: ArgReprInfo, ownerOpt, m: range, isParamArrayArg, isInArg, isOutArg, isOptionalArg, isWitnessArg) = - inherit FSharpSymbol(cenv, - (fun () -> Item.OtherName(topArgInfo.Name, paramTy, Some topArgInfo, ownerOpt, m)), - (fun _ _ _ -> true)) +type FSharpParameter + (cenv, paramTy: TType, topArgInfo: ArgReprInfo, ownerOpt, m: range, isParamArrayArg, isInArg, isOutArg, isOptionalArg, isWitnessArg) = + inherit FSharpSymbol(cenv, (fun () -> Item.OtherName(topArgInfo.Name, paramTy, Some topArgInfo, ownerOpt, m)), (fun _ _ _ -> true)) + + new(cenv, idOpt, ty, ownerOpt, m) = + let argInfo: ArgReprInfo = + { + Name = idOpt + Attribs = [] + OtherRange = None + } - new (cenv, idOpt, ty, ownerOpt, m) = - let argInfo: ArgReprInfo = { Name = idOpt; Attribs = []; OtherRange = None } FSharpParameter(cenv, ty, argInfo, ownerOpt, m, false, false, false, false, false) - new (cenv, ty, argInfo: ArgReprInfo, m: range) = - FSharpParameter(cenv, ty, argInfo, None, m, false, false, false, false, false) + new(cenv, ty, argInfo: ArgReprInfo, m: range) = FSharpParameter(cenv, ty, argInfo, None, m, false, false, false, false, false) - member _.Name = match topArgInfo.Name with None -> None | Some v -> Some v.idText + member _.Name = + match topArgInfo.Name with + | None -> None + | Some v -> Some v.idText member _.cenv: SymbolEnv = cenv - member _.AdjustType ty = FSharpParameter(cenv, ty, topArgInfo, ownerOpt, m, isParamArrayArg, isInArg, isOutArg, isOptionalArg, isWitnessArg) + member _.AdjustType ty = + FSharpParameter(cenv, ty, topArgInfo, ownerOpt, m, isParamArrayArg, isInArg, isOutArg, isOptionalArg, isWitnessArg) member _.Type: FSharpType = FSharpType(cenv, paramTy) @@ -2889,11 +3502,13 @@ type FSharpParameter(cenv, paramTy: TType, topArgInfo: ArgReprInfo, ownerOpt, m: member _.Owner = match ownerOpt with - | Some (ArgumentContainer.Method minfo) -> Some (FSharpMemberOrFunctionOrValue (cenv, minfo) :> FSharpSymbol) + | Some(ArgumentContainer.Method minfo) -> Some(FSharpMemberOrFunctionOrValue(cenv, minfo) :> FSharpSymbol) | _ -> None - override _.Attributes = - topArgInfo.Attribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) |> makeReadOnlyCollection + override _.Attributes = + topArgInfo.Attribs + |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) + |> makeReadOnlyCollection member _.IsParamArrayArg = isParamArrayArg @@ -2902,95 +3517,115 @@ type FSharpParameter(cenv, paramTy: TType, topArgInfo: ArgReprInfo, ownerOpt, m: member _.IsOutArg = isOutArg member _.IsOptionalArg = isOptionalArg - + member _.IsWitnessArg = isWitnessArg - + member private x.ValReprInfo = topArgInfo override x.Equals(other: obj) = - box x === other || - match other with - | :? FSharpParameter as p -> x.Name = p.Name && equals x.DeclarationLocation p.DeclarationLocation - | _ -> false + box x === other + || match other with + | :? FSharpParameter as p -> x.Name = p.Name && equals x.DeclarationLocation p.DeclarationLocation + | _ -> false override x.GetHashCode() = hash (box topArgInfo) - override x.ToString() = - "parameter " + (match x.Name with None -> " s) + override x.ToString() = + "parameter " + + (match x.Name with + | None -> " s) -type FSharpAssemblySignature (cenv, topAttribs: TopAttribs option, optViewedCcu: CcuThunk option, mtyp: ModuleOrNamespaceType) = +type FSharpAssemblySignature(cenv, topAttribs: TopAttribs option, optViewedCcu: CcuThunk option, mtyp: ModuleOrNamespaceType) = // Assembly signature for a referenced/linked assembly - new (cenv: SymbolEnv, ccu: CcuThunk) = - let cenv = if ccu.IsUnresolvedReference then cenv else SymbolEnv(cenv.g, ccu, None, cenv.tcImports) + new(cenv: SymbolEnv, ccu: CcuThunk) = + let cenv = + if ccu.IsUnresolvedReference then + cenv + else + SymbolEnv(cenv.g, ccu, None, cenv.tcImports) + FSharpAssemblySignature(cenv, None, Some ccu, ccu.Contents.ModuleOrNamespaceType) - + // Assembly signature for an assembly produced via type-checking. - new (tcGlobals, thisCcu, thisCcuTyp, tcImports, topAttribs, contents) = + new(tcGlobals, thisCcu, thisCcuTyp, tcImports, topAttribs, contents) = FSharpAssemblySignature(SymbolEnv(tcGlobals, thisCcu, Some thisCcuTyp, tcImports), topAttribs, None, contents) - member _.Entities = + member _.Entities = + + let rec loop (rmtyp: ModuleOrNamespaceType) = + [| + for entity in rmtyp.AllEntities do + if entity.IsNamespace then + yield! loop entity.ModuleOrNamespaceType + else + let entityRef = rescopeEntity optViewedCcu entity + yield FSharpEntity(cenv, entityRef) + |] - let rec loop (rmtyp: ModuleOrNamespaceType) = - [| for entity in rmtyp.AllEntities do - if entity.IsNamespace then - yield! loop entity.ModuleOrNamespaceType - else - let entityRef = rescopeEntity optViewedCcu entity - yield FSharpEntity(cenv, entityRef) |] - loop mtyp |> makeReadOnlyCollection member _.Attributes = - [ match optViewedCcu with - | Some ccu -> - match ccu.TryGetILModuleDef() with - | Some ilModule -> - match ilModule.Manifest with + [ + match optViewedCcu with + | Some ccu -> + match ccu.TryGetILModuleDef() with + | Some ilModule -> + match ilModule.Manifest with | None -> () - | Some manifest -> + | Some manifest -> for a in AttribInfosOfIL cenv.g cenv.amap cenv.thisCcu.ILScopeRef range0 manifest.CustomAttrs do yield FSharpAttribute(cenv, a) - | None -> - // If no module is available, then look in the CCU contents. + | None -> + // If no module is available, then look in the CCU contents. if ccu.IsFSharp then - for a in ccu.Contents.Attribs do - yield FSharpAttribute(cenv, FSAttribInfo (cenv.g, a)) - | None -> - match topAttribs with - | None -> () - | Some tA -> for a in tA.assemblyAttrs do yield FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a)) ] + for a in ccu.Contents.Attribs do + yield FSharpAttribute(cenv, FSAttribInfo(cenv.g, a)) + | None -> + match topAttribs with + | None -> () + | Some tA -> + for a in tA.assemblyAttrs do + yield FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a)) + ] |> makeReadOnlyCollection member _.FindEntityByPath path = - let findNested name entity = + let findNested name entity = match entity with - | Some (e: Entity) ->e.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind name + | Some(e: Entity) -> e.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind name | _ -> None match path with | hd :: tl -> - (mtyp.AllEntitiesByCompiledAndLogicalMangledNames.TryFind hd, tl) - ||> List.fold (fun a x -> findNested x a) - |> Option.map (fun e -> FSharpEntity(cenv, rescopeEntity optViewedCcu e)) + (mtyp.AllEntitiesByCompiledAndLogicalMangledNames.TryFind hd, tl) + ||> List.fold (fun a x -> findNested x a) + |> Option.map (fun e -> FSharpEntity(cenv, rescopeEntity optViewedCcu e)) | _ -> None - member x.TryGetEntities() = try x.Entities :> _ seq with _ -> Seq.empty + member x.TryGetEntities() = + try + x.Entities :> _ seq + with _ -> + Seq.empty override x.ToString() = "" -type FSharpAssembly internal (cenv, ccu: CcuThunk) = +type FSharpAssembly internal (cenv, ccu: CcuThunk) = - new (tcGlobals, tcImports, ccu: CcuThunk) = - FSharpAssembly(SymbolEnv(tcGlobals, ccu, None, tcImports), ccu) + new(tcGlobals, tcImports, ccu: CcuThunk) = FSharpAssembly(SymbolEnv(tcGlobals, ccu, None, tcImports), ccu) member _.RawCcuThunk = ccu - member _.QualifiedName = match ccu.QualifiedName with None -> "" | Some s -> s + member _.QualifiedName = + match ccu.QualifiedName with + | None -> "" + | Some s -> s member _.FileName = ccu.FileName - member _.SimpleName = ccu.AssemblyName + member _.SimpleName = ccu.AssemblyName member _.IsFSharp = ccu.IsFSharp @@ -2998,32 +3633,39 @@ type FSharpAssembly internal (cenv, ccu: CcuThunk) = member _.IsProviderGenerated = ccu.IsProviderGenerated #endif - member _.Contents : FSharpAssemblySignature = FSharpAssemblySignature(cenv, ccu) - - override x.ToString() = + member _.Contents: FSharpAssemblySignature = FSharpAssemblySignature(cenv, ccu) + + override x.ToString() = match ccu.ILScopeRef with - | ILScopeRef.PrimaryAssembly -> - cenv.g.ilg.primaryAssemblyRef.QualifiedName - | scoref -> - scoref.QualifiedName + | ILScopeRef.PrimaryAssembly -> cenv.g.ilg.primaryAssemblyRef.QualifiedName + | scoref -> scoref.QualifiedName /// Represents open declaration in F# code. [] -type FSharpOpenDeclaration(target: SynOpenDeclTarget, range: range option, modules: FSharpEntity list, types: FSharpType list, appliedScope: range, isOwnNamespace: bool) = +type FSharpOpenDeclaration + ( + target: SynOpenDeclTarget, + range: range option, + modules: FSharpEntity list, + types: FSharpType list, + appliedScope: range, + isOwnNamespace: bool + ) = member _.Target = target - member _.LongId = - match target with + member _.LongId = + match target with | SynOpenDeclTarget.ModuleOrNamespace(longId, _) -> longId.LongIdent | SynOpenDeclTarget.Type(synType, _) -> - let rec get ty = - match ty with - | SynType.LongIdent (SynLongIdent(lid, _, _)) -> lid - | SynType.App (ty2, _, _, _, _, _, _) -> get ty2 - | SynType.LongIdentApp (ty2, _, _, _, _, _, _) -> get ty2 - | SynType.Paren (ty2, _) -> get ty2 + let rec get ty = + match ty with + | SynType.LongIdent(SynLongIdent(lid, _, _)) -> lid + | SynType.App(ty2, _, _, _, _, _, _) -> get ty2 + | SynType.LongIdentApp(ty2, _, _, _, _, _, _) -> get ty2 + | SynType.Paren(ty2, _) -> get ty2 | _ -> [] + get synType member _.Range = range diff --git a/src/Compiler/TypedTree/CompilerGlobalState.fs b/src/Compiler/TypedTree/CompilerGlobalState.fs index 12dda2b08d8..5deb901840c 100644 --- a/src/Compiler/TypedTree/CompilerGlobalState.fs +++ b/src/Compiler/TypedTree/CompilerGlobalState.fs @@ -17,19 +17,25 @@ open FSharp.Compiler.Text /// It is made concurrency-safe since a global instance of the type is allocated in tast.fs, and it is good /// policy to make all globally-allocated objects concurrency safe in case future versions of the compiler /// are used to host multiple concurrent instances of compilation. -type NiceNameGenerator() = - let basicNameCounts = ConcurrentDictionary(max Environment.ProcessorCount 1, 127) +type NiceNameGenerator() = + let basicNameCounts = + ConcurrentDictionary(max Environment.ProcessorCount 1, 127) // Cache this as a delegate. let basicNameCountsAddDelegate = Func(fun _ -> ref 0) - - member _.FreshCompilerGeneratedNameOfBasicName (basicName, m: range) = + + member _.FreshCompilerGeneratedNameOfBasicName(basicName, m: range) = let countCell = basicNameCounts.GetOrAdd(basicName, basicNameCountsAddDelegate) let count = Interlocked.Increment(countCell) - CompilerGeneratedNameSuffix basicName (string m.StartLine + (match (count-1) with 0 -> "" | n -> "-" + string n)) + CompilerGeneratedNameSuffix + basicName + (string m.StartLine + + (match (count - 1) with + | 0 -> "" + | n -> "-" + string n)) - member this.FreshCompilerGeneratedName (name, m: range) = - this.FreshCompilerGeneratedNameOfBasicName (GetBasicNameOfPossibleCompilerGeneratedName name, m) + member this.FreshCompilerGeneratedName(name, m: range) = + this.FreshCompilerGeneratedNameOfBasicName(GetBasicNameOfPossibleCompilerGeneratedName name, m) /// Generates compiler-generated names marked up with a source code location, but if given the same unique value then /// return precisely the same name. Each name generated also includes the StartLine number of the range passed in @@ -37,25 +43,27 @@ type NiceNameGenerator() = /// /// This type may be accessed concurrently, though in practice it is only used from the compilation thread. /// It is made concurrency-safe since a global instance of the type is allocated in tast.fs. -type StableNiceNameGenerator() = +type StableNiceNameGenerator() = + + let niceNames = + ConcurrentDictionary(max Environment.ProcessorCount 1, 127) - let niceNames = ConcurrentDictionary(max Environment.ProcessorCount 1, 127) let innerGenerator = new NiceNameGenerator() - member x.GetUniqueCompilerGeneratedName (name, m: range, uniq) = + member x.GetUniqueCompilerGeneratedName(name, m: range, uniq) = let basicName = GetBasicNameOfPossibleCompilerGeneratedName name let key = basicName, uniq niceNames.GetOrAdd(key, fun (basicName, _) -> innerGenerator.FreshCompilerGeneratedNameOfBasicName(basicName, m)) -type internal CompilerGlobalState () = +type internal CompilerGlobalState() = /// A global generator of compiler generated names let globalNng = NiceNameGenerator() /// A global generator of stable compiler generated names - let globalStableNameGenerator = StableNiceNameGenerator () + let globalStableNameGenerator = StableNiceNameGenerator() /// A name generator used by IlxGen for static fields, some generated arguments and other things. - let ilxgenGlobalNng = NiceNameGenerator () + let ilxgenGlobalNng = NiceNameGenerator() member _.NiceNameGenerator = globalNng @@ -68,11 +76,14 @@ type Unique = int64 //++GLOBAL MUTABLE STATE (concurrency-safe) let mutable private uniqueCount = 0L -let newUnique() = System.Threading.Interlocked.Increment &uniqueCount + +let newUnique () = + System.Threading.Interlocked.Increment &uniqueCount /// Unique name generator for stamps attached to to val_specs, tycon_specs etc. //++GLOBAL MUTABLE STATE (concurrency-safe) let mutable private stampCount = 0L -let newStamp() = + +let newStamp () = let stamp = System.Threading.Interlocked.Increment &stampCount - stamp \ No newline at end of file + stamp diff --git a/src/Compiler/TypedTree/QuotationPickler.fs b/src/Compiler/TypedTree/QuotationPickler.fs index de18b73e5c0..9d78e4b78b1 100644 --- a/src/Compiler/TypedTree/QuotationPickler.fs +++ b/src/Compiler/TypedTree/QuotationPickler.fs @@ -8,7 +8,8 @@ open FSharp.Compiler.IO open Internal.Utilities.Collections open Internal.Utilities.Library.Extras -let mkRLinear mk (vs, body) = List.foldBack (fun v acc -> mk (v, acc)) vs body +let mkRLinear mk (vs, body) = + List.foldBack (fun v acc -> mk (v, acc)) vs body type TypeVarData = { tvName: string } @@ -27,27 +28,33 @@ type TypeData = let mkVarTy v = VarType v -let mkFunTy (x1, x2) = AppType(FunTyOp, [x1; x2]) +let mkFunTy (x1, x2) = AppType(FunTyOp, [ x1; x2 ]) -let mkArrayTy (n, x) = AppType(ArrayTyOp n, [x]) +let mkArrayTy (n, x) = AppType(ArrayTyOp n, [ x ]) let mkILNamedTy (r, l) = AppType(NamedTyOp r, l) type CtorData = - { Parent: NamedTypeData - ArgTypes: TypeData list } + { + Parent: NamedTypeData + ArgTypes: TypeData list + } type MethodData = - { Parent: NamedTypeData - Name: string - ArgTypes: TypeData list - RetType: TypeData - NumGenericArgs: int } + { + Parent: NamedTypeData + Name: string + ArgTypes: TypeData list + RetType: TypeData + NumGenericArgs: int + } type ValData = - { Name: string - Type: TypeData - IsMutable: bool } + { + Name: string + Type: TypeData + IsMutable: bool + } type PropInfoData = NamedTypeData * string * TypeData * TypeData list @@ -116,17 +123,17 @@ type ExprData = let mkVar v = VarExpr v -let mkHole (v, idx) = HoleExpr (v, idx) +let mkHole (v, idx) = HoleExpr(v, idx) -let mkApp (a, b) = CombExpr(AppOp, [], [a; b]) +let mkApp (a, b) = CombExpr(AppOp, [], [ a; b ]) -let mkLambda (a, b) = LambdaExpr (a, b) +let mkLambda (a, b) = LambdaExpr(a, b) let mkQuote a = QuoteExpr a let mkQuoteRaw40 a = QuoteRawExpr a -let mkCond (x1, x2, x3) = CombExpr(CondOp, [], [x1;x2;x3]) +let mkCond (x1, x2, x3) = CombExpr(CondOp, [], [ x1; x2; x3 ]) let mkModuleValueApp (tcref, nm, isProp, tyargs, args: ExprData list) = CombExpr(ModuleValueOp(tcref, nm, isProp), tyargs, args) @@ -134,107 +141,120 @@ let mkModuleValueApp (tcref, nm, isProp, tyargs, args: ExprData list) = let mkModuleValueWApp (tcref, nm, isProp, nmW, nWitnesses, tyargs, args: ExprData list) = CombExpr(ModuleValueWOp(tcref, nm, isProp, nmW, nWitnesses), tyargs, args) -let mkTuple (ty, x) = CombExpr(TupleMkOp, [ty], x) +let mkTuple (ty, x) = CombExpr(TupleMkOp, [ ty ], x) -let mkLet ((v, e), b) = CombExpr(LetOp, [], [e;mkLambda (v, b)]) (* nb. order preserves source order *) +let mkLet ((v, e), b) = + CombExpr(LetOp, [], [ e; mkLambda (v, b) ]) (* nb. order preserves source order *) let mkUnit () = CombExpr(UnitOp, [], []) -let mkNull ty = CombExpr(NullOp, [ty], []) +let mkNull ty = CombExpr(NullOp, [ ty ], []) -let mkLetRecRaw e1 = CombExpr(LetRecOp, [], [e1]) +let mkLetRecRaw e1 = CombExpr(LetRecOp, [], [ e1 ]) let mkLetRecCombRaw args = CombExpr(LetRecCombOp, [], args) let mkLetRec (ves, body) = - let vs, es = List.unzip ves - mkLetRecRaw(mkRLinear mkLambda (vs, mkLetRecCombRaw (body :: es))) + let vs, es = List.unzip ves + mkLetRecRaw (mkRLinear mkLambda (vs, mkLetRecCombRaw (body :: es))) let mkRecdMk (n, tys, args) = CombExpr(RecdMkOp n, tys, args) -let mkRecdGet (d1, d2, tyargs, args) = CombExpr(RecdGetOp(d1, d2), tyargs, args) +let mkRecdGet (d1, d2, tyargs, args) = + CombExpr(RecdGetOp(d1, d2), tyargs, args) -let mkRecdSet (d1, d2, tyargs, args) = CombExpr(RecdSetOp(d1, d2), tyargs, args) +let mkRecdSet (d1, d2, tyargs, args) = + CombExpr(RecdSetOp(d1, d2), tyargs, args) let mkUnion (d1, d2, tyargs, args) = CombExpr(SumMkOp(d1, d2), tyargs, args) -let mkUnionFieldGet (d1, d2, d3, tyargs, arg) = CombExpr(SumFieldGetOp(d1, d2, d3), tyargs, [arg]) +let mkUnionFieldGet (d1, d2, d3, tyargs, arg) = + CombExpr(SumFieldGetOp(d1, d2, d3), tyargs, [ arg ]) -let mkUnionCaseTagTest (d1, d2, tyargs, arg) = CombExpr(SumTagTestOp(d1, d2), tyargs, [arg]) +let mkUnionCaseTagTest (d1, d2, tyargs, arg) = + CombExpr(SumTagTestOp(d1, d2), tyargs, [ arg ]) -let mkTupleGet (ty, n, e) = CombExpr(TupleGetOp n, [ty], [e]) +let mkTupleGet (ty, n, e) = CombExpr(TupleGetOp n, [ ty ], [ e ]) -let mkCoerce (ty, arg) = CombExpr(CoerceOp, [ty], [arg]) +let mkCoerce (ty, arg) = CombExpr(CoerceOp, [ ty ], [ arg ]) -let mkTypeTest (ty, arg) = CombExpr(TypeTestOp, [ty], [arg]) +let mkTypeTest (ty, arg) = CombExpr(TypeTestOp, [ ty ], [ arg ]) -let mkAddressOf arg = CombExpr(AddressOfOp, [], [arg]) +let mkAddressOf arg = CombExpr(AddressOfOp, [], [ arg ]) -let mkAddressSet (arg1, arg2) = CombExpr(AddressSetOp, [], [arg1;arg2]) +let mkAddressSet (arg1, arg2) = + CombExpr(AddressSetOp, [], [ arg1; arg2 ]) -let mkVarSet (arg1, arg2) = CombExpr(ExprSetOp, [], [arg1;arg2]) +let mkVarSet (arg1, arg2) = CombExpr(ExprSetOp, [], [ arg1; arg2 ]) -let mkDefaultValue ty = CombExpr(DefaultValueOp, [ty], []) +let mkDefaultValue ty = CombExpr(DefaultValueOp, [ ty ], []) let mkThisVar ty = ThisVarExpr(ty) -let mkNewArray (ty, args) = CombExpr(NewArrayOp, [ty], args) +let mkNewArray (ty, args) = CombExpr(NewArrayOp, [ ty ], args) -let mkBool (v, ty) = CombExpr(BoolOp v, [ty], []) +let mkBool (v, ty) = CombExpr(BoolOp v, [ ty ], []) -let mkString (v, ty) = CombExpr(StringOp v, [ty], []) +let mkString (v, ty) = CombExpr(StringOp v, [ ty ], []) -let mkSingle (v, ty) = CombExpr(SingleOp v, [ty], []) +let mkSingle (v, ty) = CombExpr(SingleOp v, [ ty ], []) -let mkDouble (v, ty) = CombExpr(DoubleOp v, [ty], []) +let mkDouble (v, ty) = CombExpr(DoubleOp v, [ ty ], []) -let mkChar (v, ty) = CombExpr(CharOp v, [ty], []) +let mkChar (v, ty) = CombExpr(CharOp v, [ ty ], []) -let mkSByte (v, ty) = CombExpr(SByteOp v, [ty], []) +let mkSByte (v, ty) = CombExpr(SByteOp v, [ ty ], []) -let mkByte (v, ty) = CombExpr(ByteOp v, [ty], []) +let mkByte (v, ty) = CombExpr(ByteOp v, [ ty ], []) -let mkInt16 (v, ty) = CombExpr(Int16Op v, [ty], []) +let mkInt16 (v, ty) = CombExpr(Int16Op v, [ ty ], []) -let mkUInt16 (v, ty) = CombExpr(UInt16Op v, [ty], []) +let mkUInt16 (v, ty) = CombExpr(UInt16Op v, [ ty ], []) -let mkInt32 (v, ty) = CombExpr(Int32Op v, [ty], []) +let mkInt32 (v, ty) = CombExpr(Int32Op v, [ ty ], []) -let mkUInt32 (v, ty) = CombExpr(UInt32Op v, [ty], []) +let mkUInt32 (v, ty) = CombExpr(UInt32Op v, [ ty ], []) -let mkInt64 (v, ty) = CombExpr(Int64Op v, [ty], []) +let mkInt64 (v, ty) = CombExpr(Int64Op v, [ ty ], []) -let mkUInt64 (v, ty) = CombExpr(UInt64Op v, [ty], []) +let mkUInt64 (v, ty) = CombExpr(UInt64Op v, [ ty ], []) -let mkSequential (e1, e2) = CombExpr(SeqOp, [], [e1;e2]) +let mkSequential (e1, e2) = CombExpr(SeqOp, [], [ e1; e2 ]) -let mkIntegerForLoop (x1, x2, x3) = CombExpr(ForLoopOp, [], [x1;x2;x3]) +let mkIntegerForLoop (x1, x2, x3) = CombExpr(ForLoopOp, [], [ x1; x2; x3 ]) -let mkWhileLoop (e1, e2) = CombExpr(WhileLoopOp, [], [e1;e2]) +let mkWhileLoop (e1, e2) = CombExpr(WhileLoopOp, [], [ e1; e2 ]) -let mkTryFinally(e1, e2) = CombExpr(TryFinallyOp, [], [e1;e2]) +let mkTryFinally (e1, e2) = CombExpr(TryFinallyOp, [], [ e1; e2 ]) -let mkTryWith(e1, vf, ef, vh, eh) = CombExpr(TryWithOp, [], [e1;mkLambda(vf, ef);mkLambda(vh, eh)]) +let mkTryWith (e1, vf, ef, vh, eh) = + CombExpr(TryWithOp, [], [ e1; mkLambda (vf, ef); mkLambda (vh, eh) ]) -let mkDelegate (ty, e) = CombExpr(DelegateOp, [ty], [e]) +let mkDelegate (ty, e) = CombExpr(DelegateOp, [ ty ], [ e ]) let mkPropGet (d, tyargs, args) = CombExpr(PropGetOp(d), tyargs, args) let mkPropSet (d, tyargs, args) = CombExpr(PropSetOp(d), tyargs, args) -let mkFieldGet (d1, d2, tyargs, args) = CombExpr(FieldGetOp(d1, d2), tyargs, args) +let mkFieldGet (d1, d2, tyargs, args) = + CombExpr(FieldGetOp(d1, d2), tyargs, args) -let mkFieldSet (d1, d2, tyargs, args) = CombExpr(FieldSetOp(d1, d2), tyargs, args) +let mkFieldSet (d1, d2, tyargs, args) = + CombExpr(FieldSetOp(d1, d2), tyargs, args) -let mkCtorCall (d, tyargs, args) = CombExpr(CtorCallOp(d), tyargs, args) +let mkCtorCall (d, tyargs, args) = CombExpr(CtorCallOp(d), tyargs, args) let mkMethodCall (d, tyargs, args) = CombExpr(MethodCallOp(d), tyargs, args) -let mkMethodCallW (d1, d2, d3, tyargs, args) = CombExpr(MethodCallWOp(d1, d2, d3), tyargs, args) +let mkMethodCallW (d1, d2, d3, tyargs, args) = + CombExpr(MethodCallWOp(d1, d2, d3), tyargs, args) -let mkAttributedExpression(e, attr) = AttrExpr(e, [attr]) +let mkAttributedExpression (e, attr) = AttrExpr(e, [ attr ]) -let isAttributedExpression e = match e with AttrExpr _ -> true | _ -> false +let isAttributedExpression e = + match e with + | AttrExpr _ -> true + | _ -> false //--------------------------------------------------------------------------- // Pickle/unpickle expression and type specifications in a stable format @@ -249,15 +269,19 @@ let PickleBufferCapacity = 100000 module SimplePickle = - type Table<'T when 'T:not null> = - { tbl: HashMultiMap<'T, int> // This should be "Dictionary" - mutable rows: 'T list - mutable count: int } + type Table<'T when 'T: not null> = + { + tbl: HashMultiMap<'T, int> // This should be "Dictionary" + mutable rows: 'T list + mutable count: int + } - static member Create () = - { tbl = HashMultiMap(20, HashIdentity.Structural) - rows=[] - count=0; } + static member Create() = + { + tbl = HashMultiMap(20, HashIdentity.Structural) + rows = [] + count = 0 + } member tbl.AsList = List.rev tbl.rows @@ -271,16 +295,17 @@ module SimplePickle = n member tbl.FindOrAdd x = - if tbl.tbl.ContainsKey x then tbl.tbl[x] - else tbl.Add x + if tbl.tbl.ContainsKey x then tbl.tbl[x] else tbl.Add x member tbl.Find x = tbl.tbl[x] member tbl.ContainsKey x = tbl.tbl.ContainsKey x type QuotationPickleOutState = - { os: ByteBuffer - ostrings: Table } + { + os: ByteBuffer + ostrings: Table + } let p_byte b st = st.os.EmitIntAsByte b @@ -299,50 +324,52 @@ module SimplePickle = // compress integers according to the same scheme used by CLR metadata // This halves the size of pickled data let p_int32 n st = - if n >= 0 && n <= 0x7F then + if n >= 0 && n <= 0x7F then p_byte (Bits.b0 n) st else if n >= 0x80 && n <= 0x3FFF then - p_byte (0x80 ||| (n >>> 8)) st + p_byte (0x80 ||| (n >>> 8)) st p_byte (n &&& 0xFF) st else p_byte 0xFF st prim_pint32 n st - let p_bytes (s:byte[]) st = + let p_bytes (s: byte[]) st = let len = s.Length p_int32 len st st.os.EmitBytes s - let p_memory (s:ReadOnlyMemory) st = + let p_memory (s: ReadOnlyMemory) st = let len = s.Length p_int32 len st st.os.EmitMemory s - let prim_pstring (s:string) st = + let prim_pstring (s: string) st = let bytes = Encoding.UTF8.GetBytes s let len = bytes.Length p_int32 len st st.os.EmitBytes bytes - let p_int (c:int) st = p_int32 c st + let p_int (c: int) st = p_int32 c st - let p_int8 (i:int8) st = p_int32 (int32 i) st + let p_int8 (i: int8) st = p_int32 (int32 i) st - let p_uint8 (i:uint8) st = p_byte (int i) st + let p_uint8 (i: uint8) st = p_byte (int i) st - let p_int16 (i:int16) st = p_int32 (int32 i) st + let p_int16 (i: int16) st = p_int32 (int32 i) st - let p_uint16 (x:uint16) st = p_int32 (int32 x) st + let p_uint16 (x: uint16) st = p_int32 (int32 x) st - let puint32 (x:uint32) st = p_int32 (int32 x) st + let puint32 (x: uint32) st = p_int32 (int32 x) st let p_int64 i st = p_int32 (int32 (i &&& 0xFFFFFFFFL)) st p_int32 (int32 (i >>> 32)) st - let bits_of_float32 (x:float32) = BitConverter.ToInt32(BitConverter.GetBytes(x), 0) + let bits_of_float32 (x: float32) = + BitConverter.ToInt32(BitConverter.GetBytes(x), 0) - let bits_of_float (x:float) = BitConverter.ToInt64(BitConverter.GetBytes(x), 0) + let bits_of_float (x: float) = + BitConverter.ToInt64(BitConverter.GetBytes(x), 0) let p_uint64 x st = p_int64 (int64 x) st @@ -352,13 +379,27 @@ module SimplePickle = let p_char i st = p_uint16 (uint16 (int32 i)) st - let inline p_tup2 p1 p2 (a, b) (st:QuotationPickleOutState) = (p1 a st : unit); (p2 b st : unit) + let inline p_tup2 p1 p2 (a, b) (st: QuotationPickleOutState) = + (p1 a st: unit) + (p2 b st: unit) - let inline p_tup3 p1 p2 p3 (a, b, c) st = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit) + let inline p_tup3 p1 p2 p3 (a, b, c) st = + (p1 a st: unit) + (p2 b st: unit) + (p3 c st: unit) - let inline p_tup4 p1 p2 p3 p4 (a, b, c, d) st = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit); (p4 d st : unit) + let inline p_tup4 p1 p2 p3 p4 (a, b, c, d) st = + (p1 a st: unit) + (p2 b st: unit) + (p3 c st: unit) + (p4 d st: unit) - let inline p_tup5 p1 p2 p3 p4 p5 (a, b, c, d, e) st = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit); (p4 d st : unit); (p5 e st : unit) + let inline p_tup5 p1 p2 p3 p4 p5 (a, b, c, d, e) st = + (p1 a st: unit) + (p2 b st: unit) + (p3 c st: unit) + (p4 d st: unit) + (p5 e st: unit) let puniq (tbl: Table<_>) key st = p_int (tbl.FindOrAdd key) st @@ -367,12 +408,18 @@ module SimplePickle = let rec p_list f x st = match x with | [] -> p_byte 0 st - | h :: t -> p_byte 1 st; f h st; p_list f t st + | h :: t -> + p_byte 1 st + f h st + p_list f t st let pickle_obj p x = let st1 = - { os = ByteBuffer.Create(PickleBufferCapacity, useArrayPool = true) - ostrings=Table<_>.Create() } + { + os = ByteBuffer.Create(PickleBufferCapacity, useArrayPool = true) + ostrings = Table<_>.Create() + } + let stringTab, phase1bytes = p x st1 st1.ostrings.AsList, st1.os.AsMemory() @@ -380,8 +427,11 @@ module SimplePickle = let phase2data = (stringTab, phase1bytes) let st2 = - { os = ByteBuffer.Create(PickleBufferCapacity, useArrayPool = true) - ostrings=Table<_>.Create() } + { + os = ByteBuffer.Create(PickleBufferCapacity, useArrayPool = true) + ostrings = Table<_>.Create() + } + let phase2bytes = p_tup2 (p_list prim_pstring) p_memory phase2data st2 st2.os.AsMemory() @@ -398,22 +448,31 @@ let p_assemblyref x st = p_string x st let p_NamedType x st = match x with | Idx n -> p_tup2 p_string p_assemblyref (string n, "") st - | Named (nm, a) -> p_tup2 p_string p_assemblyref (nm, a) st + | Named(nm, a) -> p_tup2 p_string p_assemblyref (nm, a) st let p_tycon x st = match x with | FunTyOp -> p_byte 1 st - | NamedTyOp a -> p_byte 2 st; p_NamedType a st - | ArrayTyOp a -> p_byte 3 st; p_int a st + | NamedTyOp a -> + p_byte 2 st + p_NamedType a st + | ArrayTyOp a -> + p_byte 3 st + p_int a st let rec p_type x st = match x with - | VarType v -> p_byte 0 st; p_int v st - | AppType(c, ts) -> p_byte 1 st; p_tup2 p_tycon p_types (c, ts) st + | VarType v -> + p_byte 0 st + p_int v st + | AppType(c, ts) -> + p_byte 1 st + p_tup2 p_tycon p_types (c, ts) st and p_types x st = p_list p_type x st -let p_varDecl (v: ValData) st = p_tup3 p_string p_type p_bool (v.Name, v.Type, v.IsMutable) st +let p_varDecl (v: ValData) st = + p_tup3 p_string p_type p_bool (v.Name, v.Type, v.IsMutable) st let p_recdFieldSpec v st = p_tup2 p_NamedType p_string v st @@ -431,63 +490,115 @@ let p_PropInfoData a st = let p_CombOp x st = match x with | CondOp -> p_byte 0 st - | ModuleValueOp (x, y, z) -> + | ModuleValueOp(x, y, z) -> p_byte 1 st p_NamedType x st p_string y st p_bool z st | LetRecOp -> p_byte 2 st - | RecdMkOp a -> p_byte 3 st; p_NamedType a st - | RecdGetOp (x, y) -> p_byte 4 st; p_recdFieldSpec (x, y) st - | SumMkOp (x, y) -> p_byte 5 st; p_ucaseSpec (x, y) st - | SumFieldGetOp (a, b, c) -> p_byte 6 st; p_tup2 p_ucaseSpec p_int ((a, b), c) st - | SumTagTestOp (x, y) -> p_byte 7 st; p_ucaseSpec (x, y) st + | RecdMkOp a -> + p_byte 3 st + p_NamedType a st + | RecdGetOp(x, y) -> + p_byte 4 st + p_recdFieldSpec (x, y) st + | SumMkOp(x, y) -> + p_byte 5 st + p_ucaseSpec (x, y) st + | SumFieldGetOp(a, b, c) -> + p_byte 6 st + p_tup2 p_ucaseSpec p_int ((a, b), c) st + | SumTagTestOp(x, y) -> + p_byte 7 st + p_ucaseSpec (x, y) st | TupleMkOp -> p_byte 8 st - | TupleGetOp a -> p_byte 9 st; p_int a st - | BoolOp a -> p_byte 11 st; p_bool a st - | StringOp a -> p_byte 12 st; p_string a st - | SingleOp a -> p_byte 13 st; p_single a st - | DoubleOp a -> p_byte 14 st; p_double a st - | CharOp a -> p_byte 15 st; p_char a st - | SByteOp a -> p_byte 16 st; p_int8 a st - | ByteOp a -> p_byte 17 st; p_uint8 a st - | Int16Op a -> p_byte 18 st; p_int16 a st - | UInt16Op a -> p_byte 19 st; p_uint16 a st - | Int32Op a -> p_byte 20 st; p_int32 a st - | UInt32Op a -> p_byte 21 st; puint32 a st - | Int64Op a -> p_byte 22 st; p_int64 a st - | UInt64Op a -> p_byte 23 st; p_uint64 a st + | TupleGetOp a -> + p_byte 9 st + p_int a st + | BoolOp a -> + p_byte 11 st + p_bool a st + | StringOp a -> + p_byte 12 st + p_string a st + | SingleOp a -> + p_byte 13 st + p_single a st + | DoubleOp a -> + p_byte 14 st + p_double a st + | CharOp a -> + p_byte 15 st + p_char a st + | SByteOp a -> + p_byte 16 st + p_int8 a st + | ByteOp a -> + p_byte 17 st + p_uint8 a st + | Int16Op a -> + p_byte 18 st + p_int16 a st + | UInt16Op a -> + p_byte 19 st + p_uint16 a st + | Int32Op a -> + p_byte 20 st + p_int32 a st + | UInt32Op a -> + p_byte 21 st + puint32 a st + | Int64Op a -> + p_byte 22 st + p_int64 a st + | UInt64Op a -> + p_byte 23 st + p_uint64 a st | UnitOp -> p_byte 24 st - | PropGetOp d -> p_byte 25 st; p_PropInfoData d st - | CtorCallOp a -> p_byte 26 st; p_CtorData a st + | PropGetOp d -> + p_byte 25 st + p_PropInfoData d st + | CtorCallOp a -> + p_byte 26 st + p_CtorData a st | CoerceOp -> p_byte 28 st | SeqOp -> p_byte 29 st | ForLoopOp -> p_byte 30 st - | MethodCallOp a -> p_byte 31 st; p_MethodData a st + | MethodCallOp a -> + p_byte 31 st + p_MethodData a st | NewArrayOp -> p_byte 32 st | DelegateOp -> p_byte 33 st | WhileLoopOp -> p_byte 34 st | LetOp -> p_byte 35 st - | RecdSetOp (x, y) -> p_byte 36 st; p_recdFieldSpec (x, y) st - | FieldGetOp (a, b) -> p_byte 37 st; p_tup2 p_NamedType p_string (a, b) st + | RecdSetOp(x, y) -> + p_byte 36 st + p_recdFieldSpec (x, y) st + | FieldGetOp(a, b) -> + p_byte 37 st + p_tup2 p_NamedType p_string (a, b) st | LetRecCombOp -> p_byte 38 st | AppOp -> p_byte 39 st | NullOp -> p_byte 40 st | DefaultValueOp -> p_byte 41 st - | PropSetOp d -> p_byte 42 st; p_PropInfoData d st - | FieldSetOp (a, b) -> p_byte 43 st; p_tup2 p_NamedType p_string (a, b) st + | PropSetOp d -> + p_byte 42 st + p_PropInfoData d st + | FieldSetOp(a, b) -> + p_byte 43 st + p_tup2 p_NamedType p_string (a, b) st | AddressOfOp -> p_byte 44 st | AddressSetOp -> p_byte 45 st | TypeTestOp -> p_byte 46 st | TryFinallyOp -> p_byte 47 st | TryWithOp -> p_byte 48 st | ExprSetOp -> p_byte 49 st - | MethodCallWOp (a, b, c) -> + | MethodCallWOp(a, b, c) -> p_byte 50 st p_MethodData a st p_MethodData b st p_int c st - | ModuleValueWOp (x, y, z, nmW, nWitnesses) -> + | ModuleValueWOp(x, y, z, nmW, nWitnesses) -> p_byte 51 st p_string nmW st p_int nWitnesses st @@ -497,19 +608,38 @@ let p_CombOp x st = let rec p_expr x st = match x with - | CombExpr(c, ts, args) -> p_byte 0 st; p_tup3 p_CombOp p_types (p_list p_expr) (c, ts, args) st - | VarExpr v -> p_byte 1 st; p_int v st - | LambdaExpr(v, e) -> p_byte 2 st; p_tup2 p_varDecl p_expr (v, e) st - | HoleExpr(ty, idx) -> p_byte 3 st; p_type ty st; p_int idx st - | QuoteExpr(tm) -> p_byte 4 st; p_expr tm st - | AttrExpr(e, attrs) -> p_byte 5 st; p_tup2 p_expr (p_list p_expr) (e, attrs) st - | ThisVarExpr(ty) -> p_byte 6 st; p_type ty st - | QuoteRawExpr(tm) -> p_byte 7 st; p_expr tm st + | CombExpr(c, ts, args) -> + p_byte 0 st + p_tup3 p_CombOp p_types (p_list p_expr) (c, ts, args) st + | VarExpr v -> + p_byte 1 st + p_int v st + | LambdaExpr(v, e) -> + p_byte 2 st + p_tup2 p_varDecl p_expr (v, e) st + | HoleExpr(ty, idx) -> + p_byte 3 st + p_type ty st + p_int idx st + | QuoteExpr(tm) -> + p_byte 4 st + p_expr tm st + | AttrExpr(e, attrs) -> + p_byte 5 st + p_tup2 p_expr (p_list p_expr) (e, attrs) st + | ThisVarExpr(ty) -> + p_byte 6 st + p_type ty st + | QuoteRawExpr(tm) -> + p_byte 7 st + p_expr tm st type ModuleDefnData = - { Module: NamedTypeData - Name: string - IsProperty: bool } + { + Module: NamedTypeData + Name: string + IsProperty: bool + } type MethodBaseData = | ModuleDefn of ModuleDefnData * (string * int) option @@ -520,12 +650,12 @@ let pickle = pickle_obj p_expr let p_MethodBase x st = match x with - | ModuleDefn (md, None) -> + | ModuleDefn(md, None) -> p_byte 0 st p_NamedType md.Module st p_string md.Name st p_bool md.IsProperty st - | ModuleDefn (md, Some (nmW, nWitnesses)) -> + | ModuleDefn(md, Some(nmW, nWitnesses)) -> p_byte 3 st p_string nmW st p_int nWitnesses st diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 8f82eebc078..ee945dee609 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -33,7 +33,7 @@ let private envRange = rangeN DummyFileNameForRangesWithoutASpecificLocation 0 type IntrinsicValRef = | IntrinsicValRef of NonLocalEntityRef * string * bool * TType * ValLinkageFullKey - member x.Name = (let (IntrinsicValRef(_, nm, _, _, _)) = x in nm) + member x.Name = (let (IntrinsicValRef(_, nm, _, _, _)) = x in nm) /// For debugging [] @@ -42,7 +42,7 @@ type IntrinsicValRef = /// For debugging override x.ToString() = x.Name -let ValRefForIntrinsic (IntrinsicValRef(mvr, _, _, _, key)) = mkNonLocalValRef mvr key +let ValRefForIntrinsic (IntrinsicValRef(mvr, _, _, _, key)) = mkNonLocalValRef mvr key //------------------------------------------------------------------------- // Access the initial environment: names @@ -51,48 +51,47 @@ let ValRefForIntrinsic (IntrinsicValRef(mvr, _, _, _, key)) = mkNonLocalValRef [] module FSharpLib = - let Root = "Microsoft.FSharp" - let RootPath = splitNamespace Root - let Core = Root + ".Core" - let CorePath = splitNamespace Core - let CoreOperatorsCheckedName = Root + ".Core.Operators.Checked" - let ControlName = Root + ".Control" - let LinqName = Root + ".Linq" - let CollectionsName = Root + ".Collections" - let LanguagePrimitivesName = Root + ".Core.LanguagePrimitives" - let CompilerServicesName = Root + ".Core.CompilerServices" - let LinqRuntimeHelpersName = Root + ".Linq.RuntimeHelpers" + let Root = "Microsoft.FSharp" + let RootPath = splitNamespace Root + let Core = Root + ".Core" + let CorePath = splitNamespace Core + let CoreOperatorsCheckedName = Root + ".Core.Operators.Checked" + let ControlName = Root + ".Control" + let LinqName = Root + ".Linq" + let CollectionsName = Root + ".Collections" + let LanguagePrimitivesName = Root + ".Core.LanguagePrimitives" + let CompilerServicesName = Root + ".Core.CompilerServices" + let LinqRuntimeHelpersName = Root + ".Linq.RuntimeHelpers" let ExtraTopLevelOperatorsName = Root + ".Core.ExtraTopLevelOperators" - let NativeInteropName = Root + ".NativeInterop" + let NativeInteropName = Root + ".NativeInterop" - let QuotationsName = Root + ".Quotations" + let QuotationsName = Root + ".Quotations" - let ControlPath = splitNamespace ControlName - let LinqPath = splitNamespace LinqName - let CollectionsPath = splitNamespace CollectionsName - let NativeInteropPath = splitNamespace NativeInteropName |> Array.ofList - let CompilerServicesPath = splitNamespace CompilerServicesName |> Array.ofList - let LinqRuntimeHelpersPath = splitNamespace LinqRuntimeHelpersName |> Array.ofList - let QuotationsPath = splitNamespace QuotationsName |> Array.ofList + let ControlPath = splitNamespace ControlName + let LinqPath = splitNamespace LinqName + let CollectionsPath = splitNamespace CollectionsName + let NativeInteropPath = splitNamespace NativeInteropName |> Array.ofList + let CompilerServicesPath = splitNamespace CompilerServicesName |> Array.ofList + let LinqRuntimeHelpersPath = splitNamespace LinqRuntimeHelpersName |> Array.ofList + let QuotationsPath = splitNamespace QuotationsName |> Array.ofList - let RootPathArray = RootPath |> Array.ofList - let CorePathArray = CorePath |> Array.ofList - let LinqPathArray = LinqPath |> Array.ofList - let ControlPathArray = ControlPath |> Array.ofList - let CollectionsPathArray = CollectionsPath |> Array.ofList + let RootPathArray = RootPath |> Array.ofList + let CorePathArray = CorePath |> Array.ofList + let LinqPathArray = LinqPath |> Array.ofList + let ControlPathArray = ControlPath |> Array.ofList + let CollectionsPathArray = CollectionsPath |> Array.ofList //------------------------------------------------------------------------- // Access the initial environment: helpers to build references //------------------------------------------------------------------------- -type - [] - BuiltinAttribInfo = +[] +type BuiltinAttribInfo = | AttribInfo of ILTypeRef * TyconRef member this.TyconRef = let (AttribInfo(_, tcref)) = this in tcref - member this.TypeRef = let (AttribInfo(tref, _)) = this in tref + member this.TypeRef = let (AttribInfo(tref, _)) = this in tref /// For debugging [] @@ -101,75 +100,113 @@ type /// For debugging override x.ToString() = x.TyconRef.ToString() - [] -let tname_InternalsVisibleToAttribute = "System.Runtime.CompilerServices.InternalsVisibleToAttribute" +let tname_InternalsVisibleToAttribute = + "System.Runtime.CompilerServices.InternalsVisibleToAttribute" + [] -let tname_DebuggerNonUserCodeAttribute = "System.Diagnostics.DebuggerNonUserCodeAttribute" +let tname_DebuggerNonUserCodeAttribute = + "System.Diagnostics.DebuggerNonUserCodeAttribute" + [] let tname_DebuggableAttribute_DebuggingModes = "DebuggingModes" + [] let tname_DebuggerHiddenAttribute = "System.Diagnostics.DebuggerHiddenAttribute" + [] let tname_DebuggerDisplayAttribute = "System.Diagnostics.DebuggerDisplayAttribute" + [] -let tname_DebuggerTypeProxyAttribute = "System.Diagnostics.DebuggerTypeProxyAttribute" +let tname_DebuggerTypeProxyAttribute = + "System.Diagnostics.DebuggerTypeProxyAttribute" + [] -let tname_DebuggerStepThroughAttribute = "System.Diagnostics.DebuggerStepThroughAttribute" +let tname_DebuggerStepThroughAttribute = + "System.Diagnostics.DebuggerStepThroughAttribute" + [] -let tname_DebuggerBrowsableAttribute = "System.Diagnostics.DebuggerBrowsableAttribute" +let tname_DebuggerBrowsableAttribute = + "System.Diagnostics.DebuggerBrowsableAttribute" + [] let tname_DebuggerBrowsableState = "System.Diagnostics.DebuggerBrowsableState" [] let tname_StringBuilder = "System.Text.StringBuilder" + [] let tname_IComparable = "System.IComparable" + [] let tname_Exception = "System.Exception" + [] let tname_Missing = "System.Reflection.Missing" + [] let tname_FormattableString = "System.FormattableString" + [] let tname_SerializationInfo = "System.Runtime.Serialization.SerializationInfo" + [] let tname_StreamingContext = "System.Runtime.Serialization.StreamingContext" + [] -let tname_SecurityPermissionAttribute = "System.Security.Permissions.SecurityPermissionAttribute" +let tname_SecurityPermissionAttribute = + "System.Security.Permissions.SecurityPermissionAttribute" + [] let tname_Delegate = "System.Delegate" + [] let tname_ValueType = "System.ValueType" + [] let tname_Enum = "System.Enum" + [] let tname_FlagsAttribute = "System.FlagsAttribute" + [] let tname_Array = "System.Array" + [] let tname_RuntimeArgumentHandle = "System.RuntimeArgumentHandle" + [] let tname_RuntimeTypeHandle = "System.RuntimeTypeHandle" + [] let tname_RuntimeMethodHandle = "System.RuntimeMethodHandle" + [] let tname_RuntimeFieldHandle = "System.RuntimeFieldHandle" + [] -let tname_CompilerGeneratedAttribute = "System.Runtime.CompilerServices.CompilerGeneratedAttribute" +let tname_CompilerGeneratedAttribute = + "System.Runtime.CompilerServices.CompilerGeneratedAttribute" + [] -let tname_ReferenceAssemblyAttribute = "System.Runtime.CompilerServices.ReferenceAssemblyAttribute" +let tname_ReferenceAssemblyAttribute = + "System.Runtime.CompilerServices.ReferenceAssemblyAttribute" + [] let tname_UnmanagedType = "System.Runtime.InteropServices.UnmanagedType" + [] let tname_DebuggableAttribute = "System.Diagnostics.DebuggableAttribute" + [] let tname_AsyncCallback = "System.AsyncCallback" + [] let tname_IAsyncResult = "System.IAsyncResult" -[] -let tname_IsByRefLikeAttribute = "System.Runtime.CompilerServices.IsByRefLikeAttribute" +[] +let tname_IsByRefLikeAttribute = + "System.Runtime.CompilerServices.IsByRefLikeAttribute" //------------------------------------------------------------------------- // Table of all these "globals" @@ -182,1825 +219,3262 @@ type CompilationMode = | Service | Interactive -type TcGlobals( - compilingFSharpCore: bool, - ilg: ILGlobals, - fslibCcu: CcuThunk, - directoryToResolveRelativePaths, - mlCompatibility: bool, - isInteractive: bool, - checkNullness: bool, - useReflectionFreeCodeGen: bool, - // The helper to find system types amongst referenced DLLs - tryFindSysTypeCcuHelper: string list -> string -> bool -> FSharp.Compiler.TypedTree.CcuThunk option, - emitDebugInfoInQuotations: bool, - noDebugAttributes: bool, - pathMap: PathMap, - langVersion: LanguageVersion, - realsig: bool, - compilationMode: CompilationMode) = - - let v_langFeatureNullness = langVersion.SupportsFeature LanguageFeature.NullnessChecking - - let v_knownWithNull = - if v_langFeatureNullness then KnownWithNull else KnownAmbivalentToNull - - let v_knownWithoutNull = - if v_langFeatureNullness then KnownWithoutNull else KnownAmbivalentToNull - - let mkNonGenericTy tcref = TType_app(tcref, [], v_knownWithoutNull) - - let mkNonGenericTyWithNullness tcref nullness = TType_app(tcref, [], nullness) - - let mkNonLocalTyconRef2 ccu path n = mkNonLocalTyconRef (mkNonLocalEntityRef ccu path) n - - let mk_MFCore_tcref ccu n = mkNonLocalTyconRef2 ccu CorePathArray n - let mk_MFQuotations_tcref ccu n = mkNonLocalTyconRef2 ccu QuotationsPath n - let mk_MFLinq_tcref ccu n = mkNonLocalTyconRef2 ccu LinqPathArray n - let mk_MFCollections_tcref ccu n = mkNonLocalTyconRef2 ccu CollectionsPathArray n - let mk_MFCompilerServices_tcref ccu n = mkNonLocalTyconRef2 ccu CompilerServicesPath n - let mk_MFControl_tcref ccu n = mkNonLocalTyconRef2 ccu ControlPathArray n - - let tryFindSysTypeCcu path nm = tryFindSysTypeCcuHelper path nm false - - let tryFindPublicSysTypeCcu path nm = tryFindSysTypeCcuHelper path nm true - - let vara = Construct.NewRigidTypar "a" envRange - let varb = Construct.NewRigidTypar "b" envRange - let varc = Construct.NewRigidTypar "c" envRange - let vard = Construct.NewRigidTypar "d" envRange - let vare = Construct.NewRigidTypar "e" envRange - - let varaTy = mkTyparTy vara - let varbTy = mkTyparTy varb - let varcTy = mkTyparTy varc - let vardTy = mkTyparTy vard - let vareTy = mkTyparTy vare - - let v_int_tcr = mk_MFCore_tcref fslibCcu "int" - let v_nativeint_tcr = mk_MFCore_tcref fslibCcu "nativeint" - let v_unativeint_tcr = mk_MFCore_tcref fslibCcu "unativeint" - let v_int32_tcr = mk_MFCore_tcref fslibCcu "int32" - let v_int16_tcr = mk_MFCore_tcref fslibCcu "int16" - let v_int64_tcr = mk_MFCore_tcref fslibCcu "int64" - let v_uint16_tcr = mk_MFCore_tcref fslibCcu "uint16" - let v_uint32_tcr = mk_MFCore_tcref fslibCcu "uint32" - let v_uint64_tcr = mk_MFCore_tcref fslibCcu "uint64" - let v_sbyte_tcr = mk_MFCore_tcref fslibCcu "sbyte" - let v_decimal_tcr = mk_MFCore_tcref fslibCcu "decimal" - let v_pdecimal_tcr = mk_MFCore_tcref fslibCcu "decimal`1" - let v_byte_tcr = mk_MFCore_tcref fslibCcu "byte" - let v_bool_tcr = mk_MFCore_tcref fslibCcu "bool" - let v_string_tcr = mk_MFCore_tcref fslibCcu "string" - let v_obj_tcr = mk_MFCore_tcref fslibCcu "obj" - let v_unit_tcr_canon = mk_MFCore_tcref fslibCcu "Unit" - let v_unit_tcr_nice = mk_MFCore_tcref fslibCcu "unit" - let v_exn_tcr = mk_MFCore_tcref fslibCcu "exn" - let v_char_tcr = mk_MFCore_tcref fslibCcu "char" - let v_float_tcr = mk_MFCore_tcref fslibCcu "float" - let v_float32_tcr = mk_MFCore_tcref fslibCcu "float32" - let v_pfloat_tcr = mk_MFCore_tcref fslibCcu "float`1" - let v_pfloat32_tcr = mk_MFCore_tcref fslibCcu "float32`1" - let v_pint_tcr = mk_MFCore_tcref fslibCcu "int`1" - let v_pint8_tcr = mk_MFCore_tcref fslibCcu "sbyte`1" - let v_pint16_tcr = mk_MFCore_tcref fslibCcu "int16`1" - let v_pint64_tcr = mk_MFCore_tcref fslibCcu "int64`1" - let v_pnativeint_tcr = mk_MFCore_tcref fslibCcu "nativeint`1" - let v_puint_tcr = mk_MFCore_tcref fslibCcu "uint`1" - let v_puint8_tcr = mk_MFCore_tcref fslibCcu "byte`1" - let v_puint16_tcr = mk_MFCore_tcref fslibCcu "uint16`1" - let v_puint64_tcr = mk_MFCore_tcref fslibCcu "uint64`1" - let v_punativeint_tcr = mk_MFCore_tcref fslibCcu "unativeint`1" - let v_byref_tcr = mk_MFCore_tcref fslibCcu "byref`1" - let v_byref2_tcr = mk_MFCore_tcref fslibCcu "byref`2" - let v_outref_tcr = mk_MFCore_tcref fslibCcu "outref`1" - let v_inref_tcr = mk_MFCore_tcref fslibCcu "inref`1" - let v_nativeptr_tcr = mk_MFCore_tcref fslibCcu "nativeptr`1" - let v_voidptr_tcr = mk_MFCore_tcref fslibCcu "voidptr" - let v_ilsigptr_tcr = mk_MFCore_tcref fslibCcu "ilsigptr`1" - let v_fastFunc_tcr = mk_MFCore_tcref fslibCcu "FSharpFunc`2" - let v_refcell_tcr_canon = mk_MFCore_tcref fslibCcu "Ref`1" - let v_refcell_tcr_nice = mk_MFCore_tcref fslibCcu "ref`1" - let v_mfe_tcr = mk_MFCore_tcref fslibCcu "MatchFailureException" - - let mutable embeddedILTypeDefs = ConcurrentDictionary() - - let dummyAssemblyNameCarryingUsefulErrorInformation path typeName = - FSComp.SR.tcGlobalsSystemTypeNotFound (String.concat "." path + "." + typeName) - - // Search for a type. If it is not found, leave a dangling CCU reference with some useful diagnostic information should - // the type actually be dereferenced - let findSysTypeCcu path typeName = - match tryFindSysTypeCcu path typeName with - | None -> CcuThunk.CreateDelayed(dummyAssemblyNameCarryingUsefulErrorInformation path typeName) - | Some ccu -> ccu - - let tryFindSysTyconRef path nm = - match tryFindSysTypeCcu path nm with - | Some ccu -> Some (mkNonLocalTyconRef2 ccu (Array.ofList path) nm) - | None -> None - - let findSysTyconRef path nm = - let ccu = findSysTypeCcu path nm - mkNonLocalTyconRef2 ccu (Array.ofList path) nm - - let findSysILTypeRef nm = - let path, typeName = splitILTypeName nm - let scoref = - match tryFindSysTypeCcu path typeName with - | None -> ILScopeRef.Assembly (mkSimpleAssemblyRef (dummyAssemblyNameCarryingUsefulErrorInformation path typeName)) - | Some ccu -> ccu.ILScopeRef - mkILTyRef (scoref, nm) - - let tryFindSysILTypeRef nm = - let path, typeName = splitILTypeName nm - tryFindSysTypeCcu path typeName |> Option.map (fun ccu -> mkILTyRef (ccu.ILScopeRef, nm)) - - let findSysAttrib nm = - let tref = findSysILTypeRef nm - let path, typeName = splitILTypeName nm - AttribInfo(tref, findSysTyconRef path typeName) - - let tryFindSysAttrib nm = - let path, typeName = splitILTypeName nm - - // System Attributes must be public types. - match tryFindSysTypeCcu path typeName with - | Some _ -> Some (findSysAttrib nm) - | None -> None - - let findPublicSysAttrib nm = - let path, typeName = splitILTypeName nm - let scoref, ccu = +type TcGlobals + ( + compilingFSharpCore: bool, + ilg: ILGlobals, + fslibCcu: CcuThunk, + directoryToResolveRelativePaths, + mlCompatibility: bool, + isInteractive: bool, + checkNullness: bool, + useReflectionFreeCodeGen: bool, + // The helper to find system types amongst referenced DLLs + tryFindSysTypeCcuHelper: string list -> string -> bool -> FSharp.Compiler.TypedTree.CcuThunk option, + emitDebugInfoInQuotations: bool, + noDebugAttributes: bool, + pathMap: PathMap, + langVersion: LanguageVersion, + realsig: bool, + compilationMode: CompilationMode + ) = + + let v_langFeatureNullness = + langVersion.SupportsFeature LanguageFeature.NullnessChecking + + let v_knownWithNull = + if v_langFeatureNullness then + KnownWithNull + else + KnownAmbivalentToNull + + let v_knownWithoutNull = + if v_langFeatureNullness then + KnownWithoutNull + else + KnownAmbivalentToNull + + let mkNonGenericTy tcref = + TType_app(tcref, [], v_knownWithoutNull) + + let mkNonGenericTyWithNullness tcref nullness = TType_app(tcref, [], nullness) + + let mkNonLocalTyconRef2 ccu path n = + mkNonLocalTyconRef (mkNonLocalEntityRef ccu path) n + + let mk_MFCore_tcref ccu n = mkNonLocalTyconRef2 ccu CorePathArray n + + let mk_MFQuotations_tcref ccu n = + mkNonLocalTyconRef2 ccu QuotationsPath n + + let mk_MFLinq_tcref ccu n = mkNonLocalTyconRef2 ccu LinqPathArray n + + let mk_MFCollections_tcref ccu n = + mkNonLocalTyconRef2 ccu CollectionsPathArray n + + let mk_MFCompilerServices_tcref ccu n = + mkNonLocalTyconRef2 ccu CompilerServicesPath n + + let mk_MFControl_tcref ccu n = + mkNonLocalTyconRef2 ccu ControlPathArray n + + let tryFindSysTypeCcu path nm = tryFindSysTypeCcuHelper path nm false + + let tryFindPublicSysTypeCcu path nm = tryFindSysTypeCcuHelper path nm true + + let vara = Construct.NewRigidTypar "a" envRange + let varb = Construct.NewRigidTypar "b" envRange + let varc = Construct.NewRigidTypar "c" envRange + let vard = Construct.NewRigidTypar "d" envRange + let vare = Construct.NewRigidTypar "e" envRange + + let varaTy = mkTyparTy vara + let varbTy = mkTyparTy varb + let varcTy = mkTyparTy varc + let vardTy = mkTyparTy vard + let vareTy = mkTyparTy vare + + let v_int_tcr = mk_MFCore_tcref fslibCcu "int" + let v_nativeint_tcr = mk_MFCore_tcref fslibCcu "nativeint" + let v_unativeint_tcr = mk_MFCore_tcref fslibCcu "unativeint" + let v_int32_tcr = mk_MFCore_tcref fslibCcu "int32" + let v_int16_tcr = mk_MFCore_tcref fslibCcu "int16" + let v_int64_tcr = mk_MFCore_tcref fslibCcu "int64" + let v_uint16_tcr = mk_MFCore_tcref fslibCcu "uint16" + let v_uint32_tcr = mk_MFCore_tcref fslibCcu "uint32" + let v_uint64_tcr = mk_MFCore_tcref fslibCcu "uint64" + let v_sbyte_tcr = mk_MFCore_tcref fslibCcu "sbyte" + let v_decimal_tcr = mk_MFCore_tcref fslibCcu "decimal" + let v_pdecimal_tcr = mk_MFCore_tcref fslibCcu "decimal`1" + let v_byte_tcr = mk_MFCore_tcref fslibCcu "byte" + let v_bool_tcr = mk_MFCore_tcref fslibCcu "bool" + let v_string_tcr = mk_MFCore_tcref fslibCcu "string" + let v_obj_tcr = mk_MFCore_tcref fslibCcu "obj" + let v_unit_tcr_canon = mk_MFCore_tcref fslibCcu "Unit" + let v_unit_tcr_nice = mk_MFCore_tcref fslibCcu "unit" + let v_exn_tcr = mk_MFCore_tcref fslibCcu "exn" + let v_char_tcr = mk_MFCore_tcref fslibCcu "char" + let v_float_tcr = mk_MFCore_tcref fslibCcu "float" + let v_float32_tcr = mk_MFCore_tcref fslibCcu "float32" + let v_pfloat_tcr = mk_MFCore_tcref fslibCcu "float`1" + let v_pfloat32_tcr = mk_MFCore_tcref fslibCcu "float32`1" + let v_pint_tcr = mk_MFCore_tcref fslibCcu "int`1" + let v_pint8_tcr = mk_MFCore_tcref fslibCcu "sbyte`1" + let v_pint16_tcr = mk_MFCore_tcref fslibCcu "int16`1" + let v_pint64_tcr = mk_MFCore_tcref fslibCcu "int64`1" + let v_pnativeint_tcr = mk_MFCore_tcref fslibCcu "nativeint`1" + let v_puint_tcr = mk_MFCore_tcref fslibCcu "uint`1" + let v_puint8_tcr = mk_MFCore_tcref fslibCcu "byte`1" + let v_puint16_tcr = mk_MFCore_tcref fslibCcu "uint16`1" + let v_puint64_tcr = mk_MFCore_tcref fslibCcu "uint64`1" + let v_punativeint_tcr = mk_MFCore_tcref fslibCcu "unativeint`1" + let v_byref_tcr = mk_MFCore_tcref fslibCcu "byref`1" + let v_byref2_tcr = mk_MFCore_tcref fslibCcu "byref`2" + let v_outref_tcr = mk_MFCore_tcref fslibCcu "outref`1" + let v_inref_tcr = mk_MFCore_tcref fslibCcu "inref`1" + let v_nativeptr_tcr = mk_MFCore_tcref fslibCcu "nativeptr`1" + let v_voidptr_tcr = mk_MFCore_tcref fslibCcu "voidptr" + let v_ilsigptr_tcr = mk_MFCore_tcref fslibCcu "ilsigptr`1" + let v_fastFunc_tcr = mk_MFCore_tcref fslibCcu "FSharpFunc`2" + let v_refcell_tcr_canon = mk_MFCore_tcref fslibCcu "Ref`1" + let v_refcell_tcr_nice = mk_MFCore_tcref fslibCcu "ref`1" + let v_mfe_tcr = mk_MFCore_tcref fslibCcu "MatchFailureException" + + let mutable embeddedILTypeDefs = ConcurrentDictionary() + + let dummyAssemblyNameCarryingUsefulErrorInformation path typeName = + FSComp.SR.tcGlobalsSystemTypeNotFound (String.concat "." path + "." + typeName) + + // Search for a type. If it is not found, leave a dangling CCU reference with some useful diagnostic information should + // the type actually be dereferenced + let findSysTypeCcu path typeName = + match tryFindSysTypeCcu path typeName with + | None -> CcuThunk.CreateDelayed(dummyAssemblyNameCarryingUsefulErrorInformation path typeName) + | Some ccu -> ccu + + let tryFindSysTyconRef path nm = + match tryFindSysTypeCcu path nm with + | Some ccu -> Some(mkNonLocalTyconRef2 ccu (Array.ofList path) nm) + | None -> None + + let findSysTyconRef path nm = + let ccu = findSysTypeCcu path nm + mkNonLocalTyconRef2 ccu (Array.ofList path) nm + + let findSysILTypeRef nm = + let path, typeName = splitILTypeName nm + + let scoref = + match tryFindSysTypeCcu path typeName with + | None -> ILScopeRef.Assembly(mkSimpleAssemblyRef (dummyAssemblyNameCarryingUsefulErrorInformation path typeName)) + | Some ccu -> ccu.ILScopeRef + + mkILTyRef (scoref, nm) + + let tryFindSysILTypeRef nm = + let path, typeName = splitILTypeName nm + + tryFindSysTypeCcu path typeName + |> Option.map (fun ccu -> mkILTyRef (ccu.ILScopeRef, nm)) + + let findSysAttrib nm = + let tref = findSysILTypeRef nm + let path, typeName = splitILTypeName nm + AttribInfo(tref, findSysTyconRef path typeName) + + let tryFindSysAttrib nm = + let path, typeName = splitILTypeName nm + + // System Attributes must be public types. + match tryFindSysTypeCcu path typeName with + | Some _ -> Some(findSysAttrib nm) + | None -> None + + let findPublicSysAttrib nm = + let path, typeName = splitILTypeName nm + + let scoref, ccu = match tryFindPublicSysTypeCcu path typeName with | None -> - ILScopeRef.Assembly (mkSimpleAssemblyRef (dummyAssemblyNameCarryingUsefulErrorInformation path typeName)), + ILScopeRef.Assembly(mkSimpleAssemblyRef (dummyAssemblyNameCarryingUsefulErrorInformation path typeName)), CcuThunk.CreateDelayed(dummyAssemblyNameCarryingUsefulErrorInformation path typeName) - | Some ccu -> - ccu.ILScopeRef, - ccu - let tref = mkILTyRef (scoref, nm) - let tcref = mkNonLocalTyconRef2 ccu (Array.ofList path) typeName - AttribInfo(tref, tcref) - - // Well known set of generated embeddable attribute names - static let isInEmbeddableKnownSet name = - match name with - | "System.Runtime.CompilerServices.IsReadOnlyAttribute" - | "System.Runtime.CompilerServices.IsUnmanagedAttribute" - | "System.Runtime.CompilerServices.NullableAttribute" - | "System.Runtime.CompilerServices.NullableContextAttribute" - | "System.Diagnostics.CodeAnalysis.MemberNotNullWhenAttribute" - | "System.Diagnostics.CodeAnalysis.DynamicDependencyAttribute" - | "System.Diagnostics.CodeAnalysis.DynamicallyAccessedMemberTypes" -> true - | _ -> false - - let findOrEmbedSysPublicType nm = - - assert (isInEmbeddableKnownSet nm) //Ensure that the named type is in known set of embedded types - - let sysAttrib = findPublicSysAttrib nm - if sysAttrib.TyconRef.CanDeref then - sysAttrib - else - let attrRef = ILTypeRef.Create(ILScopeRef.Local, [], nm) - let attrTycon = - Construct.NewTycon( - Some (CompPath(ILScopeRef.Local, SyntaxAccess.Internal, [])), - attrRef.Name, - range0, - taccessInternal, - taccessInternal, - TyparKind.Type, - LazyWithContext.NotLazy [], - FSharp.Compiler.Xml.XmlDoc.Empty, - false, - false, - false, - MaybeLazy.Strict(Construct.NewEmptyModuleOrNamespaceType ModuleOrType) - ) - AttribInfo(attrRef, mkLocalTyconRef attrTycon) - - let mkSysNonGenericTy path n = mkNonGenericTy(findSysTyconRef path n) - let tryMkSysNonGenericTy path n = tryFindSysTyconRef path n |> Option.map mkNonGenericTy - - let sys = ["System"] - let sysCollections = ["System";"Collections"] - let sysGenerics = ["System";"Collections";"Generic"] - let sysCompilerServices = ["System";"Runtime";"CompilerServices"] - - let lazy_tcr = findSysTyconRef sys "Lazy`1" - let v_fslib_IEvent2_tcr = mk_MFControl_tcref fslibCcu "IEvent`2" - let v_tcref_IObservable = findSysTyconRef sys "IObservable`1" - let v_tcref_IObserver = findSysTyconRef sys "IObserver`1" - let v_fslib_IDelegateEvent_tcr = mk_MFControl_tcref fslibCcu "IDelegateEvent`1" - - let v_option_tcr_nice = mk_MFCore_tcref fslibCcu "option`1" - let v_valueoption_tcr_nice = mk_MFCore_tcref fslibCcu "voption`1" - let v_list_tcr_canon = mk_MFCollections_tcref fslibCcu "List`1" - let v_list_tcr_nice = mk_MFCollections_tcref fslibCcu "list`1" - let v_lazy_tcr_nice = mk_MFControl_tcref fslibCcu "Lazy`1" - let v_seq_tcr = mk_MFCollections_tcref fslibCcu "seq`1" - let v_format_tcr = mk_MFCore_tcref fslibCcu "PrintfFormat`5" - let v_format4_tcr = mk_MFCore_tcref fslibCcu "PrintfFormat`4" - let v_date_tcr = findSysTyconRef sys "DateTime" - let v_IEnumerable_tcr = findSysTyconRef sysGenerics "IEnumerable`1" - let v_IEnumerator_tcr = findSysTyconRef sysGenerics "IEnumerator`1" - let v_System_Attribute_tcr = findSysTyconRef sys "Attribute" - let v_expr_tcr = mk_MFQuotations_tcref fslibCcu "Expr`1" - let v_raw_expr_tcr = mk_MFQuotations_tcref fslibCcu "Expr" - let v_query_builder_tcref = mk_MFLinq_tcref fslibCcu "QueryBuilder" - let v_querySource_tcr = mk_MFLinq_tcref fslibCcu "QuerySource`2" - let v_linqExpression_tcr = findSysTyconRef ["System";"Linq";"Expressions"] "Expression`1" - - let v_il_arr_tcr_map = - Array.init 32 (fun idx -> - let type_sig = - let rank = idx + 1 - if rank = 1 then "[]`1" - else "[" + (String.replicate (rank - 1) ",") + "]`1" - mk_MFCore_tcref fslibCcu type_sig) - - let v_byte_ty = mkNonGenericTy v_byte_tcr - let v_sbyte_ty = mkNonGenericTy v_sbyte_tcr - let v_int16_ty = mkNonGenericTy v_int16_tcr - let v_uint16_ty = mkNonGenericTy v_uint16_tcr - let v_int_ty = mkNonGenericTy v_int_tcr - let v_int32_ty = mkNonGenericTy v_int32_tcr - let v_uint32_ty = mkNonGenericTy v_uint32_tcr - let v_int64_ty = mkNonGenericTy v_int64_tcr - let v_uint64_ty = mkNonGenericTy v_uint64_tcr - let v_float32_ty = mkNonGenericTy v_float32_tcr - let v_float_ty = mkNonGenericTy v_float_tcr - let v_nativeint_ty = mkNonGenericTy v_nativeint_tcr - let v_unativeint_ty = mkNonGenericTy v_unativeint_tcr - - let v_enum_ty = mkNonGenericTy v_int_tcr - let v_bool_ty = mkNonGenericTy v_bool_tcr - let v_char_ty = mkNonGenericTy v_char_tcr - let v_obj_ty_without_null = mkNonGenericTyWithNullness v_obj_tcr v_knownWithoutNull - let v_obj_ty_ambivalent = mkNonGenericTyWithNullness v_obj_tcr KnownAmbivalentToNull - let v_obj_ty_with_null = mkNonGenericTyWithNullness v_obj_tcr v_knownWithNull - let v_IFormattable_tcref = findSysTyconRef sys "IFormattable" - let v_FormattableString_tcref = findSysTyconRef sys "FormattableString" - let v_IFormattable_ty = mkNonGenericTy v_IFormattable_tcref - let v_FormattableString_ty = mkNonGenericTy v_FormattableString_tcref - let v_FormattableStringFactory_tcref = findSysTyconRef sysCompilerServices "FormattableStringFactory" - let v_FormattableStringFactory_ty = mkNonGenericTy v_FormattableStringFactory_tcref - let v_string_ty = mkNonGenericTy v_string_tcr - let v_string_ty_ambivalent = mkNonGenericTyWithNullness v_string_tcr KnownAmbivalentToNull - let v_decimal_ty = mkSysNonGenericTy sys "Decimal" - let v_unit_ty = mkNonGenericTy v_unit_tcr_nice - let v_system_Type_ty = mkSysNonGenericTy sys "Type" - let v_Array_tcref = findSysTyconRef sys "Array" - - let v_system_Reflection_MethodInfo_ty = mkSysNonGenericTy ["System";"Reflection"] "MethodInfo" - let v_nullable_tcr = findSysTyconRef sys "Nullable`1" - (* local helpers to build value infos *) - let mkNullableTy ty = TType_app(v_nullable_tcr, [ty], v_knownWithoutNull) - let mkByrefTy ty = TType_app(v_byref_tcr, [ty], v_knownWithoutNull) - let mkNativePtrTy ty = TType_app(v_nativeptr_tcr, [ty], v_knownWithoutNull) - let mkFunTy d r = TType_fun (d, r, v_knownWithoutNull) - let mkFunTyWithNullness d r nullness = TType_fun (d, r, nullness) - let (-->) d r = mkFunTy d r - let mkIteratedFunTy dl r = List.foldBack mkFunTy dl r - let mkSmallRefTupledTy l = match l with [] -> v_unit_ty | [h] -> h | tys -> mkRawRefTupleTy tys - let mkForallTyIfNeeded d r = match d with [] -> r | tps -> TType_forall(tps, r) - - // A table of all intrinsics that the compiler cares about - let v_knownIntrinsics = ConcurrentDictionary(HashIdentity.Structural) - - let makeIntrinsicValRefGeneral isKnown (enclosingEntity, logicalName, memberParentName, compiledNameOpt, typars, (argTys, retTy)) = - let ty = mkForallTyIfNeeded typars (mkIteratedFunTy (List.map mkSmallRefTupledTy argTys) retTy) - let isMember = Option.isSome memberParentName - let argCount = if isMember then List.sumBy List.length argTys else 0 - let linkageType = if isMember then Some ty else None - let key = ValLinkageFullKey({ MemberParentMangledName=memberParentName; MemberIsOverride=false; LogicalName=logicalName; TotalArgCount= argCount }, linkageType) - let vref = IntrinsicValRef(enclosingEntity, logicalName, isMember, ty, key) - let compiledName = defaultArg compiledNameOpt logicalName - - let key = (enclosingEntity.LastItemMangledName, memberParentName, compiledName, argCount) - assert not (v_knownIntrinsics.ContainsKey(key)) - if isKnown && not (v_knownIntrinsics.ContainsKey(key)) then - v_knownIntrinsics[key] <- ValRefForIntrinsic vref - vref - - let makeIntrinsicValRef info = makeIntrinsicValRefGeneral true info - let makeOtherIntrinsicValRef info = makeIntrinsicValRefGeneral false info - - let v_IComparer_ty = mkSysNonGenericTy sysCollections "IComparer" - let v_IEqualityComparer_ty = mkSysNonGenericTy sysCollections "IEqualityComparer" - - let v_system_RuntimeMethodHandle_ty = mkSysNonGenericTy sys "RuntimeMethodHandle" - - let mk_unop_ty ty = [[ty]], ty - let mk_binop_ty ty = [[ty]; [ty]], ty - let mk_shiftop_ty ty = [[ty]; [v_int_ty]], ty - let mk_binop_ty3 ty1 ty2 ty3 = [[ty1]; [ty2]], ty3 - let mk_rel_sig ty = [[ty];[ty]], v_bool_ty - let mk_compare_sig ty = [[ty];[ty]], v_int_ty - let mk_hash_sig ty = [[ty]], v_int_ty - let mk_compare_withc_sig ty = [[v_IComparer_ty];[ty]; [ty]], v_int_ty - let mk_equality_withc_sig ty = [[v_IEqualityComparer_ty];[ty];[ty]], v_bool_ty - let mk_hash_withc_sig ty = [[v_IEqualityComparer_ty]; [ty]], v_int_ty - - let mkListTy ty = TType_app(v_list_tcr_nice, [ty], v_knownWithoutNull) - - let mkSeqTy ty1 = TType_app(v_seq_tcr, [ty1], v_knownWithoutNull) - - let mkIEvent2Ty ty1 ty2 = TType_app (v_fslib_IEvent2_tcr, [ty1; ty2], v_knownWithoutNull) - - let mkRefCellTy ty = TType_app(v_refcell_tcr_canon, [ty], v_knownWithoutNull) - - let mkOptionTy ty = TType_app(v_option_tcr_nice, [ty], v_knownWithoutNull) - - let mkQuerySourceTy ty1 ty2 = TType_app(v_querySource_tcr, [ty1; ty2], v_knownWithoutNull) - - let v_tcref_System_Collections_IEnumerable = findSysTyconRef sysCollections "IEnumerable"; - - let mkArrayType rank (ty : TType) : TType = - assert (rank >= 1 && rank <= 32) - TType_app(v_il_arr_tcr_map[rank - 1], [ty], v_knownWithoutNull) - - let mkLazyTy ty = TType_app(lazy_tcr, [ty], v_knownWithoutNull) - - let mkPrintfFormatTy aty bty cty dty ety = TType_app(v_format_tcr, [aty;bty;cty;dty; ety], v_knownWithoutNull) - - let mk_format4_ty aty bty cty dty = TType_app(v_format4_tcr, [aty;bty;cty;dty], v_knownWithoutNull) - - let mkQuotedExprTy aty = TType_app(v_expr_tcr, [aty], v_knownWithoutNull) - - let mkRawQuotedExprTy = TType_app(v_raw_expr_tcr, [], v_knownWithoutNull) - - let mkQueryBuilderTy = TType_app(v_query_builder_tcref, [], v_knownWithoutNull) - - let mkLinqExpressionTy aty = TType_app(v_linqExpression_tcr, [aty], v_knownWithoutNull) - - let v_cons_ucref = mkUnionCaseRef v_list_tcr_canon "op_ColonColon" - - let v_nil_ucref = mkUnionCaseRef v_list_tcr_canon "op_Nil" - - let fslib_MF_nleref = mkNonLocalEntityRef fslibCcu RootPathArray - let fslib_MFCore_nleref = mkNonLocalEntityRef fslibCcu CorePathArray - let fslib_MFLinq_nleref = mkNonLocalEntityRef fslibCcu LinqPathArray - let fslib_MFCollections_nleref = mkNonLocalEntityRef fslibCcu CollectionsPathArray - let fslib_MFCompilerServices_nleref = mkNonLocalEntityRef fslibCcu CompilerServicesPath - let fslib_MFLinqRuntimeHelpers_nleref = mkNonLocalEntityRef fslibCcu LinqRuntimeHelpersPath - let fslib_MFControl_nleref = mkNonLocalEntityRef fslibCcu ControlPathArray - let fslib_MFNativeInterop_nleref = mkNonLocalEntityRef fslibCcu NativeInteropPath - - let fslib_MFLanguagePrimitives_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "LanguagePrimitives" - let fslib_MFIntrinsicOperators_nleref = mkNestedNonLocalEntityRef fslib_MFLanguagePrimitives_nleref "IntrinsicOperators" - let fslib_MFIntrinsicFunctions_nleref = mkNestedNonLocalEntityRef fslib_MFLanguagePrimitives_nleref "IntrinsicFunctions" - let fslib_MFHashCompare_nleref = mkNestedNonLocalEntityRef fslib_MFLanguagePrimitives_nleref "HashCompare" - let fslib_MFOperators_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "Operators" - let fslib_MFByRefKinds_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "ByRefKinds" - let fslib_MFOperatorIntrinsics_nleref = mkNestedNonLocalEntityRef fslib_MFOperators_nleref "OperatorIntrinsics" - let fslib_MFOperatorsUnchecked_nleref = mkNestedNonLocalEntityRef fslib_MFOperators_nleref "Unchecked" - let fslib_MFOperatorsChecked_nleref = mkNestedNonLocalEntityRef fslib_MFOperators_nleref "Checked" - let fslib_MFExtraTopLevelOperators_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "ExtraTopLevelOperators" - let fslib_MFNullableOperators_nleref = mkNestedNonLocalEntityRef fslib_MFLinq_nleref "NullableOperators" - let fslib_MFQueryRunExtensions_nleref = mkNestedNonLocalEntityRef fslib_MFLinq_nleref "QueryRunExtensions" - let fslib_MFQueryRunExtensionsLowPriority_nleref = mkNestedNonLocalEntityRef fslib_MFQueryRunExtensions_nleref "LowPriority" - let fslib_MFQueryRunExtensionsHighPriority_nleref = mkNestedNonLocalEntityRef fslib_MFQueryRunExtensions_nleref "HighPriority" - - let fslib_MFPrintfModule_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "PrintfModule" - let fslib_MFSeqModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "SeqModule" - let fslib_MFListModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "ListModule" - let fslib_MFArrayModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "ArrayModule" - let fslib_MFArray2DModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "Array2DModule" - let fslib_MFArray3DModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "Array3DModule" - let fslib_MFArray4DModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "Array4DModule" - let fslib_MFSetModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "SetModule" - let fslib_MFMapModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "MapModule" - let fslib_MFStringModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "StringModule" - let fslib_MFNativePtrModule_nleref = mkNestedNonLocalEntityRef fslib_MFNativeInterop_nleref "NativePtrModule" - let fslib_MFOptionModule_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "OptionModule" - let fslib_MFStateMachineHelpers_nleref = mkNestedNonLocalEntityRef fslib_MFCompilerServices_nleref "StateMachineHelpers" - let fslib_MFRuntimeHelpers_nleref = mkNestedNonLocalEntityRef fslib_MFCompilerServices_nleref "RuntimeHelpers" - let fslib_MFQuotations_nleref = mkNestedNonLocalEntityRef fslib_MF_nleref "Quotations" - - let fslib_MFLinqRuntimeHelpersQuotationConverter_nleref = mkNestedNonLocalEntityRef fslib_MFLinqRuntimeHelpers_nleref "LeafExpressionConverter" - let fslib_MFLazyExtensions_nleref = mkNestedNonLocalEntityRef fslib_MFControl_nleref "LazyExtensions" - - let v_ref_tuple1_tcr = findSysTyconRef sys "Tuple`1" - let v_ref_tuple2_tcr = findSysTyconRef sys "Tuple`2" - let v_ref_tuple3_tcr = findSysTyconRef sys "Tuple`3" - let v_ref_tuple4_tcr = findSysTyconRef sys "Tuple`4" - let v_ref_tuple5_tcr = findSysTyconRef sys "Tuple`5" - let v_ref_tuple6_tcr = findSysTyconRef sys "Tuple`6" - let v_ref_tuple7_tcr = findSysTyconRef sys "Tuple`7" - let v_ref_tuple8_tcr = findSysTyconRef sys "Tuple`8" - let v_struct_tuple1_tcr = findSysTyconRef sys "ValueTuple`1" - let v_struct_tuple2_tcr = findSysTyconRef sys "ValueTuple`2" - let v_struct_tuple3_tcr = findSysTyconRef sys "ValueTuple`3" - let v_struct_tuple4_tcr = findSysTyconRef sys "ValueTuple`4" - let v_struct_tuple5_tcr = findSysTyconRef sys "ValueTuple`5" - let v_struct_tuple6_tcr = findSysTyconRef sys "ValueTuple`6" - let v_struct_tuple7_tcr = findSysTyconRef sys "ValueTuple`7" - let v_struct_tuple8_tcr = findSysTyconRef sys "ValueTuple`8" - - let v_choice2_tcr = mk_MFCore_tcref fslibCcu "Choice`2" - let v_choice3_tcr = mk_MFCore_tcref fslibCcu "Choice`3" - let v_choice4_tcr = mk_MFCore_tcref fslibCcu "Choice`4" - let v_choice5_tcr = mk_MFCore_tcref fslibCcu "Choice`5" - let v_choice6_tcr = mk_MFCore_tcref fslibCcu "Choice`6" - let v_choice7_tcr = mk_MFCore_tcref fslibCcu "Choice`7" - let tyconRefEq x y = primEntityRefEq compilingFSharpCore fslibCcu x y - - let v_suppressed_types = - [ mk_MFCore_tcref fslibCcu "Option`1"; - mk_MFCore_tcref fslibCcu "Ref`1"; - mk_MFCore_tcref fslibCcu "FSharpTypeFunc"; - mk_MFCore_tcref fslibCcu "FSharpFunc`2"; - mk_MFCore_tcref fslibCcu "Unit" ] - - let v_knownFSharpCoreModules = - dict [ for nleref in [ fslib_MFLanguagePrimitives_nleref - fslib_MFIntrinsicOperators_nleref - fslib_MFIntrinsicFunctions_nleref - fslib_MFHashCompare_nleref - fslib_MFOperators_nleref - fslib_MFOperatorIntrinsics_nleref - fslib_MFOperatorsUnchecked_nleref - fslib_MFOperatorsChecked_nleref - fslib_MFExtraTopLevelOperators_nleref - fslib_MFNullableOperators_nleref - fslib_MFQueryRunExtensions_nleref - fslib_MFQueryRunExtensionsLowPriority_nleref - fslib_MFQueryRunExtensionsHighPriority_nleref - - fslib_MFPrintfModule_nleref - fslib_MFSeqModule_nleref - fslib_MFListModule_nleref - fslib_MFArrayModule_nleref - fslib_MFArray2DModule_nleref - fslib_MFArray3DModule_nleref - fslib_MFArray4DModule_nleref - fslib_MFSetModule_nleref - fslib_MFMapModule_nleref - fslib_MFStringModule_nleref - fslib_MFNativePtrModule_nleref - fslib_MFOptionModule_nleref - fslib_MFStateMachineHelpers_nleref - fslib_MFRuntimeHelpers_nleref ] do - - yield nleref.LastItemMangledName, ERefNonLocal nleref ] - - let tryDecodeTupleTy tupInfo l = - match l with - | [t1;t2;t3;t4;t5;t6;t7;markerTy] -> - match markerTy with - | TType_app(tcref, [t8], _) when tyconRefEq tcref v_ref_tuple1_tcr -> mkRawRefTupleTy [t1;t2;t3;t4;t5;t6;t7;t8] |> Some - | TType_app(tcref, [t8], _) when tyconRefEq tcref v_struct_tuple1_tcr -> mkRawStructTupleTy [t1;t2;t3;t4;t5;t6;t7;t8] |> Some - | TType_tuple (_structness2, t8plus) -> TType_tuple (tupInfo, [t1;t2;t3;t4;t5;t6;t7] @ t8plus) |> Some - | _ -> None - | [] -> None - | [_] -> None - | _ -> TType_tuple (tupInfo, l) |> Some - - let decodeTupleTyAndNullness tupInfo tinst _nullness = - match tryDecodeTupleTy tupInfo tinst with - | Some ty -> ty - | None -> failwith "couldn't decode tuple ty" - - let decodeTupleTyAndNullnessIfPossible tcref tupInfo tinst nullness = - match tryDecodeTupleTy tupInfo tinst with - | Some ty -> ty - | None -> TType_app(tcref, tinst, nullness) - - let decodeTupleTy tupInfo tinst = - decodeTupleTyAndNullness tupInfo tinst v_knownWithoutNull - - let mk_MFCore_attrib nm : BuiltinAttribInfo = - AttribInfo(mkILTyRef(ilg.fsharpCoreAssemblyScopeRef, Core + "." + nm), mk_MFCore_tcref fslibCcu nm) - - let mk_MFCompilerServices_attrib nm : BuiltinAttribInfo = - AttribInfo(mkILTyRef(ilg.fsharpCoreAssemblyScopeRef, Core + "." + nm), mk_MFCompilerServices_tcref fslibCcu nm) - - let mkSourceDoc fileName = ILSourceDocument.Create(language=None, vendor=None, documentType=None, file=fileName) - - let compute i = - let path = fileOfFileIndex i - let fullPath = FileSystem.GetFullFilePathInDirectoryShim directoryToResolveRelativePaths path - mkSourceDoc fullPath - - // Build the memoization table for files - let v_memoize_file = - MemoizationTable(compute, keyComparer = HashIdentity.Structural) - - let v_and_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "&" , None , None , [], mk_rel_sig v_bool_ty) - let v_addrof_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&" , None , None , [vara], ([[varaTy]], mkByrefTy varaTy)) - let v_addrof2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&&" , None , None , [vara], ([[varaTy]], mkNativePtrTy varaTy)) - let v_and2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "&&" , None , None , [], mk_rel_sig v_bool_ty) - let v_or_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, "or" , None , Some "Or" , [], mk_rel_sig v_bool_ty) - let v_or2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "||" , None , None , [], mk_rel_sig v_bool_ty) - let v_compare_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "compare" , None , Some "Compare", [vara], mk_compare_sig varaTy) - let v_equals_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName "=" , None , None , [vara], mk_rel_sig varaTy) - let v_equals_nullable_operator_info = makeIntrinsicValRef(fslib_MFNullableOperators_nleref, CompileOpName "=?" , None , None , [vara], ([[varaTy];[mkNullableTy varaTy]], v_bool_ty)) - let v_nullable_equals_operator_info = makeIntrinsicValRef(fslib_MFNullableOperators_nleref, CompileOpName "?=" , None , None , [vara], ([[mkNullableTy varaTy];[varaTy]], v_bool_ty)) - let v_nullable_equals_nullable_operator_info = makeIntrinsicValRef(fslib_MFNullableOperators_nleref, CompileOpName "?=?" , None , None , [vara], ([[mkNullableTy varaTy];[mkNullableTy varaTy]], v_bool_ty)) - let v_not_equals_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName "<>" , None , None , [vara], mk_rel_sig varaTy) - let v_less_than_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName "<" , None , None , [vara], mk_rel_sig varaTy) - let v_less_than_or_equals_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName "<=" , None , None , [vara], mk_rel_sig varaTy) - let v_greater_than_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName ">" , None , None , [vara], mk_rel_sig varaTy) - let v_greater_than_or_equals_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, CompileOpName ">=" , None , None , [vara], mk_rel_sig varaTy) - - let v_enumOfValue_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "EnumOfValue" , None , None , [vara; varb], ([[varaTy]], varbTy)) - - let v_generic_comparison_withc_outer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericComparisonWithComparer" , None , None , [vara], mk_compare_withc_sig varaTy) - let v_generic_hash_withc_tuple2_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastHashTuple2" , None , None , [vara;varb], mk_hash_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy])) - let v_generic_hash_withc_tuple3_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastHashTuple3" , None , None , [vara;varb;varc], mk_hash_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy])) - let v_generic_hash_withc_tuple4_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastHashTuple4" , None , None , [vara;varb;varc;vard], mk_hash_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy; vardTy])) - let v_generic_hash_withc_tuple5_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastHashTuple5" , None , None , [vara;varb;varc;vard;vare], mk_hash_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy; vardTy; vareTy])) - let v_generic_equals_withc_tuple2_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastEqualsTuple2" , None , None , [vara;varb], mk_equality_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy])) - let v_generic_equals_withc_tuple3_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastEqualsTuple3" , None , None , [vara;varb;varc], mk_equality_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy])) - let v_generic_equals_withc_tuple4_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastEqualsTuple4" , None , None , [vara;varb;varc;vard], mk_equality_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy; vardTy])) - let v_generic_equals_withc_tuple5_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastEqualsTuple5" , None , None , [vara;varb;varc;vard;vare], mk_equality_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy; vardTy; vareTy])) - - let v_generic_compare_withc_tuple2_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastCompareTuple2" , None , None , [vara;varb], mk_compare_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy])) - let v_generic_compare_withc_tuple3_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastCompareTuple3" , None , None , [vara;varb;varc], mk_compare_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy])) - let v_generic_compare_withc_tuple4_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastCompareTuple4" , None , None , [vara;varb;varc;vard], mk_compare_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy; vardTy])) - let v_generic_compare_withc_tuple5_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FastCompareTuple5" , None , None , [vara;varb;varc;vard;vare], mk_compare_withc_sig (decodeTupleTy tupInfoRef [varaTy; varbTy; varcTy; vardTy; vareTy])) - - - let v_generic_equality_er_outer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericEqualityER" , None , None , [vara], mk_rel_sig varaTy) - let v_get_generic_comparer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericComparer" , None , None , [], ([], v_IComparer_ty)) - let v_get_generic_er_equality_comparer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericEqualityERComparer" , None , None , [], ([], v_IEqualityComparer_ty)) - let v_get_generic_per_equality_comparer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericEqualityComparer" , None , None , [], ([], v_IEqualityComparer_ty)) - let v_generic_equality_withc_outer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericEqualityWithComparer" , None , None , [vara], mk_equality_withc_sig varaTy) - let v_generic_hash_withc_outer_info = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref, "GenericHashWithComparer" , None , None , [vara], mk_hash_withc_sig varaTy) - - let v_generic_equality_er_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericEqualityERIntrinsic" , None , None , [vara], mk_rel_sig varaTy) - let v_generic_equality_per_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericEqualityIntrinsic" , None , None , [vara], mk_rel_sig varaTy) - let v_generic_equality_withc_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericEqualityWithComparerIntrinsic" , None , None , [vara], mk_equality_withc_sig varaTy) - let v_generic_comparison_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericComparisonIntrinsic" , None , None , [vara], mk_compare_sig varaTy) - let v_generic_comparison_withc_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericComparisonWithComparerIntrinsic", None , None , [vara], mk_compare_withc_sig varaTy) - - let v_generic_hash_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericHashIntrinsic" , None , None , [vara], mk_hash_sig varaTy) - let v_generic_hash_withc_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericHashWithComparerIntrinsic" , None , None , [vara], mk_hash_withc_sig varaTy) - - let v_create_instance_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "CreateInstance" , None , None , [vara], ([[v_unit_ty]], varaTy)) - let v_unbox_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "UnboxGeneric" , None , None , [vara], ([[v_obj_ty_with_null]], varaTy)) - - let v_unbox_fast_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "UnboxFast" , None , None , [vara], ([[v_obj_ty_with_null]], varaTy)) - let v_istype_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "TypeTestGeneric" , None , None , [vara], ([[v_obj_ty_with_null]], v_bool_ty)) - let v_istype_fast_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "TypeTestFast" , None , None , [vara], ([[v_obj_ty_with_null]], v_bool_ty)) - - let v_dispose_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "Dispose" , None , None , [vara], ([[varaTy]], v_unit_ty)) - - let v_getstring_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "GetString" , None , None , [], ([[v_string_ty];[v_int_ty]], v_char_ty)) - - let v_reference_equality_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "PhysicalEqualityIntrinsic" , None , None , [vara], mk_rel_sig varaTy) - - let v_piperight_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_PipeRight" , None , None , [vara; varb],([[varaTy];[varaTy --> varbTy]], varbTy)) - let v_piperight2_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_PipeRight2" , None , None , [vara; varb; varc],([[varaTy; varbTy];[varaTy --> (varbTy --> varcTy)]], varcTy)) - let v_piperight3_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_PipeRight3" , None , None , [vara; varb; varc; vard],([[varaTy; varbTy; varcTy];[varaTy --> (varbTy --> (varcTy --> vardTy))]], vardTy)) - let v_bitwise_or_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_BitwiseOr" , None , None , [vara], mk_binop_ty varaTy) - let v_bitwise_and_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_BitwiseAnd" , None , None , [vara], mk_binop_ty varaTy) - let v_bitwise_xor_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_ExclusiveOr" , None , None , [vara], mk_binop_ty varaTy) - let v_bitwise_unary_not_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_LogicalNot" , None , None , [vara], mk_unop_ty varaTy) - let v_bitwise_shift_left_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_LeftShift" , None , None , [vara], mk_shiftop_ty varaTy) - let v_bitwise_shift_right_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_RightShift" , None , None , [vara], mk_shiftop_ty varaTy) - let v_exponentiation_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Exponentiation" , None , None , [vara;varb], ([[varaTy];[varbTy]], varaTy)) - let v_unchecked_addition_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Addition" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_unchecked_subtraction_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Subtraction" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_unchecked_multiply_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Multiply" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_unchecked_division_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Division" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_unchecked_modulus_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Modulus" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_unchecked_unary_plus_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_UnaryPlus" , None , None , [vara], mk_unop_ty varaTy) - let v_unchecked_unary_minus_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_UnaryNegation" , None , None , [vara], mk_unop_ty varaTy) - let v_unchecked_unary_not_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "not" , None , Some "Not" , [], mk_unop_ty v_bool_ty) - let v_refcell_deref_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Dereference" , None , None , [vara], ([[mkRefCellTy varaTy]], varaTy)) - let v_refcell_assign_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_ColonEquals" , None , None , [vara], ([[mkRefCellTy varaTy]; [varaTy]], v_unit_ty)) - let v_refcell_incr_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "incr" , None , Some "Increment" , [], ([[mkRefCellTy v_int_ty]], v_unit_ty)) - let v_refcell_decr_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "decr" , None , Some "Decrement" , [], ([[mkRefCellTy v_int_ty]], v_unit_ty)) - - let v_checked_addition_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "op_Addition" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_checked_subtraction_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "op_Subtraction" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_checked_multiply_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "op_Multiply" , None , None , [vara;varb;varc], mk_binop_ty3 varaTy varbTy varcTy) - let v_checked_unary_minus_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "op_UnaryNegation" , None , None , [vara], mk_unop_ty varaTy) - - let v_byte_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "byte" , None , Some "ToByte", [vara], ([[varaTy]], v_byte_ty)) - let v_sbyte_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "sbyte" , None , Some "ToSByte", [vara], ([[varaTy]], v_sbyte_ty)) - let v_int16_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "int16" , None , Some "ToInt16", [vara], ([[varaTy]], v_int16_ty)) - let v_uint16_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "uint16" , None , Some "ToUInt16", [vara], ([[varaTy]], v_uint16_ty)) - let v_int_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "int" , None , Some "ToInt", [vara], ([[varaTy]], v_int_ty)) - let v_int32_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "int32" , None , Some "ToInt32", [vara], ([[varaTy]], v_int32_ty)) - let v_uint32_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "uint32" , None , Some "ToUInt32", [vara], ([[varaTy]], v_uint32_ty)) - let v_int64_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "int64" , None , Some "ToInt64", [vara], ([[varaTy]], v_int64_ty)) - let v_uint64_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "uint64" , None , Some "ToUInt64", [vara], ([[varaTy]], v_uint64_ty)) - let v_nativeint_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "nativeint" , None , Some "ToIntPtr", [vara], ([[varaTy]], v_nativeint_ty)) - let v_unativeint_checked_info = makeIntrinsicValRef(fslib_MFOperatorsChecked_nleref, "unativeint" , None , Some "ToUIntPtr", [vara], ([[varaTy]], v_unativeint_ty)) - - let v_byte_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "byte" , None , Some "ToByte", [vara], ([[varaTy]], v_byte_ty)) - let v_sbyte_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "sbyte" , None , Some "ToSByte", [vara], ([[varaTy]], v_sbyte_ty)) - let v_int16_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "int16" , None , Some "ToInt16", [vara], ([[varaTy]], v_int16_ty)) - let v_uint16_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "uint16" , None , Some "ToUInt16", [vara], ([[varaTy]], v_uint16_ty)) - let v_int32_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "int32" , None , Some "ToInt32", [vara], ([[varaTy]], v_int32_ty)) - let v_uint32_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "uint32" , None , Some "ToUInt32", [vara], ([[varaTy]], v_uint32_ty)) - let v_int64_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "int64" , None , Some "ToInt64", [vara], ([[varaTy]], v_int64_ty)) - let v_uint64_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "uint64" , None , Some "ToUInt64", [vara], ([[varaTy]], v_uint64_ty)) - let v_float32_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "float32" , None , Some "ToSingle", [vara], ([[varaTy]], v_float32_ty)) - let v_float_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "float" , None , Some "ToDouble", [vara], ([[varaTy]], v_float_ty)) - let v_nativeint_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "nativeint" , None , Some "ToIntPtr", [vara], ([[varaTy]], v_nativeint_ty)) - let v_unativeint_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "unativeint" , None , Some "ToUIntPtr", [vara], ([[varaTy]], v_unativeint_ty)) - - let v_char_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "char" , None , Some "ToChar", [vara], ([[varaTy]], v_char_ty)) - let v_enum_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "enum" , None , Some "ToEnum", [vara], ([[varaTy]], v_enum_ty)) - - let v_hash_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "hash" , None , Some "Hash" , [vara], ([[varaTy]], v_int_ty)) - let v_box_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "box" , None , Some "Box" , [vara], ([[varaTy]], v_obj_ty_with_null)) - let v_isnull_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "isNull" , None , Some "IsNull" , [vara], ([[varaTy]], v_bool_ty)) - let v_raise_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "raise" , None , Some "Raise" , [vara], ([[mkSysNonGenericTy sys "Exception"]], varaTy)) - let v_failwith_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "failwith" , None , Some "FailWith" , [vara], ([[v_string_ty]], varaTy)) - let v_invalid_arg_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "invalidArg" , None , Some "InvalidArg" , [vara], ([[v_string_ty]; [v_string_ty]], varaTy)) - let v_null_arg_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "nullArg" , None , Some "NullArg" , [vara], ([[v_string_ty]], varaTy)) - let v_invalid_op_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "invalidOp" , None , Some "InvalidOp" , [vara], ([[v_string_ty]], varaTy)) - let v_failwithf_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "failwithf" , None , Some "PrintFormatToStringThenFail" , [vara;varb], ([[mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty]], varaTy)) - - let v_reraise_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "reraise" , None , Some "Reraise", [vara], ([[v_unit_ty]], varaTy)) - let v_typeof_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "typeof" , None , Some "TypeOf" , [vara], ([], v_system_Type_ty)) - let v_methodhandleof_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "methodhandleof" , None , Some "MethodHandleOf", [vara;varb], ([[varaTy --> varbTy]], v_system_RuntimeMethodHandle_ty)) - let v_sizeof_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "sizeof" , None , Some "SizeOf" , [vara], ([], v_int_ty)) - let v_nameof_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "nameof" , None , Some "NameOf" , [vara], ([[varaTy]], v_string_ty)) - - let v_unchecked_defaultof_info = makeIntrinsicValRef(fslib_MFOperatorsUnchecked_nleref, "defaultof" , None , Some "DefaultOf", [vara], ([], varaTy)) - let v_typedefof_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "typedefof" , None , Some "TypeDefOf", [vara], ([], v_system_Type_ty)) - let v_range_op_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_Range" , None , None , [vara], ([[varaTy];[varaTy]], mkSeqTy varaTy)) - let v_range_step_op_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "op_RangeStep" , None , None , [vara;varb], ([[varaTy];[varbTy];[varaTy]], mkSeqTy varaTy)) - let v_range_int32_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeInt32" , None , None , [], ([[v_int_ty];[v_int_ty];[v_int_ty]], mkSeqTy v_int_ty)) - let v_range_int64_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeInt64" , None , None , [], ([[v_int64_ty];[v_int64_ty];[v_int64_ty]], mkSeqTy v_int64_ty)) - let v_range_uint64_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeUInt64" , None , None , [], ([[v_uint64_ty];[v_uint64_ty];[v_uint64_ty]], mkSeqTy v_uint64_ty)) - let v_range_uint32_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeUInt32" , None , None , [], ([[v_uint32_ty];[v_uint32_ty];[v_uint32_ty]], mkSeqTy v_uint32_ty)) - let v_range_nativeint_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeIntPtr" , None , None , [], ([[v_nativeint_ty];[v_nativeint_ty];[v_nativeint_ty]], mkSeqTy v_nativeint_ty)) - let v_range_unativeint_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeUIntPtr" , None , None , [], ([[v_unativeint_ty];[v_unativeint_ty];[v_unativeint_ty]], mkSeqTy v_unativeint_ty)) - let v_range_int16_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeInt16" , None , None , [], ([[v_int16_ty];[v_int16_ty];[v_int16_ty]], mkSeqTy v_int16_ty)) - let v_range_uint16_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeUInt16" , None , None , [], ([[v_uint16_ty];[v_uint16_ty];[v_uint16_ty]], mkSeqTy v_uint16_ty)) - let v_range_sbyte_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeSByte" , None , None , [], ([[v_sbyte_ty];[v_sbyte_ty];[v_sbyte_ty]], mkSeqTy v_sbyte_ty)) - let v_range_byte_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeByte" , None , None , [], ([[v_byte_ty];[v_byte_ty];[v_byte_ty]], mkSeqTy v_byte_ty)) - let v_range_char_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeChar" , None , None , [], ([[v_char_ty];[v_char_ty];[v_char_ty]], mkSeqTy v_char_ty)) - let v_range_generic_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeGeneric" , None , None , [vara], ([[varaTy];[varaTy]], mkSeqTy varaTy)) - let v_range_step_generic_op_info = makeIntrinsicValRef(fslib_MFOperatorIntrinsics_nleref, "RangeStepGeneric" , None , None , [vara;varb], ([[varaTy];[varbTy];[varaTy]], mkSeqTy varaTy)) - - let v_array_length_info = makeIntrinsicValRef(fslib_MFArrayModule_nleref, "length" , None , Some "Length" , [vara], ([[mkArrayType 1 varaTy]], v_int_ty)) - let v_array_get_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "GetArray" , None , None , [vara], ([[mkArrayType 1 varaTy]; [v_int_ty]], varaTy)) - let v_array2D_get_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "GetArray2D" , None , None , [vara], ([[mkArrayType 2 varaTy];[v_int_ty]; [v_int_ty]], varaTy)) - let v_array3D_get_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "GetArray3D" , None , None , [vara], ([[mkArrayType 3 varaTy];[v_int_ty]; [v_int_ty]; [v_int_ty]], varaTy)) - let v_array4D_get_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "GetArray4D" , None , None , [vara], ([[mkArrayType 4 varaTy];[v_int_ty]; [v_int_ty]; [v_int_ty]; [v_int_ty]], varaTy)) - let v_array_set_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "SetArray" , None , None , [vara], ([[mkArrayType 1 varaTy]; [v_int_ty]; [varaTy]], v_unit_ty)) - let v_array2D_set_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "SetArray2D" , None , None , [vara], ([[mkArrayType 2 varaTy];[v_int_ty]; [v_int_ty]; [varaTy]], v_unit_ty)) - let v_array3D_set_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "SetArray3D" , None , None , [vara], ([[mkArrayType 3 varaTy];[v_int_ty]; [v_int_ty]; [v_int_ty]; [varaTy]], v_unit_ty)) - let v_array4D_set_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "SetArray4D" , None , None , [vara], ([[mkArrayType 4 varaTy];[v_int_ty]; [v_int_ty]; [v_int_ty]; [v_int_ty]; [varaTy]], v_unit_ty)) - - let v_option_toNullable_info = makeIntrinsicValRef(fslib_MFOptionModule_nleref, "toNullable" , None , Some "ToNullable" , [vara], ([[mkOptionTy varaTy]], mkNullableTy varaTy)) - let v_option_defaultValue_info = makeIntrinsicValRef(fslib_MFOptionModule_nleref, "defaultValue" , None , Some "DefaultValue" , [vara], ([[varaTy]; [mkOptionTy varaTy]], varaTy)) - - let v_nativeptr_tobyref_info = makeIntrinsicValRef(fslib_MFNativePtrModule_nleref, "toByRef" , None , Some "ToByRefInlined", [vara], ([[mkNativePtrTy varaTy]], mkByrefTy varaTy)) - - let v_seq_collect_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "collect" , None , Some "Collect", [vara;varb;varc], ([[varaTy --> varbTy]; [mkSeqTy varaTy]], mkSeqTy varcTy)) - let v_seq_delay_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "delay" , None , Some "Delay" , [varb], ([[v_unit_ty --> mkSeqTy varbTy]], mkSeqTy varbTy)) - let v_seq_append_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "append" , None , Some "Append" , [varb], ([[mkSeqTy varbTy]; [mkSeqTy varbTy]], mkSeqTy varbTy)) - let v_seq_using_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateUsing" , None , None , [vara;varb;varc], ([[varaTy];[(varaTy --> varbTy)]], mkSeqTy varcTy)) - let v_seq_generated_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateWhile" , None , None , [varb], ([[v_unit_ty --> v_bool_ty]; [mkSeqTy varbTy]], mkSeqTy varbTy)) - let v_seq_finally_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateThenFinally" , None , None , [varb], ([[mkSeqTy varbTy]; [v_unit_ty --> v_unit_ty]], mkSeqTy varbTy)) - let v_seq_trywith_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateTryWith" , None , None , [varb], ([[mkSeqTy varbTy]; [mkNonGenericTy v_exn_tcr --> v_int32_ty]; [mkNonGenericTy v_exn_tcr --> mkSeqTy varbTy]], mkSeqTy varbTy)) - let v_seq_of_functions_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateFromFunctions" , None , None , [vara;varb], ([[v_unit_ty --> varaTy]; [varaTy --> v_bool_ty]; [varaTy --> varbTy]], mkSeqTy varbTy)) - let v_create_event_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "CreateEvent" , None , None , [vara;varb], ([[varaTy --> v_unit_ty]; [varaTy --> v_unit_ty]; [(v_obj_ty_with_null --> (varbTy --> v_unit_ty)) --> varaTy]], mkIEvent2Ty varaTy varbTy)) - let v_cgh__useResumableCode_info = makeIntrinsicValRef(fslib_MFStateMachineHelpers_nleref, "__useResumableCode" , None , None , [vara], ([[]], v_bool_ty)) - let v_cgh__debugPoint_info = makeIntrinsicValRef(fslib_MFStateMachineHelpers_nleref, "__debugPoint" , None , None , [vara], ([[v_int_ty]; [varaTy]], varaTy)) - let v_cgh__resumeAt_info = makeIntrinsicValRef(fslib_MFStateMachineHelpers_nleref, "__resumeAt" , None , None , [vara], ([[v_int_ty]; [varaTy]], varaTy)) - let v_cgh__stateMachine_info = makeIntrinsicValRef(fslib_MFStateMachineHelpers_nleref, "__stateMachine" , None , None , [vara; varb], ([[varaTy]], varbTy)) // inaccurate type but it doesn't matter for linking - let v_cgh__resumableEntry_info = makeIntrinsicValRef(fslib_MFStateMachineHelpers_nleref, "__resumableEntry" , None , None , [vara], ([[v_int_ty --> varaTy]; [v_unit_ty --> varaTy]], varaTy)) - let v_seq_to_array_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "toArray" , None , Some "ToArray", [varb], ([[mkSeqTy varbTy]], mkArrayType 1 varbTy)) - let v_seq_to_list_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "toList" , None , Some "ToList" , [varb], ([[mkSeqTy varbTy]], mkListTy varbTy)) - let v_seq_map_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "map" , None , Some "Map" , [vara;varb], ([[varaTy --> varbTy]; [mkSeqTy varaTy]], mkSeqTy varbTy)) - let v_seq_singleton_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "singleton" , None , Some "Singleton" , [vara], ([[varaTy]], mkSeqTy varaTy)) - let v_seq_empty_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "empty" , None , Some "Empty" , [vara], ([], mkSeqTy varaTy)) - let v_new_format_info = makeIntrinsicValRef(fslib_MFCore_nleref, ".ctor" , Some "PrintfFormat`5", None , [vara;varb;varc;vard;vare], ([[v_string_ty]], mkPrintfFormatTy varaTy varbTy varcTy vardTy vareTy)) - let v_sprintf_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "sprintf" , None , Some "PrintFormatToStringThen", [vara], ([[mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty]], varaTy)) - let v_lazy_force_info = makeIntrinsicValRef(fslib_MFLazyExtensions_nleref, "Force" , Some "Lazy`1" , None , [vara], ([[mkLazyTy varaTy]; []], varaTy)) - let v_lazy_create_info = makeIntrinsicValRef(fslib_MFLazyExtensions_nleref, "Create" , Some "Lazy`1" , None , [vara], ([[v_unit_ty --> varaTy]], mkLazyTy varaTy)) - - let v_seq_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "seq" , None , Some "CreateSequence" , [vara], ([[mkSeqTy varaTy]], mkSeqTy varaTy)) - let v_splice_expr_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "op_Splice" , None , None , [vara], ([[mkQuotedExprTy varaTy]], varaTy)) - let v_splice_raw_expr_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "op_SpliceUntyped" , None , None , [vara], ([[mkRawQuotedExprTy]], varaTy)) - let v_new_decimal_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "MakeDecimal" , None , None , [], ([[v_int_ty]; [v_int_ty]; [v_int_ty]; [v_bool_ty]; [v_byte_ty]], v_decimal_ty)) - let v_deserialize_quoted_FSharp_20_plus_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Deserialize" , Some "Expr" , None , [], ([[v_system_Type_ty ;mkListTy v_system_Type_ty ;mkListTy mkRawQuotedExprTy ; mkArrayType 1 v_byte_ty]], mkRawQuotedExprTy )) - let v_deserialize_quoted_FSharp_40_plus_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Deserialize40" , Some "Expr" , None , [], ([[v_system_Type_ty ;mkArrayType 1 v_system_Type_ty; mkArrayType 1 v_system_Type_ty; mkArrayType 1 mkRawQuotedExprTy; mkArrayType 1 v_byte_ty]], mkRawQuotedExprTy )) - let v_call_with_witnesses_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "CallWithWitnesses" , Some "Expr" , None , [], ([[v_system_Reflection_MethodInfo_ty; v_system_Reflection_MethodInfo_ty; mkListTy mkRawQuotedExprTy; mkListTy mkRawQuotedExprTy]], mkRawQuotedExprTy)) - let v_cast_quotation_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Cast" , Some "Expr" , None , [vara], ([[mkRawQuotedExprTy]], mkQuotedExprTy varaTy)) - let v_lift_value_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "Value" , Some "Expr" , None , [vara], ([[varaTy]], mkRawQuotedExprTy)) - let v_lift_value_with_name_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "ValueWithName" , Some "Expr" , None , [vara], ([[varaTy; v_string_ty]], mkRawQuotedExprTy)) - let v_lift_value_with_defn_info = makeIntrinsicValRef(fslib_MFQuotations_nleref, "WithValue" , Some "Expr" , None , [vara], ([[varaTy; mkQuotedExprTy varaTy]], mkQuotedExprTy varaTy)) - let v_query_value_info = makeIntrinsicValRef(fslib_MFExtraTopLevelOperators_nleref, "query" , None , None , [], ([], mkQueryBuilderTy) ) - let v_query_run_value_info = makeIntrinsicValRef(fslib_MFQueryRunExtensionsLowPriority_nleref, "Run" , Some "QueryBuilder" , None , [vara], ([[mkQueryBuilderTy];[mkQuotedExprTy varaTy]], varaTy) ) - let v_query_run_enumerable_info = makeIntrinsicValRef(fslib_MFQueryRunExtensionsHighPriority_nleref, "Run" , Some "QueryBuilder" , None , [vara], ([[mkQueryBuilderTy];[mkQuotedExprTy (mkQuerySourceTy varaTy (mkNonGenericTy v_tcref_System_Collections_IEnumerable)) ]], mkSeqTy varaTy) ) - let v_query_for_value_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "For" , Some "QueryBuilder" , None , [vara; vard; varb; vare], ([[mkQueryBuilderTy];[mkQuerySourceTy varaTy vardTy;varaTy --> mkQuerySourceTy varbTy vareTy]], mkQuerySourceTy varbTy vardTy) ) - let v_query_select_value_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "Select" , Some "QueryBuilder" , None , [vara; vare; varb], ([[mkQueryBuilderTy];[mkQuerySourceTy varaTy vareTy;varaTy --> varbTy]], mkQuerySourceTy varbTy vareTy) ) - let v_query_yield_value_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "Yield" , Some "QueryBuilder" , None , [vara; vare], ([[mkQueryBuilderTy];[varaTy]], mkQuerySourceTy varaTy vareTy) ) - let v_query_yield_from_value_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "YieldFrom" , Some "QueryBuilder" , None , [vara; vare], ([[mkQueryBuilderTy];[mkQuerySourceTy varaTy vareTy]], mkQuerySourceTy varaTy vareTy) ) - let v_query_source_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "Source" , Some "QueryBuilder" , None , [vara], ([[mkQueryBuilderTy];[mkSeqTy varaTy ]], mkQuerySourceTy varaTy (mkNonGenericTy v_tcref_System_Collections_IEnumerable)) ) - let v_query_source_as_enum_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "get_Source" , Some "QuerySource`2" , None , [vara; vare], ([[mkQuerySourceTy varaTy vareTy];[]], mkSeqTy varaTy) ) - let v_new_query_source_info = makeIntrinsicValRef(fslib_MFLinq_nleref, ".ctor" , Some "QuerySource`2" , None , [vara; vare], ([[mkSeqTy varaTy]], mkQuerySourceTy varaTy vareTy) ) - let v_query_zero_value_info = makeIntrinsicValRef(fslib_MFLinq_nleref, "Zero" , Some "QueryBuilder" , None , [vara; vare], ([[mkQueryBuilderTy];[]], mkQuerySourceTy varaTy vareTy) ) - let v_fail_init_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "FailInit" , None , None , [], ([[v_unit_ty]], v_unit_ty)) - let v_fail_static_init_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "FailStaticInit" , None , None , [], ([[v_unit_ty]], v_unit_ty)) - let v_check_this_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "CheckThis" , None , None , [vara], ([[varaTy]], varaTy)) - let v_quote_to_linq_lambda_info = makeIntrinsicValRef(fslib_MFLinqRuntimeHelpersQuotationConverter_nleref, "QuotationToLambdaExpression" , None , None , [vara], ([[mkQuotedExprTy varaTy]], mkLinqExpressionTy varaTy)) - - let tref_DebuggerNonUserCodeAttribute = findSysILTypeRef tname_DebuggerNonUserCodeAttribute - let v_DebuggerNonUserCodeAttribute_tcr = splitILTypeName tname_DebuggerNonUserCodeAttribute ||> findSysTyconRef - - let tref_DebuggableAttribute = findSysILTypeRef tname_DebuggableAttribute - let tref_CompilerGeneratedAttribute = findSysILTypeRef tname_CompilerGeneratedAttribute - let v_CompilerGeneratedAttribute_tcr = splitILTypeName tname_CompilerGeneratedAttribute ||> findSysTyconRef - let tref_InternalsVisibleToAttribute = findSysILTypeRef tname_InternalsVisibleToAttribute - - let debuggerNonUserCodeAttribute = mkILCustomAttribute (tref_DebuggerNonUserCodeAttribute, [], [], []) - let compilerGeneratedAttribute = mkILCustomAttribute (tref_CompilerGeneratedAttribute, [], [], []) - let generatedAttributes = if noDebugAttributes then [||] else [| compilerGeneratedAttribute; debuggerNonUserCodeAttribute |] - let compilerGlobalState = CompilerGlobalState() - - // Requests attributes to be added to compiler generated methods. - let addGeneratedAttrs (attrs: ILAttributes) = - if Array.isEmpty generatedAttributes then - attrs - else - match attrs.AsArray() with - | [||] -> mkILCustomAttrsFromArray generatedAttributes - | attrs -> mkILCustomAttrsFromArray (Array.append attrs generatedAttributes) - - let addValGeneratedAttrs (v: Val) m = - if not noDebugAttributes then - let attrs = [ - Attrib(v_CompilerGeneratedAttribute_tcr, ILAttrib compilerGeneratedAttribute.Method.MethodRef, [], [], false, None, m) - Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib debuggerNonUserCodeAttribute.Method.MethodRef, [], [], false, None, m) - Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib debuggerNonUserCodeAttribute.Method.MethodRef, [], [], true, None, m) - ] - - match v.Attribs with - | [] -> v.SetAttribs attrs - | _ -> v.SetAttribs (attrs @ v.Attribs) - - let addMethodGeneratedAttrs (mdef:ILMethodDef) = mdef.With(customAttrs = addGeneratedAttrs mdef.CustomAttrs) - - let addPropertyGeneratedAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addGeneratedAttrs pdef.CustomAttrs) - - let addFieldGeneratedAttrs (fdef:ILFieldDef) = fdef.With(customAttrs = addGeneratedAttrs fdef.CustomAttrs) - - let tref_DebuggerBrowsableAttribute n = + | Some ccu -> ccu.ILScopeRef, ccu + + let tref = mkILTyRef (scoref, nm) + let tcref = mkNonLocalTyconRef2 ccu (Array.ofList path) typeName + AttribInfo(tref, tcref) + + // Well known set of generated embeddable attribute names + static let isInEmbeddableKnownSet name = + match name with + | "System.Runtime.CompilerServices.IsReadOnlyAttribute" + | "System.Runtime.CompilerServices.IsUnmanagedAttribute" + | "System.Runtime.CompilerServices.NullableAttribute" + | "System.Runtime.CompilerServices.NullableContextAttribute" + | "System.Diagnostics.CodeAnalysis.MemberNotNullWhenAttribute" + | "System.Diagnostics.CodeAnalysis.DynamicDependencyAttribute" + | "System.Diagnostics.CodeAnalysis.DynamicallyAccessedMemberTypes" -> true + | _ -> false + + let findOrEmbedSysPublicType nm = + + assert (isInEmbeddableKnownSet nm) //Ensure that the named type is in known set of embedded types + + let sysAttrib = findPublicSysAttrib nm + + if sysAttrib.TyconRef.CanDeref then + sysAttrib + else + let attrRef = ILTypeRef.Create(ILScopeRef.Local, [], nm) + + let attrTycon = + Construct.NewTycon( + Some(CompPath(ILScopeRef.Local, SyntaxAccess.Internal, [])), + attrRef.Name, + range0, + taccessInternal, + taccessInternal, + TyparKind.Type, + LazyWithContext.NotLazy [], + FSharp.Compiler.Xml.XmlDoc.Empty, + false, + false, + false, + MaybeLazy.Strict(Construct.NewEmptyModuleOrNamespaceType ModuleOrType) + ) + + AttribInfo(attrRef, mkLocalTyconRef attrTycon) + + let mkSysNonGenericTy path n = mkNonGenericTy (findSysTyconRef path n) + + let tryMkSysNonGenericTy path n = + tryFindSysTyconRef path n |> Option.map mkNonGenericTy + + let sys = [ "System" ] + let sysCollections = [ "System"; "Collections" ] + let sysGenerics = [ "System"; "Collections"; "Generic" ] + let sysCompilerServices = [ "System"; "Runtime"; "CompilerServices" ] + + let lazy_tcr = findSysTyconRef sys "Lazy`1" + let v_fslib_IEvent2_tcr = mk_MFControl_tcref fslibCcu "IEvent`2" + let v_tcref_IObservable = findSysTyconRef sys "IObservable`1" + let v_tcref_IObserver = findSysTyconRef sys "IObserver`1" + let v_fslib_IDelegateEvent_tcr = mk_MFControl_tcref fslibCcu "IDelegateEvent`1" + + let v_option_tcr_nice = mk_MFCore_tcref fslibCcu "option`1" + let v_valueoption_tcr_nice = mk_MFCore_tcref fslibCcu "voption`1" + let v_list_tcr_canon = mk_MFCollections_tcref fslibCcu "List`1" + let v_list_tcr_nice = mk_MFCollections_tcref fslibCcu "list`1" + let v_lazy_tcr_nice = mk_MFControl_tcref fslibCcu "Lazy`1" + let v_seq_tcr = mk_MFCollections_tcref fslibCcu "seq`1" + let v_format_tcr = mk_MFCore_tcref fslibCcu "PrintfFormat`5" + let v_format4_tcr = mk_MFCore_tcref fslibCcu "PrintfFormat`4" + let v_date_tcr = findSysTyconRef sys "DateTime" + let v_IEnumerable_tcr = findSysTyconRef sysGenerics "IEnumerable`1" + let v_IEnumerator_tcr = findSysTyconRef sysGenerics "IEnumerator`1" + let v_System_Attribute_tcr = findSysTyconRef sys "Attribute" + let v_expr_tcr = mk_MFQuotations_tcref fslibCcu "Expr`1" + let v_raw_expr_tcr = mk_MFQuotations_tcref fslibCcu "Expr" + let v_query_builder_tcref = mk_MFLinq_tcref fslibCcu "QueryBuilder" + let v_querySource_tcr = mk_MFLinq_tcref fslibCcu "QuerySource`2" + + let v_linqExpression_tcr = + findSysTyconRef [ "System"; "Linq"; "Expressions" ] "Expression`1" + + let v_il_arr_tcr_map = + Array.init 32 (fun idx -> + let type_sig = + let rank = idx + 1 + + if rank = 1 then + "[]`1" + else + "[" + (String.replicate (rank - 1) ",") + "]`1" + + mk_MFCore_tcref fslibCcu type_sig) + + let v_byte_ty = mkNonGenericTy v_byte_tcr + let v_sbyte_ty = mkNonGenericTy v_sbyte_tcr + let v_int16_ty = mkNonGenericTy v_int16_tcr + let v_uint16_ty = mkNonGenericTy v_uint16_tcr + let v_int_ty = mkNonGenericTy v_int_tcr + let v_int32_ty = mkNonGenericTy v_int32_tcr + let v_uint32_ty = mkNonGenericTy v_uint32_tcr + let v_int64_ty = mkNonGenericTy v_int64_tcr + let v_uint64_ty = mkNonGenericTy v_uint64_tcr + let v_float32_ty = mkNonGenericTy v_float32_tcr + let v_float_ty = mkNonGenericTy v_float_tcr + let v_nativeint_ty = mkNonGenericTy v_nativeint_tcr + let v_unativeint_ty = mkNonGenericTy v_unativeint_tcr + + let v_enum_ty = mkNonGenericTy v_int_tcr + let v_bool_ty = mkNonGenericTy v_bool_tcr + let v_char_ty = mkNonGenericTy v_char_tcr + let v_obj_ty_without_null = mkNonGenericTyWithNullness v_obj_tcr v_knownWithoutNull + let v_obj_ty_ambivalent = mkNonGenericTyWithNullness v_obj_tcr KnownAmbivalentToNull + let v_obj_ty_with_null = mkNonGenericTyWithNullness v_obj_tcr v_knownWithNull + let v_IFormattable_tcref = findSysTyconRef sys "IFormattable" + let v_FormattableString_tcref = findSysTyconRef sys "FormattableString" + let v_IFormattable_ty = mkNonGenericTy v_IFormattable_tcref + let v_FormattableString_ty = mkNonGenericTy v_FormattableString_tcref + + let v_FormattableStringFactory_tcref = + findSysTyconRef sysCompilerServices "FormattableStringFactory" + + let v_FormattableStringFactory_ty = mkNonGenericTy v_FormattableStringFactory_tcref + let v_string_ty = mkNonGenericTy v_string_tcr + + let v_string_ty_ambivalent = + mkNonGenericTyWithNullness v_string_tcr KnownAmbivalentToNull + + let v_decimal_ty = mkSysNonGenericTy sys "Decimal" + let v_unit_ty = mkNonGenericTy v_unit_tcr_nice + let v_system_Type_ty = mkSysNonGenericTy sys "Type" + let v_Array_tcref = findSysTyconRef sys "Array" + + let v_system_Reflection_MethodInfo_ty = + mkSysNonGenericTy [ "System"; "Reflection" ] "MethodInfo" + + let v_nullable_tcr = findSysTyconRef sys "Nullable`1" + (* local helpers to build value infos *) + let mkNullableTy ty = + TType_app(v_nullable_tcr, [ ty ], v_knownWithoutNull) + + let mkByrefTy ty = + TType_app(v_byref_tcr, [ ty ], v_knownWithoutNull) + + let mkNativePtrTy ty = + TType_app(v_nativeptr_tcr, [ ty ], v_knownWithoutNull) + + let mkFunTy d r = TType_fun(d, r, v_knownWithoutNull) + let mkFunTyWithNullness d r nullness = TType_fun(d, r, nullness) + let (-->) d r = mkFunTy d r + let mkIteratedFunTy dl r = List.foldBack mkFunTy dl r + + let mkSmallRefTupledTy l = + match l with + | [] -> v_unit_ty + | [ h ] -> h + | tys -> mkRawRefTupleTy tys + + let mkForallTyIfNeeded d r = + match d with + | [] -> r + | tps -> TType_forall(tps, r) + + // A table of all intrinsics that the compiler cares about + let v_knownIntrinsics = + ConcurrentDictionary(HashIdentity.Structural) + + let makeIntrinsicValRefGeneral isKnown (enclosingEntity, logicalName, memberParentName, compiledNameOpt, typars, (argTys, retTy)) = + let ty = + mkForallTyIfNeeded typars (mkIteratedFunTy (List.map mkSmallRefTupledTy argTys) retTy) + + let isMember = Option.isSome memberParentName + let argCount = if isMember then List.sumBy List.length argTys else 0 + let linkageType = if isMember then Some ty else None + + let key = + ValLinkageFullKey( + { + MemberParentMangledName = memberParentName + MemberIsOverride = false + LogicalName = logicalName + TotalArgCount = argCount + }, + linkageType + ) + + let vref = IntrinsicValRef(enclosingEntity, logicalName, isMember, ty, key) + let compiledName = defaultArg compiledNameOpt logicalName + + let key = + (enclosingEntity.LastItemMangledName, memberParentName, compiledName, argCount) + + assert not (v_knownIntrinsics.ContainsKey(key)) + + if isKnown && not (v_knownIntrinsics.ContainsKey(key)) then + v_knownIntrinsics[key] <- ValRefForIntrinsic vref + + vref + + let makeIntrinsicValRef info = makeIntrinsicValRefGeneral true info + let makeOtherIntrinsicValRef info = makeIntrinsicValRefGeneral false info + + let v_IComparer_ty = mkSysNonGenericTy sysCollections "IComparer" + let v_IEqualityComparer_ty = mkSysNonGenericTy sysCollections "IEqualityComparer" + + let v_system_RuntimeMethodHandle_ty = mkSysNonGenericTy sys "RuntimeMethodHandle" + + let mk_unop_ty ty = [ [ ty ] ], ty + let mk_binop_ty ty = [ [ ty ]; [ ty ] ], ty + let mk_shiftop_ty ty = [ [ ty ]; [ v_int_ty ] ], ty + let mk_binop_ty3 ty1 ty2 ty3 = [ [ ty1 ]; [ ty2 ] ], ty3 + let mk_rel_sig ty = [ [ ty ]; [ ty ] ], v_bool_ty + let mk_compare_sig ty = [ [ ty ]; [ ty ] ], v_int_ty + let mk_hash_sig ty = [ [ ty ] ], v_int_ty + + let mk_compare_withc_sig ty = + [ [ v_IComparer_ty ]; [ ty ]; [ ty ] ], v_int_ty + + let mk_equality_withc_sig ty = + [ [ v_IEqualityComparer_ty ]; [ ty ]; [ ty ] ], v_bool_ty + + let mk_hash_withc_sig ty = + [ [ v_IEqualityComparer_ty ]; [ ty ] ], v_int_ty + + let mkListTy ty = + TType_app(v_list_tcr_nice, [ ty ], v_knownWithoutNull) + + let mkSeqTy ty1 = + TType_app(v_seq_tcr, [ ty1 ], v_knownWithoutNull) + + let mkIEvent2Ty ty1 ty2 = + TType_app(v_fslib_IEvent2_tcr, [ ty1; ty2 ], v_knownWithoutNull) + + let mkRefCellTy ty = + TType_app(v_refcell_tcr_canon, [ ty ], v_knownWithoutNull) + + let mkOptionTy ty = + TType_app(v_option_tcr_nice, [ ty ], v_knownWithoutNull) + + let mkQuerySourceTy ty1 ty2 = + TType_app(v_querySource_tcr, [ ty1; ty2 ], v_knownWithoutNull) + + let v_tcref_System_Collections_IEnumerable = + findSysTyconRef sysCollections "IEnumerable" + + let mkArrayType rank (ty: TType) : TType = + assert (rank >= 1 && rank <= 32) + TType_app(v_il_arr_tcr_map[rank - 1], [ ty ], v_knownWithoutNull) + + let mkLazyTy ty = + TType_app(lazy_tcr, [ ty ], v_knownWithoutNull) + + let mkPrintfFormatTy aty bty cty dty ety = + TType_app(v_format_tcr, [ aty; bty; cty; dty; ety ], v_knownWithoutNull) + + let mk_format4_ty aty bty cty dty = + TType_app(v_format4_tcr, [ aty; bty; cty; dty ], v_knownWithoutNull) + + let mkQuotedExprTy aty = + TType_app(v_expr_tcr, [ aty ], v_knownWithoutNull) + + let mkRawQuotedExprTy = TType_app(v_raw_expr_tcr, [], v_knownWithoutNull) + + let mkQueryBuilderTy = TType_app(v_query_builder_tcref, [], v_knownWithoutNull) + + let mkLinqExpressionTy aty = + TType_app(v_linqExpression_tcr, [ aty ], v_knownWithoutNull) + + let v_cons_ucref = mkUnionCaseRef v_list_tcr_canon "op_ColonColon" + + let v_nil_ucref = mkUnionCaseRef v_list_tcr_canon "op_Nil" + + let fslib_MF_nleref = mkNonLocalEntityRef fslibCcu RootPathArray + let fslib_MFCore_nleref = mkNonLocalEntityRef fslibCcu CorePathArray + let fslib_MFLinq_nleref = mkNonLocalEntityRef fslibCcu LinqPathArray + let fslib_MFCollections_nleref = mkNonLocalEntityRef fslibCcu CollectionsPathArray + + let fslib_MFCompilerServices_nleref = + mkNonLocalEntityRef fslibCcu CompilerServicesPath + + let fslib_MFLinqRuntimeHelpers_nleref = + mkNonLocalEntityRef fslibCcu LinqRuntimeHelpersPath + + let fslib_MFControl_nleref = mkNonLocalEntityRef fslibCcu ControlPathArray + let fslib_MFNativeInterop_nleref = mkNonLocalEntityRef fslibCcu NativeInteropPath + + let fslib_MFLanguagePrimitives_nleref = + mkNestedNonLocalEntityRef fslib_MFCore_nleref "LanguagePrimitives" + + let fslib_MFIntrinsicOperators_nleref = + mkNestedNonLocalEntityRef fslib_MFLanguagePrimitives_nleref "IntrinsicOperators" + + let fslib_MFIntrinsicFunctions_nleref = + mkNestedNonLocalEntityRef fslib_MFLanguagePrimitives_nleref "IntrinsicFunctions" + + let fslib_MFHashCompare_nleref = + mkNestedNonLocalEntityRef fslib_MFLanguagePrimitives_nleref "HashCompare" + + let fslib_MFOperators_nleref = + mkNestedNonLocalEntityRef fslib_MFCore_nleref "Operators" + + let fslib_MFByRefKinds_nleref = + mkNestedNonLocalEntityRef fslib_MFCore_nleref "ByRefKinds" + + let fslib_MFOperatorIntrinsics_nleref = + mkNestedNonLocalEntityRef fslib_MFOperators_nleref "OperatorIntrinsics" + + let fslib_MFOperatorsUnchecked_nleref = + mkNestedNonLocalEntityRef fslib_MFOperators_nleref "Unchecked" + + let fslib_MFOperatorsChecked_nleref = + mkNestedNonLocalEntityRef fslib_MFOperators_nleref "Checked" + + let fslib_MFExtraTopLevelOperators_nleref = + mkNestedNonLocalEntityRef fslib_MFCore_nleref "ExtraTopLevelOperators" + + let fslib_MFNullableOperators_nleref = + mkNestedNonLocalEntityRef fslib_MFLinq_nleref "NullableOperators" + + let fslib_MFQueryRunExtensions_nleref = + mkNestedNonLocalEntityRef fslib_MFLinq_nleref "QueryRunExtensions" + + let fslib_MFQueryRunExtensionsLowPriority_nleref = + mkNestedNonLocalEntityRef fslib_MFQueryRunExtensions_nleref "LowPriority" + + let fslib_MFQueryRunExtensionsHighPriority_nleref = + mkNestedNonLocalEntityRef fslib_MFQueryRunExtensions_nleref "HighPriority" + + let fslib_MFPrintfModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCore_nleref "PrintfModule" + + let fslib_MFSeqModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "SeqModule" + + let fslib_MFListModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "ListModule" + + let fslib_MFArrayModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "ArrayModule" + + let fslib_MFArray2DModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "Array2DModule" + + let fslib_MFArray3DModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "Array3DModule" + + let fslib_MFArray4DModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "Array4DModule" + + let fslib_MFSetModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "SetModule" + + let fslib_MFMapModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "MapModule" + + let fslib_MFStringModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCollections_nleref "StringModule" + + let fslib_MFNativePtrModule_nleref = + mkNestedNonLocalEntityRef fslib_MFNativeInterop_nleref "NativePtrModule" + + let fslib_MFOptionModule_nleref = + mkNestedNonLocalEntityRef fslib_MFCore_nleref "OptionModule" + + let fslib_MFStateMachineHelpers_nleref = + mkNestedNonLocalEntityRef fslib_MFCompilerServices_nleref "StateMachineHelpers" + + let fslib_MFRuntimeHelpers_nleref = + mkNestedNonLocalEntityRef fslib_MFCompilerServices_nleref "RuntimeHelpers" + + let fslib_MFQuotations_nleref = + mkNestedNonLocalEntityRef fslib_MF_nleref "Quotations" + + let fslib_MFLinqRuntimeHelpersQuotationConverter_nleref = + mkNestedNonLocalEntityRef fslib_MFLinqRuntimeHelpers_nleref "LeafExpressionConverter" + + let fslib_MFLazyExtensions_nleref = + mkNestedNonLocalEntityRef fslib_MFControl_nleref "LazyExtensions" + + let v_ref_tuple1_tcr = findSysTyconRef sys "Tuple`1" + let v_ref_tuple2_tcr = findSysTyconRef sys "Tuple`2" + let v_ref_tuple3_tcr = findSysTyconRef sys "Tuple`3" + let v_ref_tuple4_tcr = findSysTyconRef sys "Tuple`4" + let v_ref_tuple5_tcr = findSysTyconRef sys "Tuple`5" + let v_ref_tuple6_tcr = findSysTyconRef sys "Tuple`6" + let v_ref_tuple7_tcr = findSysTyconRef sys "Tuple`7" + let v_ref_tuple8_tcr = findSysTyconRef sys "Tuple`8" + let v_struct_tuple1_tcr = findSysTyconRef sys "ValueTuple`1" + let v_struct_tuple2_tcr = findSysTyconRef sys "ValueTuple`2" + let v_struct_tuple3_tcr = findSysTyconRef sys "ValueTuple`3" + let v_struct_tuple4_tcr = findSysTyconRef sys "ValueTuple`4" + let v_struct_tuple5_tcr = findSysTyconRef sys "ValueTuple`5" + let v_struct_tuple6_tcr = findSysTyconRef sys "ValueTuple`6" + let v_struct_tuple7_tcr = findSysTyconRef sys "ValueTuple`7" + let v_struct_tuple8_tcr = findSysTyconRef sys "ValueTuple`8" + + let v_choice2_tcr = mk_MFCore_tcref fslibCcu "Choice`2" + let v_choice3_tcr = mk_MFCore_tcref fslibCcu "Choice`3" + let v_choice4_tcr = mk_MFCore_tcref fslibCcu "Choice`4" + let v_choice5_tcr = mk_MFCore_tcref fslibCcu "Choice`5" + let v_choice6_tcr = mk_MFCore_tcref fslibCcu "Choice`6" + let v_choice7_tcr = mk_MFCore_tcref fslibCcu "Choice`7" + + let tyconRefEq x y = + primEntityRefEq compilingFSharpCore fslibCcu x y + + let v_suppressed_types = + [ + mk_MFCore_tcref fslibCcu "Option`1" + mk_MFCore_tcref fslibCcu "Ref`1" + mk_MFCore_tcref fslibCcu "FSharpTypeFunc" + mk_MFCore_tcref fslibCcu "FSharpFunc`2" + mk_MFCore_tcref fslibCcu "Unit" + ] + + let v_knownFSharpCoreModules = + dict + [ + for nleref in + [ + fslib_MFLanguagePrimitives_nleref + fslib_MFIntrinsicOperators_nleref + fslib_MFIntrinsicFunctions_nleref + fslib_MFHashCompare_nleref + fslib_MFOperators_nleref + fslib_MFOperatorIntrinsics_nleref + fslib_MFOperatorsUnchecked_nleref + fslib_MFOperatorsChecked_nleref + fslib_MFExtraTopLevelOperators_nleref + fslib_MFNullableOperators_nleref + fslib_MFQueryRunExtensions_nleref + fslib_MFQueryRunExtensionsLowPriority_nleref + fslib_MFQueryRunExtensionsHighPriority_nleref + + fslib_MFPrintfModule_nleref + fslib_MFSeqModule_nleref + fslib_MFListModule_nleref + fslib_MFArrayModule_nleref + fslib_MFArray2DModule_nleref + fslib_MFArray3DModule_nleref + fslib_MFArray4DModule_nleref + fslib_MFSetModule_nleref + fslib_MFMapModule_nleref + fslib_MFStringModule_nleref + fslib_MFNativePtrModule_nleref + fslib_MFOptionModule_nleref + fslib_MFStateMachineHelpers_nleref + fslib_MFRuntimeHelpers_nleref + ] do + + yield nleref.LastItemMangledName, ERefNonLocal nleref + ] + + let tryDecodeTupleTy tupInfo l = + match l with + | [ t1; t2; t3; t4; t5; t6; t7; markerTy ] -> + match markerTy with + | TType_app(tcref, [ t8 ], _) when tyconRefEq tcref v_ref_tuple1_tcr -> + mkRawRefTupleTy [ t1; t2; t3; t4; t5; t6; t7; t8 ] |> Some + | TType_app(tcref, [ t8 ], _) when tyconRefEq tcref v_struct_tuple1_tcr -> + mkRawStructTupleTy [ t1; t2; t3; t4; t5; t6; t7; t8 ] |> Some + | TType_tuple(_structness2, t8plus) -> TType_tuple(tupInfo, [ t1; t2; t3; t4; t5; t6; t7 ] @ t8plus) |> Some + | _ -> None + | [] -> None + | [ _ ] -> None + | _ -> TType_tuple(tupInfo, l) |> Some + + let decodeTupleTyAndNullness tupInfo tinst _nullness = + match tryDecodeTupleTy tupInfo tinst with + | Some ty -> ty + | None -> failwith "couldn't decode tuple ty" + + let decodeTupleTyAndNullnessIfPossible tcref tupInfo tinst nullness = + match tryDecodeTupleTy tupInfo tinst with + | Some ty -> ty + | None -> TType_app(tcref, tinst, nullness) + + let decodeTupleTy tupInfo tinst = + decodeTupleTyAndNullness tupInfo tinst v_knownWithoutNull + + let mk_MFCore_attrib nm : BuiltinAttribInfo = + AttribInfo(mkILTyRef (ilg.fsharpCoreAssemblyScopeRef, Core + "." + nm), mk_MFCore_tcref fslibCcu nm) + + let mk_MFCompilerServices_attrib nm : BuiltinAttribInfo = + AttribInfo(mkILTyRef (ilg.fsharpCoreAssemblyScopeRef, Core + "." + nm), mk_MFCompilerServices_tcref fslibCcu nm) + + let mkSourceDoc fileName = + ILSourceDocument.Create(language = None, vendor = None, documentType = None, file = fileName) + + let compute i = + let path = fileOfFileIndex i + + let fullPath = + FileSystem.GetFullFilePathInDirectoryShim directoryToResolveRelativePaths path + + mkSourceDoc fullPath + + // Build the memoization table for files + let v_memoize_file = + MemoizationTable(compute, keyComparer = HashIdentity.Structural) + + let v_and_info = + makeIntrinsicValRef (fslib_MFIntrinsicOperators_nleref, CompileOpName "&", None, None, [], mk_rel_sig v_bool_ty) + + let v_addrof_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicOperators_nleref, + CompileOpName "~&", + None, + None, + [ vara ], + ([ [ varaTy ] ], mkByrefTy varaTy) + ) + + let v_addrof2_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicOperators_nleref, + CompileOpName "~&&", + None, + None, + [ vara ], + ([ [ varaTy ] ], mkNativePtrTy varaTy) + ) + + let v_and2_info = + makeIntrinsicValRef (fslib_MFIntrinsicOperators_nleref, CompileOpName "&&", None, None, [], mk_rel_sig v_bool_ty) + + let v_or_info = + makeIntrinsicValRef (fslib_MFIntrinsicOperators_nleref, "or", None, Some "Or", [], mk_rel_sig v_bool_ty) + + let v_or2_info = + makeIntrinsicValRef (fslib_MFIntrinsicOperators_nleref, CompileOpName "||", None, None, [], mk_rel_sig v_bool_ty) + + let v_compare_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "compare", None, Some "Compare", [ vara ], mk_compare_sig varaTy) + + let v_equals_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, CompileOpName "=", None, None, [ vara ], mk_rel_sig varaTy) + + let v_equals_nullable_operator_info = + makeIntrinsicValRef ( + fslib_MFNullableOperators_nleref, + CompileOpName "=?", + None, + None, + [ vara ], + ([ [ varaTy ]; [ mkNullableTy varaTy ] ], v_bool_ty) + ) + + let v_nullable_equals_operator_info = + makeIntrinsicValRef ( + fslib_MFNullableOperators_nleref, + CompileOpName "?=", + None, + None, + [ vara ], + ([ [ mkNullableTy varaTy ]; [ varaTy ] ], v_bool_ty) + ) + + let v_nullable_equals_nullable_operator_info = + makeIntrinsicValRef ( + fslib_MFNullableOperators_nleref, + CompileOpName "?=?", + None, + None, + [ vara ], + ([ [ mkNullableTy varaTy ]; [ mkNullableTy varaTy ] ], v_bool_ty) + ) + + let v_not_equals_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, CompileOpName "<>", None, None, [ vara ], mk_rel_sig varaTy) + + let v_less_than_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, CompileOpName "<", None, None, [ vara ], mk_rel_sig varaTy) + + let v_less_than_or_equals_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, CompileOpName "<=", None, None, [ vara ], mk_rel_sig varaTy) + + let v_greater_than_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, CompileOpName ">", None, None, [ vara ], mk_rel_sig varaTy) + + let v_greater_than_or_equals_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, CompileOpName ">=", None, None, [ vara ], mk_rel_sig varaTy) + + let v_enumOfValue_info = + makeIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "EnumOfValue", None, None, [ vara; varb ], ([ [ varaTy ] ], varbTy)) + + let v_generic_comparison_withc_outer_info = + makeIntrinsicValRef ( + fslib_MFLanguagePrimitives_nleref, + "GenericComparisonWithComparer", + None, + None, + [ vara ], + mk_compare_withc_sig varaTy + ) + + let v_generic_hash_withc_tuple2_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastHashTuple2", + None, + None, + [ vara; varb ], + mk_hash_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy ]) + ) + + let v_generic_hash_withc_tuple3_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastHashTuple3", + None, + None, + [ vara; varb; varc ], + mk_hash_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy ]) + ) + + let v_generic_hash_withc_tuple4_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastHashTuple4", + None, + None, + [ vara; varb; varc; vard ], + mk_hash_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy; vardTy ]) + ) + + let v_generic_hash_withc_tuple5_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastHashTuple5", + None, + None, + [ vara; varb; varc; vard; vare ], + mk_hash_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy; vardTy; vareTy ]) + ) + + let v_generic_equals_withc_tuple2_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastEqualsTuple2", + None, + None, + [ vara; varb ], + mk_equality_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy ]) + ) + + let v_generic_equals_withc_tuple3_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastEqualsTuple3", + None, + None, + [ vara; varb; varc ], + mk_equality_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy ]) + ) + + let v_generic_equals_withc_tuple4_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastEqualsTuple4", + None, + None, + [ vara; varb; varc; vard ], + mk_equality_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy; vardTy ]) + ) + + let v_generic_equals_withc_tuple5_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastEqualsTuple5", + None, + None, + [ vara; varb; varc; vard; vare ], + mk_equality_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy; vardTy; vareTy ]) + ) + + let v_generic_compare_withc_tuple2_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastCompareTuple2", + None, + None, + [ vara; varb ], + mk_compare_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy ]) + ) + + let v_generic_compare_withc_tuple3_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastCompareTuple3", + None, + None, + [ vara; varb; varc ], + mk_compare_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy ]) + ) + + let v_generic_compare_withc_tuple4_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastCompareTuple4", + None, + None, + [ vara; varb; varc; vard ], + mk_compare_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy; vardTy ]) + ) + + let v_generic_compare_withc_tuple5_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "FastCompareTuple5", + None, + None, + [ vara; varb; varc; vard; vare ], + mk_compare_withc_sig (decodeTupleTy tupInfoRef [ varaTy; varbTy; varcTy; vardTy; vareTy ]) + ) + + let v_generic_equality_er_outer_info = + makeIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericEqualityER", None, None, [ vara ], mk_rel_sig varaTy) + + let v_get_generic_comparer_info = + makeIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericComparer", None, None, [], ([], v_IComparer_ty)) + + let v_get_generic_er_equality_comparer_info = + makeIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericEqualityERComparer", None, None, [], ([], v_IEqualityComparer_ty)) + + let v_get_generic_per_equality_comparer_info = + makeIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericEqualityComparer", None, None, [], ([], v_IEqualityComparer_ty)) + + let v_generic_equality_withc_outer_info = + makeIntrinsicValRef ( + fslib_MFLanguagePrimitives_nleref, + "GenericEqualityWithComparer", + None, + None, + [ vara ], + mk_equality_withc_sig varaTy + ) + + let v_generic_hash_withc_outer_info = + makeIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericHashWithComparer", None, None, [ vara ], mk_hash_withc_sig varaTy) + + let v_generic_equality_er_inner_info = + makeIntrinsicValRef (fslib_MFHashCompare_nleref, "GenericEqualityERIntrinsic", None, None, [ vara ], mk_rel_sig varaTy) + + let v_generic_equality_per_inner_info = + makeIntrinsicValRef (fslib_MFHashCompare_nleref, "GenericEqualityIntrinsic", None, None, [ vara ], mk_rel_sig varaTy) + + let v_generic_equality_withc_inner_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "GenericEqualityWithComparerIntrinsic", + None, + None, + [ vara ], + mk_equality_withc_sig varaTy + ) + + let v_generic_comparison_inner_info = + makeIntrinsicValRef (fslib_MFHashCompare_nleref, "GenericComparisonIntrinsic", None, None, [ vara ], mk_compare_sig varaTy) + + let v_generic_comparison_withc_inner_info = + makeIntrinsicValRef ( + fslib_MFHashCompare_nleref, + "GenericComparisonWithComparerIntrinsic", + None, + None, + [ vara ], + mk_compare_withc_sig varaTy + ) + + let v_generic_hash_inner_info = + makeIntrinsicValRef (fslib_MFHashCompare_nleref, "GenericHashIntrinsic", None, None, [ vara ], mk_hash_sig varaTy) + + let v_generic_hash_withc_inner_info = + makeIntrinsicValRef (fslib_MFHashCompare_nleref, "GenericHashWithComparerIntrinsic", None, None, [ vara ], mk_hash_withc_sig varaTy) + + let v_create_instance_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "CreateInstance", None, None, [ vara ], ([ [ v_unit_ty ] ], varaTy)) + + let v_unbox_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "UnboxGeneric", None, None, [ vara ], ([ [ v_obj_ty_with_null ] ], varaTy)) + + let v_unbox_fast_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "UnboxFast", None, None, [ vara ], ([ [ v_obj_ty_with_null ] ], varaTy)) + + let v_istype_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "TypeTestGeneric", + None, + None, + [ vara ], + ([ [ v_obj_ty_with_null ] ], v_bool_ty) + ) + + let v_istype_fast_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "TypeTestFast", + None, + None, + [ vara ], + ([ [ v_obj_ty_with_null ] ], v_bool_ty) + ) + + let v_dispose_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "Dispose", None, None, [ vara ], ([ [ varaTy ] ], v_unit_ty)) + + let v_getstring_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "GetString", None, None, [], ([ [ v_string_ty ]; [ v_int_ty ] ], v_char_ty)) + + let v_reference_equality_inner_info = + makeIntrinsicValRef (fslib_MFHashCompare_nleref, "PhysicalEqualityIntrinsic", None, None, [ vara ], mk_rel_sig varaTy) + + let v_piperight_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_PipeRight", + None, + None, + [ vara; varb ], + ([ [ varaTy ]; [ varaTy --> varbTy ] ], varbTy) + ) + + let v_piperight2_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_PipeRight2", + None, + None, + [ vara; varb; varc ], + ([ [ varaTy; varbTy ]; [ varaTy --> (varbTy --> varcTy) ] ], varcTy) + ) + + let v_piperight3_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_PipeRight3", + None, + None, + [ vara; varb; varc; vard ], + ([ [ varaTy; varbTy; varcTy ]; [ varaTy --> (varbTy --> (varcTy --> vardTy)) ] ], vardTy) + ) + + let v_bitwise_or_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_BitwiseOr", None, None, [ vara ], mk_binop_ty varaTy) + + let v_bitwise_and_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_BitwiseAnd", None, None, [ vara ], mk_binop_ty varaTy) + + let v_bitwise_xor_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_ExclusiveOr", None, None, [ vara ], mk_binop_ty varaTy) + + let v_bitwise_unary_not_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_LogicalNot", None, None, [ vara ], mk_unop_ty varaTy) + + let v_bitwise_shift_left_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_LeftShift", None, None, [ vara ], mk_shiftop_ty varaTy) + + let v_bitwise_shift_right_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_RightShift", None, None, [ vara ], mk_shiftop_ty varaTy) + + let v_exponentiation_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_Exponentiation", + None, + None, + [ vara; varb ], + ([ [ varaTy ]; [ varbTy ] ], varaTy) + ) + + let v_unchecked_addition_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_Addition", None, None, [ vara; varb; varc ], mk_binop_ty3 varaTy varbTy varcTy) + + let v_unchecked_subtraction_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_Subtraction", + None, + None, + [ vara; varb; varc ], + mk_binop_ty3 varaTy varbTy varcTy + ) + + let v_unchecked_multiply_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_Multiply", None, None, [ vara; varb; varc ], mk_binop_ty3 varaTy varbTy varcTy) + + let v_unchecked_division_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_Division", None, None, [ vara; varb; varc ], mk_binop_ty3 varaTy varbTy varcTy) + + let v_unchecked_modulus_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_Modulus", None, None, [ vara; varb; varc ], mk_binop_ty3 varaTy varbTy varcTy) + + let v_unchecked_unary_plus_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_UnaryPlus", None, None, [ vara ], mk_unop_ty varaTy) + + let v_unchecked_unary_minus_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_UnaryNegation", None, None, [ vara ], mk_unop_ty varaTy) + + let v_unchecked_unary_not_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "not", None, Some "Not", [], mk_unop_ty v_bool_ty) + + let v_refcell_deref_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_Dereference", None, None, [ vara ], ([ [ mkRefCellTy varaTy ] ], varaTy)) + + let v_refcell_assign_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_ColonEquals", + None, + None, + [ vara ], + ([ [ mkRefCellTy varaTy ]; [ varaTy ] ], v_unit_ty) + ) + + let v_refcell_incr_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "incr", None, Some "Increment", [], ([ [ mkRefCellTy v_int_ty ] ], v_unit_ty)) + + let v_refcell_decr_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "decr", None, Some "Decrement", [], ([ [ mkRefCellTy v_int_ty ] ], v_unit_ty)) + + let v_checked_addition_info = + makeIntrinsicValRef ( + fslib_MFOperatorsChecked_nleref, + "op_Addition", + None, + None, + [ vara; varb; varc ], + mk_binop_ty3 varaTy varbTy varcTy + ) + + let v_checked_subtraction_info = + makeIntrinsicValRef ( + fslib_MFOperatorsChecked_nleref, + "op_Subtraction", + None, + None, + [ vara; varb; varc ], + mk_binop_ty3 varaTy varbTy varcTy + ) + + let v_checked_multiply_info = + makeIntrinsicValRef ( + fslib_MFOperatorsChecked_nleref, + "op_Multiply", + None, + None, + [ vara; varb; varc ], + mk_binop_ty3 varaTy varbTy varcTy + ) + + let v_checked_unary_minus_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "op_UnaryNegation", None, None, [ vara ], mk_unop_ty varaTy) + + let v_byte_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "byte", None, Some "ToByte", [ vara ], ([ [ varaTy ] ], v_byte_ty)) + + let v_sbyte_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "sbyte", None, Some "ToSByte", [ vara ], ([ [ varaTy ] ], v_sbyte_ty)) + + let v_int16_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "int16", None, Some "ToInt16", [ vara ], ([ [ varaTy ] ], v_int16_ty)) + + let v_uint16_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "uint16", None, Some "ToUInt16", [ vara ], ([ [ varaTy ] ], v_uint16_ty)) + + let v_int_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "int", None, Some "ToInt", [ vara ], ([ [ varaTy ] ], v_int_ty)) + + let v_int32_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "int32", None, Some "ToInt32", [ vara ], ([ [ varaTy ] ], v_int32_ty)) + + let v_uint32_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "uint32", None, Some "ToUInt32", [ vara ], ([ [ varaTy ] ], v_uint32_ty)) + + let v_int64_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "int64", None, Some "ToInt64", [ vara ], ([ [ varaTy ] ], v_int64_ty)) + + let v_uint64_checked_info = + makeIntrinsicValRef (fslib_MFOperatorsChecked_nleref, "uint64", None, Some "ToUInt64", [ vara ], ([ [ varaTy ] ], v_uint64_ty)) + + let v_nativeint_checked_info = + makeIntrinsicValRef ( + fslib_MFOperatorsChecked_nleref, + "nativeint", + None, + Some "ToIntPtr", + [ vara ], + ([ [ varaTy ] ], v_nativeint_ty) + ) + + let v_unativeint_checked_info = + makeIntrinsicValRef ( + fslib_MFOperatorsChecked_nleref, + "unativeint", + None, + Some "ToUIntPtr", + [ vara ], + ([ [ varaTy ] ], v_unativeint_ty) + ) + + let v_byte_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "byte", None, Some "ToByte", [ vara ], ([ [ varaTy ] ], v_byte_ty)) + + let v_sbyte_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "sbyte", None, Some "ToSByte", [ vara ], ([ [ varaTy ] ], v_sbyte_ty)) + + let v_int16_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "int16", None, Some "ToInt16", [ vara ], ([ [ varaTy ] ], v_int16_ty)) + + let v_uint16_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "uint16", None, Some "ToUInt16", [ vara ], ([ [ varaTy ] ], v_uint16_ty)) + + let v_int32_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "int32", None, Some "ToInt32", [ vara ], ([ [ varaTy ] ], v_int32_ty)) + + let v_uint32_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "uint32", None, Some "ToUInt32", [ vara ], ([ [ varaTy ] ], v_uint32_ty)) + + let v_int64_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "int64", None, Some "ToInt64", [ vara ], ([ [ varaTy ] ], v_int64_ty)) + + let v_uint64_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "uint64", None, Some "ToUInt64", [ vara ], ([ [ varaTy ] ], v_uint64_ty)) + + let v_float32_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "float32", None, Some "ToSingle", [ vara ], ([ [ varaTy ] ], v_float32_ty)) + + let v_float_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "float", None, Some "ToDouble", [ vara ], ([ [ varaTy ] ], v_float_ty)) + + let v_nativeint_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "nativeint", None, Some "ToIntPtr", [ vara ], ([ [ varaTy ] ], v_nativeint_ty)) + + let v_unativeint_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "unativeint", None, Some "ToUIntPtr", [ vara ], ([ [ varaTy ] ], v_unativeint_ty)) + + let v_char_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "char", None, Some "ToChar", [ vara ], ([ [ varaTy ] ], v_char_ty)) + + let v_enum_operator_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "enum", None, Some "ToEnum", [ vara ], ([ [ varaTy ] ], v_enum_ty)) + + let v_hash_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "hash", None, Some "Hash", [ vara ], ([ [ varaTy ] ], v_int_ty)) + + let v_box_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "box", None, Some "Box", [ vara ], ([ [ varaTy ] ], v_obj_ty_with_null)) + + let v_isnull_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "isNull", None, Some "IsNull", [ vara ], ([ [ varaTy ] ], v_bool_ty)) + + let v_raise_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "raise", + None, + Some "Raise", + [ vara ], + ([ [ mkSysNonGenericTy sys "Exception" ] ], varaTy) + ) + + let v_failwith_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "failwith", None, Some "FailWith", [ vara ], ([ [ v_string_ty ] ], varaTy)) + + let v_invalid_arg_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "invalidArg", + None, + Some "InvalidArg", + [ vara ], + ([ [ v_string_ty ]; [ v_string_ty ] ], varaTy) + ) + + let v_null_arg_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "nullArg", None, Some "NullArg", [ vara ], ([ [ v_string_ty ] ], varaTy)) + + let v_invalid_op_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "invalidOp", None, Some "InvalidOp", [ vara ], ([ [ v_string_ty ] ], varaTy)) + + let v_failwithf_info = + makeIntrinsicValRef ( + fslib_MFExtraTopLevelOperators_nleref, + "failwithf", + None, + Some "PrintFormatToStringThenFail", + [ vara; varb ], + ([ [ mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty ] ], varaTy) + ) + + let v_reraise_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "reraise", None, Some "Reraise", [ vara ], ([ [ v_unit_ty ] ], varaTy)) + + let v_typeof_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "typeof", None, Some "TypeOf", [ vara ], ([], v_system_Type_ty)) + + let v_methodhandleof_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "methodhandleof", + None, + Some "MethodHandleOf", + [ vara; varb ], + ([ [ varaTy --> varbTy ] ], v_system_RuntimeMethodHandle_ty) + ) + + let v_sizeof_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "sizeof", None, Some "SizeOf", [ vara ], ([], v_int_ty)) + + let v_nameof_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "nameof", None, Some "NameOf", [ vara ], ([ [ varaTy ] ], v_string_ty)) + + let v_unchecked_defaultof_info = + makeIntrinsicValRef (fslib_MFOperatorsUnchecked_nleref, "defaultof", None, Some "DefaultOf", [ vara ], ([], varaTy)) + + let v_typedefof_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "typedefof", None, Some "TypeDefOf", [ vara ], ([], v_system_Type_ty)) + + let v_range_op_info = + makeIntrinsicValRef (fslib_MFOperators_nleref, "op_Range", None, None, [ vara ], ([ [ varaTy ]; [ varaTy ] ], mkSeqTy varaTy)) + + let v_range_step_op_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "op_RangeStep", + None, + None, + [ vara; varb ], + ([ [ varaTy ]; [ varbTy ]; [ varaTy ] ], mkSeqTy varaTy) + ) + + let v_range_int32_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeInt32", + None, + None, + [], + ([ [ v_int_ty ]; [ v_int_ty ]; [ v_int_ty ] ], mkSeqTy v_int_ty) + ) + + let v_range_int64_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeInt64", + None, + None, + [], + ([ [ v_int64_ty ]; [ v_int64_ty ]; [ v_int64_ty ] ], mkSeqTy v_int64_ty) + ) + + let v_range_uint64_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeUInt64", + None, + None, + [], + ([ [ v_uint64_ty ]; [ v_uint64_ty ]; [ v_uint64_ty ] ], mkSeqTy v_uint64_ty) + ) + + let v_range_uint32_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeUInt32", + None, + None, + [], + ([ [ v_uint32_ty ]; [ v_uint32_ty ]; [ v_uint32_ty ] ], mkSeqTy v_uint32_ty) + ) + + let v_range_nativeint_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeIntPtr", + None, + None, + [], + ([ [ v_nativeint_ty ]; [ v_nativeint_ty ]; [ v_nativeint_ty ] ], mkSeqTy v_nativeint_ty) + ) + + let v_range_unativeint_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeUIntPtr", + None, + None, + [], + ([ [ v_unativeint_ty ]; [ v_unativeint_ty ]; [ v_unativeint_ty ] ], mkSeqTy v_unativeint_ty) + ) + + let v_range_int16_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeInt16", + None, + None, + [], + ([ [ v_int16_ty ]; [ v_int16_ty ]; [ v_int16_ty ] ], mkSeqTy v_int16_ty) + ) + + let v_range_uint16_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeUInt16", + None, + None, + [], + ([ [ v_uint16_ty ]; [ v_uint16_ty ]; [ v_uint16_ty ] ], mkSeqTy v_uint16_ty) + ) + + let v_range_sbyte_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeSByte", + None, + None, + [], + ([ [ v_sbyte_ty ]; [ v_sbyte_ty ]; [ v_sbyte_ty ] ], mkSeqTy v_sbyte_ty) + ) + + let v_range_byte_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeByte", + None, + None, + [], + ([ [ v_byte_ty ]; [ v_byte_ty ]; [ v_byte_ty ] ], mkSeqTy v_byte_ty) + ) + + let v_range_char_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeChar", + None, + None, + [], + ([ [ v_char_ty ]; [ v_char_ty ]; [ v_char_ty ] ], mkSeqTy v_char_ty) + ) + + let v_range_generic_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeGeneric", + None, + None, + [ vara ], + ([ [ varaTy ]; [ varaTy ] ], mkSeqTy varaTy) + ) + + let v_range_step_generic_op_info = + makeIntrinsicValRef ( + fslib_MFOperatorIntrinsics_nleref, + "RangeStepGeneric", + None, + None, + [ vara; varb ], + ([ [ varaTy ]; [ varbTy ]; [ varaTy ] ], mkSeqTy varaTy) + ) + + let v_array_length_info = + makeIntrinsicValRef (fslib_MFArrayModule_nleref, "length", None, Some "Length", [ vara ], ([ [ mkArrayType 1 varaTy ] ], v_int_ty)) + + let v_array_get_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "GetArray", + None, + None, + [ vara ], + ([ [ mkArrayType 1 varaTy ]; [ v_int_ty ] ], varaTy) + ) + + let v_array2D_get_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "GetArray2D", + None, + None, + [ vara ], + ([ [ mkArrayType 2 varaTy ]; [ v_int_ty ]; [ v_int_ty ] ], varaTy) + ) + + let v_array3D_get_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "GetArray3D", + None, + None, + [ vara ], + ([ [ mkArrayType 3 varaTy ]; [ v_int_ty ]; [ v_int_ty ]; [ v_int_ty ] ], varaTy) + ) + + let v_array4D_get_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "GetArray4D", + None, + None, + [ vara ], + ([ + [ mkArrayType 4 varaTy ] + [ v_int_ty ] + [ v_int_ty ] + [ v_int_ty ] + [ v_int_ty ] + ], + varaTy) + ) + + let v_array_set_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "SetArray", + None, + None, + [ vara ], + ([ [ mkArrayType 1 varaTy ]; [ v_int_ty ]; [ varaTy ] ], v_unit_ty) + ) + + let v_array2D_set_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "SetArray2D", + None, + None, + [ vara ], + ([ [ mkArrayType 2 varaTy ]; [ v_int_ty ]; [ v_int_ty ]; [ varaTy ] ], v_unit_ty) + ) + + let v_array3D_set_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "SetArray3D", + None, + None, + [ vara ], + ([ + [ mkArrayType 3 varaTy ] + [ v_int_ty ] + [ v_int_ty ] + [ v_int_ty ] + [ varaTy ] + ], + v_unit_ty) + ) + + let v_array4D_set_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "SetArray4D", + None, + None, + [ vara ], + ([ + [ mkArrayType 4 varaTy ] + [ v_int_ty ] + [ v_int_ty ] + [ v_int_ty ] + [ v_int_ty ] + [ varaTy ] + ], + v_unit_ty) + ) + + let v_option_toNullable_info = + makeIntrinsicValRef ( + fslib_MFOptionModule_nleref, + "toNullable", + None, + Some "ToNullable", + [ vara ], + ([ [ mkOptionTy varaTy ] ], mkNullableTy varaTy) + ) + + let v_option_defaultValue_info = + makeIntrinsicValRef ( + fslib_MFOptionModule_nleref, + "defaultValue", + None, + Some "DefaultValue", + [ vara ], + ([ [ varaTy ]; [ mkOptionTy varaTy ] ], varaTy) + ) + + let v_nativeptr_tobyref_info = + makeIntrinsicValRef ( + fslib_MFNativePtrModule_nleref, + "toByRef", + None, + Some "ToByRefInlined", + [ vara ], + ([ [ mkNativePtrTy varaTy ] ], mkByrefTy varaTy) + ) + + let v_seq_collect_info = + makeIntrinsicValRef ( + fslib_MFSeqModule_nleref, + "collect", + None, + Some "Collect", + [ vara; varb; varc ], + ([ [ varaTy --> varbTy ]; [ mkSeqTy varaTy ] ], mkSeqTy varcTy) + ) + + let v_seq_delay_info = + makeIntrinsicValRef ( + fslib_MFSeqModule_nleref, + "delay", + None, + Some "Delay", + [ varb ], + ([ [ v_unit_ty --> mkSeqTy varbTy ] ], mkSeqTy varbTy) + ) + + let v_seq_append_info = + makeIntrinsicValRef ( + fslib_MFSeqModule_nleref, + "append", + None, + Some "Append", + [ varb ], + ([ [ mkSeqTy varbTy ]; [ mkSeqTy varbTy ] ], mkSeqTy varbTy) + ) + + let v_seq_using_info = + makeIntrinsicValRef ( + fslib_MFRuntimeHelpers_nleref, + "EnumerateUsing", + None, + None, + [ vara; varb; varc ], + ([ [ varaTy ]; [ (varaTy --> varbTy) ] ], mkSeqTy varcTy) + ) + + let v_seq_generated_info = + makeIntrinsicValRef ( + fslib_MFRuntimeHelpers_nleref, + "EnumerateWhile", + None, + None, + [ varb ], + ([ [ v_unit_ty --> v_bool_ty ]; [ mkSeqTy varbTy ] ], mkSeqTy varbTy) + ) + + let v_seq_finally_info = + makeIntrinsicValRef ( + fslib_MFRuntimeHelpers_nleref, + "EnumerateThenFinally", + None, + None, + [ varb ], + ([ [ mkSeqTy varbTy ]; [ v_unit_ty --> v_unit_ty ] ], mkSeqTy varbTy) + ) + + let v_seq_trywith_info = + makeIntrinsicValRef ( + fslib_MFRuntimeHelpers_nleref, + "EnumerateTryWith", + None, + None, + [ varb ], + ([ + [ mkSeqTy varbTy ] + [ mkNonGenericTy v_exn_tcr --> v_int32_ty ] + [ mkNonGenericTy v_exn_tcr --> mkSeqTy varbTy ] + ], + mkSeqTy varbTy) + ) + + let v_seq_of_functions_info = + makeIntrinsicValRef ( + fslib_MFRuntimeHelpers_nleref, + "EnumerateFromFunctions", + None, + None, + [ vara; varb ], + ([ [ v_unit_ty --> varaTy ]; [ varaTy --> v_bool_ty ]; [ varaTy --> varbTy ] ], mkSeqTy varbTy) + ) + + let v_create_event_info = + makeIntrinsicValRef ( + fslib_MFRuntimeHelpers_nleref, + "CreateEvent", + None, + None, + [ vara; varb ], + ([ + [ varaTy --> v_unit_ty ] + [ varaTy --> v_unit_ty ] + [ (v_obj_ty_with_null --> (varbTy --> v_unit_ty)) --> varaTy ] + ], + mkIEvent2Ty varaTy varbTy) + ) + + let v_cgh__useResumableCode_info = + makeIntrinsicValRef (fslib_MFStateMachineHelpers_nleref, "__useResumableCode", None, None, [ vara ], ([ [] ], v_bool_ty)) + + let v_cgh__debugPoint_info = + makeIntrinsicValRef ( + fslib_MFStateMachineHelpers_nleref, + "__debugPoint", + None, + None, + [ vara ], + ([ [ v_int_ty ]; [ varaTy ] ], varaTy) + ) + + let v_cgh__resumeAt_info = + makeIntrinsicValRef (fslib_MFStateMachineHelpers_nleref, "__resumeAt", None, None, [ vara ], ([ [ v_int_ty ]; [ varaTy ] ], varaTy)) + + let v_cgh__stateMachine_info = + makeIntrinsicValRef (fslib_MFStateMachineHelpers_nleref, "__stateMachine", None, None, [ vara; varb ], ([ [ varaTy ] ], varbTy)) // inaccurate type but it doesn't matter for linking + + let v_cgh__resumableEntry_info = + makeIntrinsicValRef ( + fslib_MFStateMachineHelpers_nleref, + "__resumableEntry", + None, + None, + [ vara ], + ([ [ v_int_ty --> varaTy ]; [ v_unit_ty --> varaTy ] ], varaTy) + ) + + let v_seq_to_array_info = + makeIntrinsicValRef ( + fslib_MFSeqModule_nleref, + "toArray", + None, + Some "ToArray", + [ varb ], + ([ [ mkSeqTy varbTy ] ], mkArrayType 1 varbTy) + ) + + let v_seq_to_list_info = + makeIntrinsicValRef (fslib_MFSeqModule_nleref, "toList", None, Some "ToList", [ varb ], ([ [ mkSeqTy varbTy ] ], mkListTy varbTy)) + + let v_seq_map_info = + makeIntrinsicValRef ( + fslib_MFSeqModule_nleref, + "map", + None, + Some "Map", + [ vara; varb ], + ([ [ varaTy --> varbTy ]; [ mkSeqTy varaTy ] ], mkSeqTy varbTy) + ) + + let v_seq_singleton_info = + makeIntrinsicValRef (fslib_MFSeqModule_nleref, "singleton", None, Some "Singleton", [ vara ], ([ [ varaTy ] ], mkSeqTy varaTy)) + + let v_seq_empty_info = + makeIntrinsicValRef (fslib_MFSeqModule_nleref, "empty", None, Some "Empty", [ vara ], ([], mkSeqTy varaTy)) + + let v_new_format_info = + makeIntrinsicValRef ( + fslib_MFCore_nleref, + ".ctor", + Some "PrintfFormat`5", + None, + [ vara; varb; varc; vard; vare ], + ([ [ v_string_ty ] ], mkPrintfFormatTy varaTy varbTy varcTy vardTy vareTy) + ) + + let v_sprintf_info = + makeIntrinsicValRef ( + fslib_MFExtraTopLevelOperators_nleref, + "sprintf", + None, + Some "PrintFormatToStringThen", + [ vara ], + ([ [ mk_format4_ty varaTy v_unit_ty v_string_ty v_string_ty ] ], varaTy) + ) + + let v_lazy_force_info = + makeIntrinsicValRef (fslib_MFLazyExtensions_nleref, "Force", Some "Lazy`1", None, [ vara ], ([ [ mkLazyTy varaTy ]; [] ], varaTy)) + + let v_lazy_create_info = + makeIntrinsicValRef ( + fslib_MFLazyExtensions_nleref, + "Create", + Some "Lazy`1", + None, + [ vara ], + ([ [ v_unit_ty --> varaTy ] ], mkLazyTy varaTy) + ) + + let v_seq_info = + makeIntrinsicValRef ( + fslib_MFOperators_nleref, + "seq", + None, + Some "CreateSequence", + [ vara ], + ([ [ mkSeqTy varaTy ] ], mkSeqTy varaTy) + ) + + let v_splice_expr_info = + makeIntrinsicValRef ( + fslib_MFExtraTopLevelOperators_nleref, + "op_Splice", + None, + None, + [ vara ], + ([ [ mkQuotedExprTy varaTy ] ], varaTy) + ) + + let v_splice_raw_expr_info = + makeIntrinsicValRef ( + fslib_MFExtraTopLevelOperators_nleref, + "op_SpliceUntyped", + None, + None, + [ vara ], + ([ [ mkRawQuotedExprTy ] ], varaTy) + ) + + let v_new_decimal_info = + makeIntrinsicValRef ( + fslib_MFIntrinsicFunctions_nleref, + "MakeDecimal", + None, + None, + [], + ([ [ v_int_ty ]; [ v_int_ty ]; [ v_int_ty ]; [ v_bool_ty ]; [ v_byte_ty ] ], v_decimal_ty) + ) + + let v_deserialize_quoted_FSharp_20_plus_info = + makeIntrinsicValRef ( + fslib_MFQuotations_nleref, + "Deserialize", + Some "Expr", + None, + [], + ([ + [ + v_system_Type_ty + mkListTy v_system_Type_ty + mkListTy mkRawQuotedExprTy + mkArrayType 1 v_byte_ty + ] + ], + mkRawQuotedExprTy) + ) + + let v_deserialize_quoted_FSharp_40_plus_info = + makeIntrinsicValRef ( + fslib_MFQuotations_nleref, + "Deserialize40", + Some "Expr", + None, + [], + ([ + [ + v_system_Type_ty + mkArrayType 1 v_system_Type_ty + mkArrayType 1 v_system_Type_ty + mkArrayType 1 mkRawQuotedExprTy + mkArrayType 1 v_byte_ty + ] + ], + mkRawQuotedExprTy) + ) + + let v_call_with_witnesses_info = + makeIntrinsicValRef ( + fslib_MFQuotations_nleref, + "CallWithWitnesses", + Some "Expr", + None, + [], + ([ + [ + v_system_Reflection_MethodInfo_ty + v_system_Reflection_MethodInfo_ty + mkListTy mkRawQuotedExprTy + mkListTy mkRawQuotedExprTy + ] + ], + mkRawQuotedExprTy) + ) + + let v_cast_quotation_info = + makeIntrinsicValRef ( + fslib_MFQuotations_nleref, + "Cast", + Some "Expr", + None, + [ vara ], + ([ [ mkRawQuotedExprTy ] ], mkQuotedExprTy varaTy) + ) + + let v_lift_value_info = + makeIntrinsicValRef (fslib_MFQuotations_nleref, "Value", Some "Expr", None, [ vara ], ([ [ varaTy ] ], mkRawQuotedExprTy)) + + let v_lift_value_with_name_info = + makeIntrinsicValRef ( + fslib_MFQuotations_nleref, + "ValueWithName", + Some "Expr", + None, + [ vara ], + ([ [ varaTy; v_string_ty ] ], mkRawQuotedExprTy) + ) + + let v_lift_value_with_defn_info = + makeIntrinsicValRef ( + fslib_MFQuotations_nleref, + "WithValue", + Some "Expr", + None, + [ vara ], + ([ [ varaTy; mkQuotedExprTy varaTy ] ], mkQuotedExprTy varaTy) + ) + + let v_query_value_info = + makeIntrinsicValRef (fslib_MFExtraTopLevelOperators_nleref, "query", None, None, [], ([], mkQueryBuilderTy)) + + let v_query_run_value_info = + makeIntrinsicValRef ( + fslib_MFQueryRunExtensionsLowPriority_nleref, + "Run", + Some "QueryBuilder", + None, + [ vara ], + ([ [ mkQueryBuilderTy ]; [ mkQuotedExprTy varaTy ] ], varaTy) + ) + + let v_query_run_enumerable_info = + makeIntrinsicValRef ( + fslib_MFQueryRunExtensionsHighPriority_nleref, + "Run", + Some "QueryBuilder", + None, + [ vara ], + ([ + [ mkQueryBuilderTy ] + [ + mkQuotedExprTy (mkQuerySourceTy varaTy (mkNonGenericTy v_tcref_System_Collections_IEnumerable)) + ] + ], + mkSeqTy varaTy) + ) + + let v_query_for_value_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "For", + Some "QueryBuilder", + None, + [ vara; vard; varb; vare ], + ([ + [ mkQueryBuilderTy ] + [ mkQuerySourceTy varaTy vardTy; varaTy --> mkQuerySourceTy varbTy vareTy ] + ], + mkQuerySourceTy varbTy vardTy) + ) + + let v_query_select_value_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "Select", + Some "QueryBuilder", + None, + [ vara; vare; varb ], + ([ [ mkQueryBuilderTy ]; [ mkQuerySourceTy varaTy vareTy; varaTy --> varbTy ] ], mkQuerySourceTy varbTy vareTy) + ) + + let v_query_yield_value_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "Yield", + Some "QueryBuilder", + None, + [ vara; vare ], + ([ [ mkQueryBuilderTy ]; [ varaTy ] ], mkQuerySourceTy varaTy vareTy) + ) + + let v_query_yield_from_value_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "YieldFrom", + Some "QueryBuilder", + None, + [ vara; vare ], + ([ [ mkQueryBuilderTy ]; [ mkQuerySourceTy varaTy vareTy ] ], mkQuerySourceTy varaTy vareTy) + ) + + let v_query_source_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "Source", + Some "QueryBuilder", + None, + [ vara ], + ([ [ mkQueryBuilderTy ]; [ mkSeqTy varaTy ] ], mkQuerySourceTy varaTy (mkNonGenericTy v_tcref_System_Collections_IEnumerable)) + ) + + let v_query_source_as_enum_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "get_Source", + Some "QuerySource`2", + None, + [ vara; vare ], + ([ [ mkQuerySourceTy varaTy vareTy ]; [] ], mkSeqTy varaTy) + ) + + let v_new_query_source_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + ".ctor", + Some "QuerySource`2", + None, + [ vara; vare ], + ([ [ mkSeqTy varaTy ] ], mkQuerySourceTy varaTy vareTy) + ) + + let v_query_zero_value_info = + makeIntrinsicValRef ( + fslib_MFLinq_nleref, + "Zero", + Some "QueryBuilder", + None, + [ vara; vare ], + ([ [ mkQueryBuilderTy ]; [] ], mkQuerySourceTy varaTy vareTy) + ) + + let v_fail_init_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "FailInit", None, None, [], ([ [ v_unit_ty ] ], v_unit_ty)) + + let v_fail_static_init_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "FailStaticInit", None, None, [], ([ [ v_unit_ty ] ], v_unit_ty)) + + let v_check_this_info = + makeIntrinsicValRef (fslib_MFIntrinsicFunctions_nleref, "CheckThis", None, None, [ vara ], ([ [ varaTy ] ], varaTy)) + + let v_quote_to_linq_lambda_info = + makeIntrinsicValRef ( + fslib_MFLinqRuntimeHelpersQuotationConverter_nleref, + "QuotationToLambdaExpression", + None, + None, + [ vara ], + ([ [ mkQuotedExprTy varaTy ] ], mkLinqExpressionTy varaTy) + ) + + let tref_DebuggerNonUserCodeAttribute = + findSysILTypeRef tname_DebuggerNonUserCodeAttribute + + let v_DebuggerNonUserCodeAttribute_tcr = + splitILTypeName tname_DebuggerNonUserCodeAttribute ||> findSysTyconRef + + let tref_DebuggableAttribute = findSysILTypeRef tname_DebuggableAttribute + + let tref_CompilerGeneratedAttribute = + findSysILTypeRef tname_CompilerGeneratedAttribute + + let v_CompilerGeneratedAttribute_tcr = + splitILTypeName tname_CompilerGeneratedAttribute ||> findSysTyconRef + + let tref_InternalsVisibleToAttribute = + findSysILTypeRef tname_InternalsVisibleToAttribute + + let debuggerNonUserCodeAttribute = + mkILCustomAttribute (tref_DebuggerNonUserCodeAttribute, [], [], []) + + let compilerGeneratedAttribute = + mkILCustomAttribute (tref_CompilerGeneratedAttribute, [], [], []) + + let generatedAttributes = + if noDebugAttributes then + [||] + else + [| compilerGeneratedAttribute; debuggerNonUserCodeAttribute |] + + let compilerGlobalState = CompilerGlobalState() + + // Requests attributes to be added to compiler generated methods. + let addGeneratedAttrs (attrs: ILAttributes) = + if Array.isEmpty generatedAttributes then + attrs + else + match attrs.AsArray() with + | [||] -> mkILCustomAttrsFromArray generatedAttributes + | attrs -> mkILCustomAttrsFromArray (Array.append attrs generatedAttributes) + + let addValGeneratedAttrs (v: Val) m = + if not noDebugAttributes then + let attrs = + [ + Attrib(v_CompilerGeneratedAttribute_tcr, ILAttrib compilerGeneratedAttribute.Method.MethodRef, [], [], false, None, m) + Attrib( + v_DebuggerNonUserCodeAttribute_tcr, + ILAttrib debuggerNonUserCodeAttribute.Method.MethodRef, + [], + [], + false, + None, + m + ) + Attrib( + v_DebuggerNonUserCodeAttribute_tcr, + ILAttrib debuggerNonUserCodeAttribute.Method.MethodRef, + [], + [], + true, + None, + m + ) + ] + + match v.Attribs with + | [] -> v.SetAttribs attrs + | _ -> v.SetAttribs(attrs @ v.Attribs) + + let addMethodGeneratedAttrs (mdef: ILMethodDef) = + mdef.With(customAttrs = addGeneratedAttrs mdef.CustomAttrs) + + let addPropertyGeneratedAttrs (pdef: ILPropertyDef) = + pdef.With(customAttrs = addGeneratedAttrs pdef.CustomAttrs) + + let addFieldGeneratedAttrs (fdef: ILFieldDef) = + fdef.With(customAttrs = addGeneratedAttrs fdef.CustomAttrs) + + let tref_DebuggerBrowsableAttribute n = let typ_DebuggerBrowsableState = let tref = findSysILTypeRef tname_DebuggerBrowsableState - ILType.Value (mkILNonGenericTySpec tref) - mkILCustomAttribute (findSysILTypeRef tname_DebuggerBrowsableAttribute, [typ_DebuggerBrowsableState], [ILAttribElem.Int32 n], []) - - let debuggerBrowsableNeverAttribute = tref_DebuggerBrowsableAttribute 0 - - let addNeverAttrs (attrs: ILAttributes) = mkILCustomAttrsFromArray (Array.append (attrs.AsArray()) [| debuggerBrowsableNeverAttribute |]) - - let addPropertyNeverAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addNeverAttrs pdef.CustomAttrs) - - let addFieldNeverAttrs (fdef:ILFieldDef) = fdef.With(customAttrs = addNeverAttrs fdef.CustomAttrs) - - let mkDebuggerTypeProxyAttribute (ty : ILType) = mkILCustomAttribute (findSysILTypeRef tname_DebuggerTypeProxyAttribute, [ilg.typ_Type], [ILAttribElem.TypeRef (Some ty.TypeRef)], []) - - let betterTyconEntries = - [| "Int32" , v_int_tcr - "IntPtr" , v_nativeint_tcr - "UIntPtr" , v_unativeint_tcr - "Int16" , v_int16_tcr - "Int64" , v_int64_tcr - "UInt16" , v_uint16_tcr - "UInt32" , v_uint32_tcr - "UInt64" , v_uint64_tcr - "SByte" , v_sbyte_tcr - "Decimal" , v_decimal_tcr - "Byte" , v_byte_tcr - "Boolean" , v_bool_tcr - "String" , v_string_tcr - "Object" , v_obj_tcr - "Exception", v_exn_tcr - "Char" , v_char_tcr - "Double" , v_float_tcr - "Single" , v_float32_tcr |] - |> Array.map (fun (nm, tcr) -> - let ty = mkNonGenericTy tcr - nm, findSysTyconRef sys nm, (fun _ nullness -> - match nullness with - | Nullness.Known NullnessInfo.WithoutNull -> ty - | _ -> mkNonGenericTyWithNullness tcr nullness)) - - let decompileTyconEntries = + ILType.Value(mkILNonGenericTySpec tref) + + mkILCustomAttribute ( + findSysILTypeRef tname_DebuggerBrowsableAttribute, + [ typ_DebuggerBrowsableState ], + [ ILAttribElem.Int32 n ], + [] + ) + + let debuggerBrowsableNeverAttribute = tref_DebuggerBrowsableAttribute 0 + + let addNeverAttrs (attrs: ILAttributes) = + mkILCustomAttrsFromArray (Array.append (attrs.AsArray()) [| debuggerBrowsableNeverAttribute |]) + + let addPropertyNeverAttrs (pdef: ILPropertyDef) = + pdef.With(customAttrs = addNeverAttrs pdef.CustomAttrs) + + let addFieldNeverAttrs (fdef: ILFieldDef) = + fdef.With(customAttrs = addNeverAttrs fdef.CustomAttrs) + + let mkDebuggerTypeProxyAttribute (ty: ILType) = + mkILCustomAttribute ( + findSysILTypeRef tname_DebuggerTypeProxyAttribute, + [ ilg.typ_Type ], + [ ILAttribElem.TypeRef(Some ty.TypeRef) ], + [] + ) + + let betterTyconEntries = + [| + "Int32", v_int_tcr + "IntPtr", v_nativeint_tcr + "UIntPtr", v_unativeint_tcr + "Int16", v_int16_tcr + "Int64", v_int64_tcr + "UInt16", v_uint16_tcr + "UInt32", v_uint32_tcr + "UInt64", v_uint64_tcr + "SByte", v_sbyte_tcr + "Decimal", v_decimal_tcr + "Byte", v_byte_tcr + "Boolean", v_bool_tcr + "String", v_string_tcr + "Object", v_obj_tcr + "Exception", v_exn_tcr + "Char", v_char_tcr + "Double", v_float_tcr + "Single", v_float32_tcr + |] + |> Array.map (fun (nm, tcr) -> + let ty = mkNonGenericTy tcr + + nm, + findSysTyconRef sys nm, + (fun _ nullness -> + match nullness with + | Nullness.Known NullnessInfo.WithoutNull -> ty + | _ -> mkNonGenericTyWithNullness tcr nullness)) + + let decompileTyconEntries = [| - "FSharpFunc`2" , v_fastFunc_tcr , (fun tinst -> mkFunTyWithNullness (List.item 0 tinst) (List.item 1 tinst)) - "Tuple`2" , v_ref_tuple2_tcr , decodeTupleTyAndNullness tupInfoRef - "Tuple`3" , v_ref_tuple3_tcr , decodeTupleTyAndNullness tupInfoRef - "Tuple`4" , v_ref_tuple4_tcr , decodeTupleTyAndNullness tupInfoRef - "Tuple`5" , v_ref_tuple5_tcr , decodeTupleTyAndNullness tupInfoRef - "Tuple`6" , v_ref_tuple6_tcr , decodeTupleTyAndNullness tupInfoRef - "Tuple`7" , v_ref_tuple7_tcr , decodeTupleTyAndNullness tupInfoRef - "Tuple`8" , v_ref_tuple8_tcr , decodeTupleTyAndNullnessIfPossible v_ref_tuple8_tcr tupInfoRef - "ValueTuple`2" , v_struct_tuple2_tcr , decodeTupleTyAndNullness tupInfoStruct - "ValueTuple`3" , v_struct_tuple3_tcr , decodeTupleTyAndNullness tupInfoStruct - "ValueTuple`4" , v_struct_tuple4_tcr , decodeTupleTyAndNullness tupInfoStruct - "ValueTuple`5" , v_struct_tuple5_tcr , decodeTupleTyAndNullness tupInfoStruct - "ValueTuple`6" , v_struct_tuple6_tcr , decodeTupleTyAndNullness tupInfoStruct - "ValueTuple`7" , v_struct_tuple7_tcr , decodeTupleTyAndNullness tupInfoStruct - "ValueTuple`8" , v_struct_tuple8_tcr , decodeTupleTyAndNullnessIfPossible v_struct_tuple8_tcr tupInfoStruct |] - - let betterEntries = Array.append betterTyconEntries decompileTyconEntries - - let mutable decompileTypeDict = Unchecked.defaultof<_> - let mutable betterTypeDict1 = Unchecked.defaultof<_> - let mutable betterTypeDict2 = Unchecked.defaultof<_> - - /// This map is indexed by stamps and lazy to avoid dereferencing while setting up the base imports. - let getDecompileTypeDict () = - match box decompileTypeDict with - | null -> - let entries = decompileTyconEntries - let t = Dictionary.newWithSize entries.Length - for _, tcref, builder in entries do - if tcref.CanDeref then - t.Add(tcref.Stamp, builder) - decompileTypeDict <- t - t - | _ -> decompileTypeDict - - /// This map is for use when building FSharp.Core.dll. The backing Tycon's may not yet exist for - /// the TyconRef's we have in our hands, hence we can't dereference them to find their stamps. - /// So this dictionary is indexed by names. Make it lazy to avoid dereferencing while setting up the base imports. - let getBetterTypeDict1 () = - match box betterTypeDict1 with - | null -> - let entries = betterEntries - let t = Dictionary.newWithSize entries.Length - for nm, tcref, builder in entries do - t.Add(nm, - (fun tcref2 tinst2 nullness -> - if tyconRefEq tcref tcref2 then - builder tinst2 nullness - else - TType_app (tcref2, tinst2, nullness))) - betterTypeDict1 <- t - t - | _ -> betterTypeDict1 - - /// This map is for use in normal times (not building FSharp.Core.dll). It is indexed by stamps - /// and lazy to avoid dereferencing while setting up the base imports. - let getBetterTypeDict2 () = - match box betterTypeDict2 with - | null -> - let entries = betterEntries - let t = Dictionary.newWithSize entries.Length - for _, tcref, builder in entries do - if tcref.CanDeref then - t.Add(tcref.Stamp, builder) - betterTypeDict2 <- t - t - | _ -> betterTypeDict2 - - /// For logical purposes equate some F# types with .NET types, e.g. TType_tuple == System.Tuple/ValueTuple. - /// Doing this normalization is a fairly performance critical piece of code as it is frequently invoked - /// in the process of converting .NET metadata to F# internal compiler data structures (see import.fs). - let decompileTy (tcref: EntityRef) tinst nullness = - if compilingFSharpCore then - // No need to decompile when compiling FSharp.Core.dll - TType_app (tcref, tinst, nullness) - else - let dict = getDecompileTypeDict() - match dict.TryGetValue tcref.Stamp with - | true, builder -> builder tinst nullness - | _ -> TType_app (tcref, tinst, nullness) - - /// For cosmetic purposes "improve" some .NET types, e.g. Int32 --> int32. - /// Doing this normalization is a fairly performance critical piece of code as it is frequently invoked - /// in the process of converting .NET metadata to F# internal compiler data structures (see import.fs). - let improveTy (tcref: EntityRef) tinst nullness = + "FSharpFunc`2", v_fastFunc_tcr, (fun tinst -> mkFunTyWithNullness (List.item 0 tinst) (List.item 1 tinst)) + "Tuple`2", v_ref_tuple2_tcr, decodeTupleTyAndNullness tupInfoRef + "Tuple`3", v_ref_tuple3_tcr, decodeTupleTyAndNullness tupInfoRef + "Tuple`4", v_ref_tuple4_tcr, decodeTupleTyAndNullness tupInfoRef + "Tuple`5", v_ref_tuple5_tcr, decodeTupleTyAndNullness tupInfoRef + "Tuple`6", v_ref_tuple6_tcr, decodeTupleTyAndNullness tupInfoRef + "Tuple`7", v_ref_tuple7_tcr, decodeTupleTyAndNullness tupInfoRef + "Tuple`8", v_ref_tuple8_tcr, decodeTupleTyAndNullnessIfPossible v_ref_tuple8_tcr tupInfoRef + "ValueTuple`2", v_struct_tuple2_tcr, decodeTupleTyAndNullness tupInfoStruct + "ValueTuple`3", v_struct_tuple3_tcr, decodeTupleTyAndNullness tupInfoStruct + "ValueTuple`4", v_struct_tuple4_tcr, decodeTupleTyAndNullness tupInfoStruct + "ValueTuple`5", v_struct_tuple5_tcr, decodeTupleTyAndNullness tupInfoStruct + "ValueTuple`6", v_struct_tuple6_tcr, decodeTupleTyAndNullness tupInfoStruct + "ValueTuple`7", v_struct_tuple7_tcr, decodeTupleTyAndNullness tupInfoStruct + "ValueTuple`8", v_struct_tuple8_tcr, decodeTupleTyAndNullnessIfPossible v_struct_tuple8_tcr tupInfoStruct + |] + + let betterEntries = Array.append betterTyconEntries decompileTyconEntries + + let mutable decompileTypeDict = Unchecked.defaultof<_> + let mutable betterTypeDict1 = Unchecked.defaultof<_> + let mutable betterTypeDict2 = Unchecked.defaultof<_> + + /// This map is indexed by stamps and lazy to avoid dereferencing while setting up the base imports. + let getDecompileTypeDict () = + match box decompileTypeDict with + | null -> + let entries = decompileTyconEntries + let t = Dictionary.newWithSize entries.Length + + for _, tcref, builder in entries do + if tcref.CanDeref then + t.Add(tcref.Stamp, builder) + + decompileTypeDict <- t + t + | _ -> decompileTypeDict + + /// This map is for use when building FSharp.Core.dll. The backing Tycon's may not yet exist for + /// the TyconRef's we have in our hands, hence we can't dereference them to find their stamps. + /// So this dictionary is indexed by names. Make it lazy to avoid dereferencing while setting up the base imports. + let getBetterTypeDict1 () = + match box betterTypeDict1 with + | null -> + let entries = betterEntries + let t = Dictionary.newWithSize entries.Length + + for nm, tcref, builder in entries do + t.Add( + nm, + (fun tcref2 tinst2 nullness -> + if tyconRefEq tcref tcref2 then + builder tinst2 nullness + else + TType_app(tcref2, tinst2, nullness)) + ) + + betterTypeDict1 <- t + t + | _ -> betterTypeDict1 + + /// This map is for use in normal times (not building FSharp.Core.dll). It is indexed by stamps + /// and lazy to avoid dereferencing while setting up the base imports. + let getBetterTypeDict2 () = + match box betterTypeDict2 with + | null -> + let entries = betterEntries + let t = Dictionary.newWithSize entries.Length + + for _, tcref, builder in entries do + if tcref.CanDeref then + t.Add(tcref.Stamp, builder) + + betterTypeDict2 <- t + t + | _ -> betterTypeDict2 + + /// For logical purposes equate some F# types with .NET types, e.g. TType_tuple == System.Tuple/ValueTuple. + /// Doing this normalization is a fairly performance critical piece of code as it is frequently invoked + /// in the process of converting .NET metadata to F# internal compiler data structures (see import.fs). + let decompileTy (tcref: EntityRef) tinst nullness = if compilingFSharpCore then - let dict = getBetterTypeDict1() + // No need to decompile when compiling FSharp.Core.dll + TType_app(tcref, tinst, nullness) + else + let dict = getDecompileTypeDict () + + match dict.TryGetValue tcref.Stamp with + | true, builder -> builder tinst nullness + | _ -> TType_app(tcref, tinst, nullness) + + /// For cosmetic purposes "improve" some .NET types, e.g. Int32 --> int32. + /// Doing this normalization is a fairly performance critical piece of code as it is frequently invoked + /// in the process of converting .NET metadata to F# internal compiler data structures (see import.fs). + let improveTy (tcref: EntityRef) tinst nullness = + if compilingFSharpCore then + let dict = getBetterTypeDict1 () + match dict.TryGetValue tcref.LogicalName with | true, builder -> builder tcref tinst nullness - | _ -> TType_app (tcref, tinst, nullness) + | _ -> TType_app(tcref, tinst, nullness) else - let dict = getBetterTypeDict2() + let dict = getBetterTypeDict2 () + match dict.TryGetValue tcref.Stamp with | true, builder -> builder tinst nullness - | _ -> TType_app (tcref, tinst, nullness) - - // Adding an unnecessary "let" instead of inlining into a multi-line pipelined compute-once "member val" that is too complex for @dsyme - let v_attribs_Unsupported = [ - tryFindSysAttrib "System.Runtime.CompilerServices.ModuleInitializerAttribute" - tryFindSysAttrib "System.Runtime.CompilerServices.CallerArgumentExpressionAttribute" - tryFindSysAttrib "System.Runtime.InteropServices.UnmanagedCallersOnlyAttribute" - tryFindSysAttrib "System.Runtime.CompilerServices.CompilerFeatureRequiredAttribute" - tryFindSysAttrib "System.Diagnostics.CodeAnalysis.SetsRequiredMembersAttribute" - tryFindSysAttrib "System.Runtime.CompilerServices.RequiredMemberAttribute" - ] |> List.choose (Option.map (fun x -> x.TyconRef)) + | _ -> TType_app(tcref, tinst, nullness) - static member IsInEmbeddableKnownSet name = isInEmbeddableKnownSet name + // Adding an unnecessary "let" instead of inlining into a multi-line pipelined compute-once "member val" that is too complex for @dsyme + let v_attribs_Unsupported = + [ + tryFindSysAttrib "System.Runtime.CompilerServices.ModuleInitializerAttribute" + tryFindSysAttrib "System.Runtime.CompilerServices.CallerArgumentExpressionAttribute" + tryFindSysAttrib "System.Runtime.InteropServices.UnmanagedCallersOnlyAttribute" + tryFindSysAttrib "System.Runtime.CompilerServices.CompilerFeatureRequiredAttribute" + tryFindSysAttrib "System.Diagnostics.CodeAnalysis.SetsRequiredMembersAttribute" + tryFindSysAttrib "System.Runtime.CompilerServices.RequiredMemberAttribute" + ] + |> List.choose (Option.map (fun x -> x.TyconRef)) - override _.ToString() = "" + static member IsInEmbeddableKnownSet name = isInEmbeddableKnownSet name - member _.directoryToResolveRelativePaths = directoryToResolveRelativePaths + override _.ToString() = "" - member _.ilg = ilg + member _.directoryToResolveRelativePaths = directoryToResolveRelativePaths - member _.noDebugAttributes = noDebugAttributes + member _.ilg = ilg - member _.tryFindSysTypeCcuHelper: string list -> string -> bool -> FSharp.Compiler.TypedTree.CcuThunk option = tryFindSysTypeCcuHelper + member _.noDebugAttributes = noDebugAttributes - member _.tryRemoveEmbeddedILTypeDefs () = [ - for key in embeddedILTypeDefs.Keys.OrderBy id do - match (embeddedILTypeDefs.TryRemove(key)) with - | true, ilTypeDef -> yield ilTypeDef - | false, _ -> () - ] + member _.tryFindSysTypeCcuHelper: string list -> string -> bool -> FSharp.Compiler.TypedTree.CcuThunk option = + tryFindSysTypeCcuHelper - // A table of all intrinsics that the compiler cares about - member _.knownIntrinsics = v_knownIntrinsics + member _.tryRemoveEmbeddedILTypeDefs() = + [ + for key in embeddedILTypeDefs.Keys.OrderBy id do + match (embeddedILTypeDefs.TryRemove(key)) with + | true, ilTypeDef -> yield ilTypeDef + | false, _ -> () + ] - member _.checkNullness = checkNullness + // A table of all intrinsics that the compiler cares about + member _.knownIntrinsics = v_knownIntrinsics - member _.langFeatureNullness = v_langFeatureNullness + member _.checkNullness = checkNullness - member _.knownWithNull = v_knownWithNull + member _.langFeatureNullness = v_langFeatureNullness - member _.knownWithoutNull = v_knownWithoutNull + member _.knownWithNull = v_knownWithNull - // A table of known modules in FSharp.Core. Not all modules are necessarily listed, but the more we list the - // better the job we do of mapping from provided expressions back to FSharp.Core F# functions and values. - member _.knownFSharpCoreModules = v_knownFSharpCoreModules + member _.knownWithoutNull = v_knownWithoutNull - member _.compilingFSharpCore = compilingFSharpCore + // A table of known modules in FSharp.Core. Not all modules are necessarily listed, but the more we list the + // better the job we do of mapping from provided expressions back to FSharp.Core F# functions and values. + member _.knownFSharpCoreModules = v_knownFSharpCoreModules - member _.useReflectionFreeCodeGen = useReflectionFreeCodeGen + member _.compilingFSharpCore = compilingFSharpCore - member _.mlCompatibility = mlCompatibility + member _.useReflectionFreeCodeGen = useReflectionFreeCodeGen - member _.emitDebugInfoInQuotations = emitDebugInfoInQuotations + member _.mlCompatibility = mlCompatibility - member _.pathMap = pathMap + member _.emitDebugInfoInQuotations = emitDebugInfoInQuotations - member _.langVersion = langVersion + member _.pathMap = pathMap - member _.realsig = realsig + member _.langVersion = langVersion - member _.unionCaseRefEq x y = primUnionCaseRefEq compilingFSharpCore fslibCcu x y + member _.realsig = realsig - member _.valRefEq x y = primValRefEq compilingFSharpCore fslibCcu x y + member _.unionCaseRefEq x y = + primUnionCaseRefEq compilingFSharpCore fslibCcu x y - member _.fslibCcu = fslibCcu + member _.valRefEq x y = + primValRefEq compilingFSharpCore fslibCcu x y - member val refcell_tcr_canon = v_refcell_tcr_canon + member _.fslibCcu = fslibCcu - member val option_tcr_canon = mk_MFCore_tcref fslibCcu "Option`1" + member val refcell_tcr_canon = v_refcell_tcr_canon - member val valueoption_tcr_canon = mk_MFCore_tcref fslibCcu "ValueOption`1" + member val option_tcr_canon = mk_MFCore_tcref fslibCcu "Option`1" - member _.list_tcr_canon = v_list_tcr_canon + member val valueoption_tcr_canon = mk_MFCore_tcref fslibCcu "ValueOption`1" - member _.lazy_tcr_canon = lazy_tcr + member _.list_tcr_canon = v_list_tcr_canon - member val refcell_tcr_nice = v_refcell_tcr_nice + member _.lazy_tcr_canon = lazy_tcr - member val array_tcr_nice = v_il_arr_tcr_map[0] + member val refcell_tcr_nice = v_refcell_tcr_nice - member _.option_tcr_nice = v_option_tcr_nice + member val array_tcr_nice = v_il_arr_tcr_map[0] - member _.valueoption_tcr_nice = v_valueoption_tcr_nice + member _.option_tcr_nice = v_option_tcr_nice - member _.list_tcr_nice = v_list_tcr_nice + member _.valueoption_tcr_nice = v_valueoption_tcr_nice - member _.lazy_tcr_nice = v_lazy_tcr_nice + member _.list_tcr_nice = v_list_tcr_nice - member _.format_tcr = v_format_tcr + member _.lazy_tcr_nice = v_lazy_tcr_nice - member _.format4_tcr = v_format4_tcr + member _.format_tcr = v_format_tcr - member _.expr_tcr = v_expr_tcr + member _.format4_tcr = v_format4_tcr - member _.raw_expr_tcr = v_raw_expr_tcr + member _.expr_tcr = v_expr_tcr - member _.nativeint_tcr = v_nativeint_tcr + member _.raw_expr_tcr = v_raw_expr_tcr - member _.int32_tcr = v_int32_tcr + member _.nativeint_tcr = v_nativeint_tcr - member _.int16_tcr = v_int16_tcr + member _.int32_tcr = v_int32_tcr - member _.int64_tcr = v_int64_tcr + member _.int16_tcr = v_int16_tcr - member _.uint16_tcr = v_uint16_tcr + member _.int64_tcr = v_int64_tcr - member _.uint32_tcr = v_uint32_tcr + member _.uint16_tcr = v_uint16_tcr - member _.uint64_tcr = v_uint64_tcr + member _.uint32_tcr = v_uint32_tcr - member _.sbyte_tcr = v_sbyte_tcr + member _.uint64_tcr = v_uint64_tcr - member _.decimal_tcr = v_decimal_tcr + member _.sbyte_tcr = v_sbyte_tcr - member _.date_tcr = v_date_tcr + member _.decimal_tcr = v_decimal_tcr - member _.pdecimal_tcr = v_pdecimal_tcr + member _.date_tcr = v_date_tcr - member _.byte_tcr = v_byte_tcr + member _.pdecimal_tcr = v_pdecimal_tcr - member _.bool_tcr = v_bool_tcr + member _.byte_tcr = v_byte_tcr - member _.unit_tcr_canon = v_unit_tcr_canon + member _.bool_tcr = v_bool_tcr - member _.exn_tcr = v_exn_tcr + member _.unit_tcr_canon = v_unit_tcr_canon - member _.char_tcr = v_char_tcr + member _.exn_tcr = v_exn_tcr - member _.float_tcr = v_float_tcr + member _.char_tcr = v_char_tcr - member _.float32_tcr = v_float32_tcr + member _.float_tcr = v_float_tcr - member _.pfloat_tcr = v_pfloat_tcr + member _.float32_tcr = v_float32_tcr - member _.pfloat32_tcr = v_pfloat32_tcr + member _.pfloat_tcr = v_pfloat_tcr - member _.pint_tcr = v_pint_tcr + member _.pfloat32_tcr = v_pfloat32_tcr - member _.pint8_tcr = v_pint8_tcr + member _.pint_tcr = v_pint_tcr - member _.pint16_tcr = v_pint16_tcr + member _.pint8_tcr = v_pint8_tcr - member _.pint64_tcr = v_pint64_tcr + member _.pint16_tcr = v_pint16_tcr - member _.pnativeint_tcr = v_pnativeint_tcr + member _.pint64_tcr = v_pint64_tcr - member _.puint_tcr = v_puint_tcr + member _.pnativeint_tcr = v_pnativeint_tcr - member _.puint8_tcr = v_puint8_tcr + member _.puint_tcr = v_puint_tcr - member _.puint16_tcr = v_puint16_tcr + member _.puint8_tcr = v_puint8_tcr - member _.puint64_tcr = v_puint64_tcr + member _.puint16_tcr = v_puint16_tcr - member _.punativeint_tcr = v_punativeint_tcr + member _.puint64_tcr = v_puint64_tcr - member _.byref_tcr = v_byref_tcr + member _.punativeint_tcr = v_punativeint_tcr - member _.byref2_tcr = v_byref2_tcr + member _.byref_tcr = v_byref_tcr - member _.outref_tcr = v_outref_tcr + member _.byref2_tcr = v_byref2_tcr - member _.inref_tcr = v_inref_tcr + member _.outref_tcr = v_outref_tcr - member _.nativeptr_tcr = v_nativeptr_tcr + member _.inref_tcr = v_inref_tcr - member _.voidptr_tcr = v_voidptr_tcr + member _.nativeptr_tcr = v_nativeptr_tcr - member _.ilsigptr_tcr = v_ilsigptr_tcr + member _.voidptr_tcr = v_voidptr_tcr - member _.fastFunc_tcr = v_fastFunc_tcr + member _.ilsigptr_tcr = v_ilsigptr_tcr - member _.MatchFailureException_tcr = v_mfe_tcr + member _.fastFunc_tcr = v_fastFunc_tcr + member _.MatchFailureException_tcr = v_mfe_tcr - member _.tcref_IObservable = v_tcref_IObservable + member _.tcref_IObservable = v_tcref_IObservable - member _.tcref_IObserver = v_tcref_IObserver + member _.tcref_IObserver = v_tcref_IObserver - member _.fslib_IEvent2_tcr = v_fslib_IEvent2_tcr + member _.fslib_IEvent2_tcr = v_fslib_IEvent2_tcr - member _.fslib_IDelegateEvent_tcr = v_fslib_IDelegateEvent_tcr + member _.fslib_IDelegateEvent_tcr = v_fslib_IDelegateEvent_tcr - member _.seq_tcr = v_seq_tcr + member _.seq_tcr = v_seq_tcr - member val seq_base_tcr = mk_MFCompilerServices_tcref fslibCcu "GeneratedSequenceBase`1" + member val seq_base_tcr = mk_MFCompilerServices_tcref fslibCcu "GeneratedSequenceBase`1" - member val ListCollector_tcr = mk_MFCompilerServices_tcref fslibCcu "ListCollector`1" + member val ListCollector_tcr = mk_MFCompilerServices_tcref fslibCcu "ListCollector`1" - member val ArrayCollector_tcr = mk_MFCompilerServices_tcref fslibCcu "ArrayCollector`1" + member val ArrayCollector_tcr = mk_MFCompilerServices_tcref fslibCcu "ArrayCollector`1" - member val SupportsWhenTEnum_tcr = mk_MFCompilerServices_tcref fslibCcu "SupportsWhenTEnum" + member val SupportsWhenTEnum_tcr = mk_MFCompilerServices_tcref fslibCcu "SupportsWhenTEnum" - member _.TryEmbedILType(tref: ILTypeRef, mkEmbeddableType: unit -> ILTypeDef) = - if tref.Scope = ILScopeRef.Local && not(embeddedILTypeDefs.ContainsKey(tref.Name)) then - embeddedILTypeDefs.TryAdd(tref.Name, mkEmbeddableType()) |> ignore + member _.TryEmbedILType(tref: ILTypeRef, mkEmbeddableType: unit -> ILTypeDef) = + if tref.Scope = ILScopeRef.Local && not (embeddedILTypeDefs.ContainsKey(tref.Name)) then + embeddedILTypeDefs.TryAdd(tref.Name, mkEmbeddableType ()) |> ignore - member g.mk_GeneratedSequenceBase_ty seqElemTy = TType_app(g.seq_base_tcr,[seqElemTy], v_knownWithoutNull) + member g.mk_GeneratedSequenceBase_ty seqElemTy = + TType_app(g.seq_base_tcr, [ seqElemTy ], v_knownWithoutNull) - member val ResumableStateMachine_tcr = mk_MFCompilerServices_tcref fslibCcu "ResumableStateMachine`1" + member val ResumableStateMachine_tcr = mk_MFCompilerServices_tcref fslibCcu "ResumableStateMachine`1" - member g.mk_ResumableStateMachine_ty dataTy = TType_app(g.ResumableStateMachine_tcr,[dataTy], v_knownWithoutNull) + member g.mk_ResumableStateMachine_ty dataTy = + TType_app(g.ResumableStateMachine_tcr, [ dataTy ], v_knownWithoutNull) - member val IResumableStateMachine_tcr = mk_MFCompilerServices_tcref fslibCcu "IResumableStateMachine`1" + member val IResumableStateMachine_tcr = mk_MFCompilerServices_tcref fslibCcu "IResumableStateMachine`1" - member g.mk_IResumableStateMachine_ty dataTy = TType_app(g.IResumableStateMachine_tcr,[dataTy], v_knownWithoutNull) + member g.mk_IResumableStateMachine_ty dataTy = + TType_app(g.IResumableStateMachine_tcr, [ dataTy ], v_knownWithoutNull) - member g.mk_ListCollector_ty seqElemTy = TType_app(g.ListCollector_tcr,[seqElemTy], v_knownWithoutNull) + member g.mk_ListCollector_ty seqElemTy = + TType_app(g.ListCollector_tcr, [ seqElemTy ], v_knownWithoutNull) - member g.mk_ArrayCollector_ty seqElemTy = TType_app(g.ArrayCollector_tcr,[seqElemTy], v_knownWithoutNull) + member g.mk_ArrayCollector_ty seqElemTy = + TType_app(g.ArrayCollector_tcr, [ seqElemTy ], v_knownWithoutNull) - member val byrefkind_In_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "In" + member val byrefkind_In_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "In" - member val byrefkind_Out_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "Out" + member val byrefkind_Out_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "Out" - member val byrefkind_InOut_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "InOut" + member val byrefkind_InOut_tcr = mkNonLocalTyconRef fslib_MFByRefKinds_nleref "InOut" - member val measureproduct_tcr = mk_MFCompilerServices_tcref fslibCcu "MeasureProduct`2" + member val measureproduct_tcr = mk_MFCompilerServices_tcref fslibCcu "MeasureProduct`2" - member val measureinverse_tcr = mk_MFCompilerServices_tcref fslibCcu "MeasureInverse`1" + member val measureinverse_tcr = mk_MFCompilerServices_tcref fslibCcu "MeasureInverse`1" - member val measureone_tcr = mk_MFCompilerServices_tcref fslibCcu "MeasureOne" + member val measureone_tcr = mk_MFCompilerServices_tcref fslibCcu "MeasureOne" - member val ResumableCode_tcr = mk_MFCompilerServices_tcref fslibCcu "ResumableCode`2" + member val ResumableCode_tcr = mk_MFCompilerServices_tcref fslibCcu "ResumableCode`2" - member _.il_arr_tcr_map = v_il_arr_tcr_map - member _.ref_tuple1_tcr = v_ref_tuple1_tcr - member _.ref_tuple2_tcr = v_ref_tuple2_tcr - member _.ref_tuple3_tcr = v_ref_tuple3_tcr - member _.ref_tuple4_tcr = v_ref_tuple4_tcr - member _.ref_tuple5_tcr = v_ref_tuple5_tcr - member _.ref_tuple6_tcr = v_ref_tuple6_tcr - member _.ref_tuple7_tcr = v_ref_tuple7_tcr - member _.ref_tuple8_tcr = v_ref_tuple8_tcr - member _.struct_tuple1_tcr = v_struct_tuple1_tcr - member _.struct_tuple2_tcr = v_struct_tuple2_tcr - member _.struct_tuple3_tcr = v_struct_tuple3_tcr - member _.struct_tuple4_tcr = v_struct_tuple4_tcr - member _.struct_tuple5_tcr = v_struct_tuple5_tcr - member _.struct_tuple6_tcr = v_struct_tuple6_tcr - member _.struct_tuple7_tcr = v_struct_tuple7_tcr - member _.struct_tuple8_tcr = v_struct_tuple8_tcr - member _.choice2_tcr = v_choice2_tcr - member _.choice3_tcr = v_choice3_tcr - member _.choice4_tcr = v_choice4_tcr - member _.choice5_tcr = v_choice5_tcr - member _.choice6_tcr = v_choice6_tcr - member _.choice7_tcr = v_choice7_tcr - member val nativeint_ty = v_nativeint_ty - member val unativeint_ty = v_unativeint_ty - member val int32_ty = v_int32_ty - member val int16_ty = v_int16_ty - member val int64_ty = v_int64_ty - member val uint16_ty = v_uint16_ty - member val uint32_ty = v_uint32_ty - member val uint64_ty = v_uint64_ty - member val sbyte_ty = v_sbyte_ty - member _.byte_ty = v_byte_ty - member _.bool_ty = v_bool_ty - member _.int_ty = v_int_ty - member _.string_ty = v_string_ty - member _.string_ty_ambivalent = v_string_ty_ambivalent - member _.system_IFormattable_tcref = v_IFormattable_tcref - member _.system_FormattableString_tcref = v_FormattableString_tcref - member _.system_IFormattable_ty = v_IFormattable_ty - member _.system_FormattableString_ty = v_FormattableString_ty - member _.system_FormattableStringFactory_ty = v_FormattableStringFactory_ty - member _.unit_ty = v_unit_ty - member _.obj_ty_noNulls = v_obj_ty_without_null - member _.obj_ty_ambivalent = v_obj_ty_ambivalent - member _.obj_ty_withNulls = v_obj_ty_with_null - member _.char_ty = v_char_ty - member _.decimal_ty = v_decimal_ty - - member val exn_ty = mkNonGenericTy v_exn_tcr - member val float_ty = v_float_ty - member val float32_ty = v_float32_ty - - /// Memoization table to help minimize the number of ILSourceDocument objects we create - member _.memoize_file x = v_memoize_file.Apply x - - member val system_Array_ty = mkSysNonGenericTy sys "Array" - member val system_Object_ty = mkSysNonGenericTy sys "Object" - member val system_IDisposable_ty = mkSysNonGenericTy sys "IDisposable" - member val system_IDisposableNull_ty = mkNonGenericTyWithNullness (findSysTyconRef sys "IDisposable") v_knownWithNull - member val system_RuntimeHelpers_ty = mkSysNonGenericTy sysCompilerServices "RuntimeHelpers" - member val system_Value_ty = mkSysNonGenericTy sys "ValueType" - member val system_Delegate_ty = mkSysNonGenericTy sys "Delegate" - member val system_MulticastDelegate_ty = mkSysNonGenericTy sys "MulticastDelegate" - member val system_Enum_ty = mkSysNonGenericTy sys "Enum" - member val system_String_tcref = findSysTyconRef sys "String" - member _.system_Type_ty = v_system_Type_ty - member val system_TypedReference_tcref = tryFindSysTyconRef sys "TypedReference" - member val system_ArgIterator_tcref = tryFindSysTyconRef sys "ArgIterator" - member val system_RuntimeArgumentHandle_tcref = tryFindSysTyconRef sys "RuntimeArgumentHandle" - member val system_SByte_tcref = findSysTyconRef sys "SByte" - member val system_Decimal_tcref = findSysTyconRef sys "Decimal" - member val system_Int16_tcref = findSysTyconRef sys "Int16" - member val system_Int32_tcref = findSysTyconRef sys "Int32" - member val system_Int64_tcref = findSysTyconRef sys "Int64" - member val system_IntPtr_tcref = findSysTyconRef sys "IntPtr" - member val system_Bool_tcref = findSysTyconRef sys "Boolean" - member val system_Byte_tcref = findSysTyconRef sys "Byte" - member val system_UInt16_tcref = findSysTyconRef sys "UInt16" - member val system_Char_tcref = findSysTyconRef sys "Char" - member val system_UInt32_tcref = findSysTyconRef sys "UInt32" - member val system_UInt64_tcref = findSysTyconRef sys "UInt64" - member val system_UIntPtr_tcref = findSysTyconRef sys "UIntPtr" - member val system_Single_tcref = findSysTyconRef sys "Single" - member val system_Double_tcref = findSysTyconRef sys "Double" - member val system_RuntimeTypeHandle_ty = mkSysNonGenericTy sys "RuntimeTypeHandle" - - member val system_MarshalByRefObject_tcref = tryFindSysTyconRef sys "MarshalByRefObject" - member val system_MarshalByRefObject_ty = tryMkSysNonGenericTy sys "MarshalByRefObject" - - member val system_ExceptionDispatchInfo_ty = - tryMkSysNonGenericTy ["System"; "Runtime"; "ExceptionServices"] "ExceptionDispatchInfo" - - member _.mk_IAsyncStateMachine_ty = mkSysNonGenericTy sysCompilerServices "IAsyncStateMachine" - - member val system_Object_tcref = findSysTyconRef sys "Object" - member val system_Value_tcref = findSysTyconRef sys "ValueType" - member val system_Void_tcref = findSysTyconRef sys "Void" - member val system_Nullable_tcref = v_nullable_tcr - member val system_GenericIComparable_tcref = findSysTyconRef sys "IComparable`1" - member val system_GenericIEquatable_tcref = findSysTyconRef sys "IEquatable`1" - member val mk_IComparable_ty = mkSysNonGenericTy sys "IComparable" - member val mk_Attribute_ty = mkSysNonGenericTy sys "Attribute" - member val system_LinqExpression_tcref = v_linqExpression_tcr - - member val mk_IStructuralComparable_ty = mkSysNonGenericTy sysCollections "IStructuralComparable" - - member val mk_IStructuralEquatable_ty = mkSysNonGenericTy sysCollections "IStructuralEquatable" - - member _.IComparer_ty = v_IComparer_ty - member _.IEqualityComparer_ty = v_IEqualityComparer_ty - member val tcref_System_Collections_IComparer = findSysTyconRef sysCollections "IComparer" - member val tcref_System_Collections_IEqualityComparer = findSysTyconRef sysCollections "IEqualityComparer" - member val tcref_System_Collections_Generic_IEqualityComparer = findSysTyconRef sysGenerics "IEqualityComparer`1" - member val tcref_System_Collections_Generic_Dictionary = findSysTyconRef sysGenerics "Dictionary`2" - - member val tcref_System_IComparable = findSysTyconRef sys "IComparable" - member val tcref_System_IStructuralComparable = findSysTyconRef sysCollections "IStructuralComparable" - member val tcref_System_IStructuralEquatable = findSysTyconRef sysCollections "IStructuralEquatable" - member val tcref_System_IDisposable = findSysTyconRef sys "IDisposable" - - member val tcref_LanguagePrimitives = mk_MFCore_tcref fslibCcu "LanguagePrimitives" - - member val tcref_System_Collections_Generic_IList = findSysTyconRef sysGenerics "IList`1" - member val tcref_System_Collections_Generic_IReadOnlyList = findSysTyconRef sysGenerics "IReadOnlyList`1" - member val tcref_System_Collections_Generic_ICollection = findSysTyconRef sysGenerics "ICollection`1" - member val tcref_System_Collections_Generic_IReadOnlyCollection = findSysTyconRef sysGenerics "IReadOnlyCollection`1" - member _.tcref_System_Collections_IEnumerable = v_tcref_System_Collections_IEnumerable - - member _.tcref_System_Collections_Generic_IEnumerable = v_IEnumerable_tcr - member _.tcref_System_Collections_Generic_IEnumerator = v_IEnumerator_tcr - - member _.tcref_System_Attribute = v_System_Attribute_tcr - - // Review: Does this need to be an option type? - member val System_Runtime_CompilerServices_RuntimeFeature_ty = tryFindSysTyconRef sysCompilerServices "RuntimeFeature" |> Option.map mkNonGenericTy - - member val iltyp_StreamingContext = tryFindSysILTypeRef tname_StreamingContext |> Option.map mkILNonGenericValueTy - member val iltyp_SerializationInfo = tryFindSysILTypeRef tname_SerializationInfo |> Option.map mkILNonGenericBoxedTy - member val iltyp_Missing = findSysILTypeRef tname_Missing |> mkILNonGenericBoxedTy - member val iltyp_AsyncCallback = findSysILTypeRef tname_AsyncCallback |> mkILNonGenericBoxedTy - member val iltyp_IAsyncResult = findSysILTypeRef tname_IAsyncResult |> mkILNonGenericBoxedTy - member val iltyp_IComparable = findSysILTypeRef tname_IComparable |> mkILNonGenericBoxedTy - member val iltyp_Exception = findSysILTypeRef tname_Exception |> mkILNonGenericBoxedTy - member val iltyp_ValueType = findSysILTypeRef tname_ValueType |> mkILNonGenericBoxedTy - member val iltyp_RuntimeFieldHandle = findSysILTypeRef tname_RuntimeFieldHandle |> mkILNonGenericValueTy - member val iltyp_RuntimeMethodHandle = findSysILTypeRef tname_RuntimeMethodHandle |> mkILNonGenericValueTy - member val iltyp_RuntimeTypeHandle = findSysILTypeRef tname_RuntimeTypeHandle |> mkILNonGenericValueTy - member val iltyp_ReferenceAssemblyAttributeOpt = tryFindSysILTypeRef tname_ReferenceAssemblyAttribute |> Option.map mkILNonGenericBoxedTy - member val iltyp_UnmanagedType = findSysILTypeRef tname_UnmanagedType |> mkILNonGenericValueTy - member val attrib_AttributeUsageAttribute = findSysAttrib "System.AttributeUsageAttribute" - member val attrib_ParamArrayAttribute = findSysAttrib "System.ParamArrayAttribute" - member val attrib_IDispatchConstantAttribute = tryFindSysAttrib "System.Runtime.CompilerServices.IDispatchConstantAttribute" - member val attrib_IUnknownConstantAttribute = tryFindSysAttrib "System.Runtime.CompilerServices.IUnknownConstantAttribute" - member val attrib_RequiresLocationAttribute = findSysAttrib "System.Runtime.CompilerServices.RequiresLocationAttribute" - - // We use 'findSysAttrib' here because lookup on attribute is done by name comparison, and can proceed - // even if the type is not found in a system assembly. - member val attrib_IsReadOnlyAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.IsReadOnlyAttribute" - member val attrib_IsUnmanagedAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.IsUnmanagedAttribute" - member val attrib_DynamicDependencyAttribute = findOrEmbedSysPublicType "System.Diagnostics.CodeAnalysis.DynamicDependencyAttribute" - member val attrib_NullableAttribute_opt = tryFindSysAttrib "System.Runtime.CompilerServices.NullableAttribute" - member val attrib_NullableContextAttribute_opt = tryFindSysAttrib "System.Runtime.CompilerServices.NullableContextAttribute" - member val attrib_NullableAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.NullableAttribute" - member val attrib_NullableContextAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.NullableContextAttribute" - member val attrib_MemberNotNullWhenAttribute = findOrEmbedSysPublicType "System.Diagnostics.CodeAnalysis.MemberNotNullWhenAttribute" - member val enum_DynamicallyAccessedMemberTypes = findOrEmbedSysPublicType "System.Diagnostics.CodeAnalysis.DynamicallyAccessedMemberTypes" - - member val attrib_SystemObsolete = findSysAttrib "System.ObsoleteAttribute" - member val attrib_DllImportAttribute = tryFindSysAttrib "System.Runtime.InteropServices.DllImportAttribute" - member val attrib_StructLayoutAttribute = findSysAttrib "System.Runtime.InteropServices.StructLayoutAttribute" - member val attrib_TypeForwardedToAttribute = findSysAttrib "System.Runtime.CompilerServices.TypeForwardedToAttribute" - member val attrib_ComVisibleAttribute = findSysAttrib "System.Runtime.InteropServices.ComVisibleAttribute" - member val attrib_ComImportAttribute = tryFindSysAttrib "System.Runtime.InteropServices.ComImportAttribute" - member val attrib_FieldOffsetAttribute = findSysAttrib "System.Runtime.InteropServices.FieldOffsetAttribute" - member val attrib_MarshalAsAttribute = tryFindSysAttrib "System.Runtime.InteropServices.MarshalAsAttribute" - member val attrib_InAttribute = findSysAttrib "System.Runtime.InteropServices.InAttribute" - member val attrib_OutAttribute = findSysAttrib "System.Runtime.InteropServices.OutAttribute" - member val attrib_OptionalAttribute = tryFindSysAttrib "System.Runtime.InteropServices.OptionalAttribute" - member val attrib_DefaultParameterValueAttribute = tryFindSysAttrib "System.Runtime.InteropServices.DefaultParameterValueAttribute" - member val attrib_ThreadStaticAttribute = tryFindSysAttrib "System.ThreadStaticAttribute" - member val attrib_VolatileFieldAttribute = mk_MFCore_attrib "VolatileFieldAttribute" - member val attrib_NoEagerConstraintApplicationAttribute = mk_MFCompilerServices_attrib "NoEagerConstraintApplicationAttribute" - member val attrib_ContextStaticAttribute = tryFindSysAttrib "System.ContextStaticAttribute" - member val attrib_FlagsAttribute = findSysAttrib "System.FlagsAttribute" - member val attrib_DefaultMemberAttribute = findSysAttrib "System.Reflection.DefaultMemberAttribute" - member val attrib_DebuggerDisplayAttribute = findSysAttrib "System.Diagnostics.DebuggerDisplayAttribute" - member val attrib_DebuggerTypeProxyAttribute = findSysAttrib "System.Diagnostics.DebuggerTypeProxyAttribute" - member val attrib_PreserveSigAttribute = tryFindSysAttrib "System.Runtime.InteropServices.PreserveSigAttribute" - member val attrib_MethodImplAttribute = findSysAttrib "System.Runtime.CompilerServices.MethodImplAttribute" - member val attrib_ExtensionAttribute = findSysAttrib "System.Runtime.CompilerServices.ExtensionAttribute" - member val attrib_CallerLineNumberAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerLineNumberAttribute" - member val attrib_CallerFilePathAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerFilePathAttribute" - member val attrib_CallerMemberNameAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerMemberNameAttribute" - member val attrib_SkipLocalsInitAttribute = findSysAttrib "System.Runtime.CompilerServices.SkipLocalsInitAttribute" - member val attrib_DecimalConstantAttribute = findSysAttrib "System.Runtime.CompilerServices.DecimalConstantAttribute" - member val attribs_Unsupported = v_attribs_Unsupported - - member val attrib_ProjectionParameterAttribute = mk_MFCore_attrib "ProjectionParameterAttribute" - member val attrib_CustomOperationAttribute = mk_MFCore_attrib "CustomOperationAttribute" - member val attrib_NonSerializedAttribute = tryFindSysAttrib "System.NonSerializedAttribute" - - member val attrib_AutoSerializableAttribute = mk_MFCore_attrib "AutoSerializableAttribute" - member val attrib_RequireQualifiedAccessAttribute = mk_MFCore_attrib "RequireQualifiedAccessAttribute" - member val attrib_EntryPointAttribute = mk_MFCore_attrib "EntryPointAttribute" - member val attrib_DefaultAugmentationAttribute = mk_MFCore_attrib "DefaultAugmentationAttribute" - member val attrib_CompilerMessageAttribute = mk_MFCore_attrib "CompilerMessageAttribute" - member val attrib_ExperimentalAttribute = mk_MFCore_attrib "ExperimentalAttribute" - member val attrib_UnverifiableAttribute = mk_MFCore_attrib "UnverifiableAttribute" - member val attrib_LiteralAttribute = mk_MFCore_attrib "LiteralAttribute" - member val attrib_ConditionalAttribute = findSysAttrib "System.Diagnostics.ConditionalAttribute" - member val attrib_OptionalArgumentAttribute = mk_MFCore_attrib "OptionalArgumentAttribute" - member val attrib_RequiresExplicitTypeArgumentsAttribute = mk_MFCore_attrib "RequiresExplicitTypeArgumentsAttribute" - member val attrib_DefaultValueAttribute = mk_MFCore_attrib "DefaultValueAttribute" - member val attrib_ClassAttribute = mk_MFCore_attrib "ClassAttribute" - member val attrib_InterfaceAttribute = mk_MFCore_attrib "InterfaceAttribute" - member val attrib_StructAttribute = mk_MFCore_attrib "StructAttribute" - member val attrib_ReflectedDefinitionAttribute = mk_MFCore_attrib "ReflectedDefinitionAttribute" - member val attrib_CompiledNameAttribute = mk_MFCore_attrib "CompiledNameAttribute" - member val attrib_AutoOpenAttribute = mk_MFCore_attrib "AutoOpenAttribute" - member val attrib_InternalsVisibleToAttribute = findSysAttrib tname_InternalsVisibleToAttribute - member val attrib_CompilationRepresentationAttribute = mk_MFCore_attrib "CompilationRepresentationAttribute" - member val attrib_CompilationArgumentCountsAttribute = mk_MFCore_attrib "CompilationArgumentCountsAttribute" - member val attrib_CompilationMappingAttribute = mk_MFCore_attrib "CompilationMappingAttribute" - member val attrib_CLIEventAttribute = mk_MFCore_attrib "CLIEventAttribute" - member val attrib_InlineIfLambdaAttribute = mk_MFCore_attrib "InlineIfLambdaAttribute" - member val attrib_CLIMutableAttribute = mk_MFCore_attrib "CLIMutableAttribute" - member val attrib_AllowNullLiteralAttribute = mk_MFCore_attrib "AllowNullLiteralAttribute" - member val attrib_NoEqualityAttribute = mk_MFCore_attrib "NoEqualityAttribute" - member val attrib_NoComparisonAttribute = mk_MFCore_attrib "NoComparisonAttribute" - member val attrib_CustomEqualityAttribute = mk_MFCore_attrib "CustomEqualityAttribute" - member val attrib_CustomComparisonAttribute = mk_MFCore_attrib "CustomComparisonAttribute" - member val attrib_EqualityConditionalOnAttribute = mk_MFCore_attrib "EqualityConditionalOnAttribute" - member val attrib_ComparisonConditionalOnAttribute = mk_MFCore_attrib "ComparisonConditionalOnAttribute" - member val attrib_ReferenceEqualityAttribute = mk_MFCore_attrib "ReferenceEqualityAttribute" - member val attrib_StructuralEqualityAttribute = mk_MFCore_attrib "StructuralEqualityAttribute" - member val attrib_StructuralComparisonAttribute = mk_MFCore_attrib "StructuralComparisonAttribute" - member val attrib_SealedAttribute = mk_MFCore_attrib "SealedAttribute" - member val attrib_AbstractClassAttribute = mk_MFCore_attrib "AbstractClassAttribute" - member val attrib_GeneralizableValueAttribute = mk_MFCore_attrib "GeneralizableValueAttribute" - member val attrib_MeasureAttribute = mk_MFCore_attrib "MeasureAttribute" - member val attrib_MeasureableAttribute = mk_MFCore_attrib "MeasureAnnotatedAbbreviationAttribute" - member val attrib_NoDynamicInvocationAttribute = mk_MFCore_attrib "NoDynamicInvocationAttribute" - member val attrib_NoCompilerInliningAttribute = mk_MFCore_attrib "NoCompilerInliningAttribute" - member val attrib_WarnOnWithoutNullArgumentAttribute = mk_MFCore_attrib "WarnOnWithoutNullArgumentAttribute" - member val attrib_SecurityAttribute = tryFindSysAttrib "System.Security.Permissions.SecurityAttribute" - member val attrib_SecurityCriticalAttribute = findSysAttrib "System.Security.SecurityCriticalAttribute" - member val attrib_SecuritySafeCriticalAttribute = findSysAttrib "System.Security.SecuritySafeCriticalAttribute" - member val attrib_ComponentModelEditorBrowsableAttribute = findSysAttrib "System.ComponentModel.EditorBrowsableAttribute" - member val attrib_CompilerFeatureRequiredAttribute = findSysAttrib "System.Runtime.CompilerServices.CompilerFeatureRequiredAttribute" - member val attrib_SetsRequiredMembersAttribute = findSysAttrib "System.Diagnostics.CodeAnalysis.SetsRequiredMembersAttribute" - member val attrib_RequiredMemberAttribute = findSysAttrib "System.Runtime.CompilerServices.RequiredMemberAttribute" - member val attrib_IlExperimentalAttribute = findSysAttrib "System.Diagnostics.CodeAnalysis.ExperimentalAttribute" - - member g.improveType tcref tinst = improveTy tcref tinst - - member g.decompileType tcref tinst = decompileTy tcref tinst - - member _.new_decimal_info = v_new_decimal_info - member _.seq_info = v_seq_info - member val seq_vref = (ValRefForIntrinsic v_seq_info) - member val and_vref = (ValRefForIntrinsic v_and_info) - member val and2_vref = (ValRefForIntrinsic v_and2_info) - member val addrof_vref = (ValRefForIntrinsic v_addrof_info) - member val addrof2_vref = (ValRefForIntrinsic v_addrof2_info) - member val or_vref = (ValRefForIntrinsic v_or_info) - member val splice_expr_vref = (ValRefForIntrinsic v_splice_expr_info) - member val splice_raw_expr_vref = (ValRefForIntrinsic v_splice_raw_expr_info) - member val or2_vref = (ValRefForIntrinsic v_or2_info) - member val generic_equality_er_inner_vref = ValRefForIntrinsic v_generic_equality_er_inner_info - member val generic_equality_per_inner_vref = ValRefForIntrinsic v_generic_equality_per_inner_info - member val generic_equality_withc_inner_vref = ValRefForIntrinsic v_generic_equality_withc_inner_info - member val generic_comparison_inner_vref = ValRefForIntrinsic v_generic_comparison_inner_info - member val generic_comparison_withc_inner_vref = ValRefForIntrinsic v_generic_comparison_withc_inner_info - member _.generic_comparison_withc_outer_info = v_generic_comparison_withc_outer_info - member _.generic_equality_er_outer_info = v_generic_equality_er_outer_info - member _.generic_equality_withc_outer_info = v_generic_equality_withc_outer_info - member _.generic_hash_withc_outer_info = v_generic_hash_withc_outer_info - member val generic_hash_inner_vref = ValRefForIntrinsic v_generic_hash_inner_info - member val generic_hash_withc_inner_vref = ValRefForIntrinsic v_generic_hash_withc_inner_info - - member val reference_equality_inner_vref = ValRefForIntrinsic v_reference_equality_inner_info - - member val piperight_vref = ValRefForIntrinsic v_piperight_info - member val piperight2_vref = ValRefForIntrinsic v_piperight2_info - member val piperight3_vref = ValRefForIntrinsic v_piperight3_info - member val bitwise_or_vref = ValRefForIntrinsic v_bitwise_or_info - member val bitwise_and_vref = ValRefForIntrinsic v_bitwise_and_info - member val bitwise_xor_vref = ValRefForIntrinsic v_bitwise_xor_info - member val bitwise_unary_not_vref = ValRefForIntrinsic v_bitwise_unary_not_info - member val bitwise_shift_left_vref = ValRefForIntrinsic v_bitwise_shift_left_info - member val bitwise_shift_right_vref = ValRefForIntrinsic v_bitwise_shift_right_info - member val exponentiation_vref = ValRefForIntrinsic v_exponentiation_info - member val unchecked_addition_vref = ValRefForIntrinsic v_unchecked_addition_info - member val unchecked_unary_plus_vref = ValRefForIntrinsic v_unchecked_unary_plus_info - member val unchecked_unary_minus_vref = ValRefForIntrinsic v_unchecked_unary_minus_info - member val unchecked_unary_not_vref = ValRefForIntrinsic v_unchecked_unary_not_info - member val unchecked_subtraction_vref = ValRefForIntrinsic v_unchecked_subtraction_info - member val unchecked_multiply_vref = ValRefForIntrinsic v_unchecked_multiply_info - member val unchecked_division_vref = ValRefForIntrinsic v_unchecked_division_info - member val unchecked_modulus_vref = ValRefForIntrinsic v_unchecked_modulus_info - member val unchecked_defaultof_vref = ValRefForIntrinsic v_unchecked_defaultof_info - member val refcell_deref_vref = ValRefForIntrinsic v_refcell_deref_info - member val refcell_assign_vref = ValRefForIntrinsic v_refcell_assign_info - member val refcell_incr_vref = ValRefForIntrinsic v_refcell_incr_info - member val refcell_decr_vref = ValRefForIntrinsic v_refcell_decr_info - - member _.bitwise_or_info = v_bitwise_or_info - member _.bitwise_and_info = v_bitwise_and_info - member _.bitwise_xor_info = v_bitwise_xor_info - member _.bitwise_unary_not_info = v_bitwise_unary_not_info - member _.bitwise_shift_left_info = v_bitwise_shift_left_info - member _.bitwise_shift_right_info = v_bitwise_shift_right_info - member _.unchecked_addition_info = v_unchecked_addition_info - member _.unchecked_subtraction_info = v_unchecked_subtraction_info - member _.unchecked_multiply_info = v_unchecked_multiply_info - member _.unchecked_division_info = v_unchecked_division_info - member _.unchecked_modulus_info = v_unchecked_modulus_info - member _.unchecked_unary_minus_info = v_unchecked_unary_minus_info - member _.unchecked_defaultof_info = v_unchecked_defaultof_info - - member _.checked_addition_info = v_checked_addition_info - member _.checked_subtraction_info = v_checked_subtraction_info - member _.checked_multiply_info = v_checked_multiply_info - member _.checked_unary_minus_info = v_checked_unary_minus_info - - member _.byte_checked_info = v_byte_checked_info - member _.sbyte_checked_info = v_sbyte_checked_info - member _.int16_checked_info = v_int16_checked_info - member _.uint16_checked_info = v_uint16_checked_info - member _.int_checked_info = v_int_checked_info - member _.int32_checked_info = v_int32_checked_info - member _.uint32_checked_info = v_uint32_checked_info - member _.int64_checked_info = v_int64_checked_info - member _.uint64_checked_info = v_uint64_checked_info - member _.nativeint_checked_info = v_nativeint_checked_info - member _.unativeint_checked_info = v_unativeint_checked_info - - member _.byte_operator_info = v_byte_operator_info - member _.sbyte_operator_info = v_sbyte_operator_info - member _.int16_operator_info = v_int16_operator_info - member _.uint16_operator_info = v_uint16_operator_info - member _.int32_operator_info = v_int32_operator_info - member _.uint32_operator_info = v_uint32_operator_info - member _.int64_operator_info = v_int64_operator_info - member _.uint64_operator_info = v_uint64_operator_info - member _.float32_operator_info = v_float32_operator_info - member _.float_operator_info = v_float_operator_info - member _.nativeint_operator_info = v_nativeint_operator_info - member _.unativeint_operator_info = v_unativeint_operator_info - - member _.char_operator_info = v_char_operator_info - member _.enum_operator_info = v_enum_operator_info - - member val compare_operator_vref = ValRefForIntrinsic v_compare_operator_info - member val equals_operator_vref = ValRefForIntrinsic v_equals_operator_info - member val equals_nullable_operator_vref = ValRefForIntrinsic v_equals_nullable_operator_info - member val nullable_equals_nullable_operator_vref = ValRefForIntrinsic v_nullable_equals_nullable_operator_info - member val nullable_equals_operator_vref = ValRefForIntrinsic v_nullable_equals_operator_info - member val not_equals_operator_vref = ValRefForIntrinsic v_not_equals_operator_info - member val less_than_operator_vref = ValRefForIntrinsic v_less_than_operator_info - member val less_than_or_equals_operator_vref = ValRefForIntrinsic v_less_than_or_equals_operator_info - member val greater_than_operator_vref = ValRefForIntrinsic v_greater_than_operator_info - member val greater_than_or_equals_operator_vref = ValRefForIntrinsic v_greater_than_or_equals_operator_info - - member val raise_vref = ValRefForIntrinsic v_raise_info - member val failwith_vref = ValRefForIntrinsic v_failwith_info - member val invalid_arg_vref = ValRefForIntrinsic v_invalid_arg_info - member val null_arg_vref = ValRefForIntrinsic v_null_arg_info - member val invalid_op_vref = ValRefForIntrinsic v_invalid_op_info - member val failwithf_vref = ValRefForIntrinsic v_failwithf_info - - member _.equals_operator_info = v_equals_operator_info - member _.not_equals_operator = v_not_equals_operator_info - member _.less_than_operator = v_less_than_operator_info - member _.less_than_or_equals_operator = v_less_than_or_equals_operator_info - member _.greater_than_operator = v_greater_than_operator_info - member _.greater_than_or_equals_operator = v_greater_than_or_equals_operator_info - - member _.hash_info = v_hash_info - member _.box_info = v_box_info - member _.isnull_info = v_isnull_info - member _.raise_info = v_raise_info - member _.reraise_info = v_reraise_info - member _.typeof_info = v_typeof_info - member _.typedefof_info = v_typedefof_info - - member val reraise_vref = ValRefForIntrinsic v_reraise_info - member val methodhandleof_vref = ValRefForIntrinsic v_methodhandleof_info - member val typeof_vref = ValRefForIntrinsic v_typeof_info - member val sizeof_vref = ValRefForIntrinsic v_sizeof_info - member val nameof_vref = ValRefForIntrinsic v_nameof_info - member val typedefof_vref = ValRefForIntrinsic v_typedefof_info - member val enum_vref = ValRefForIntrinsic v_enum_operator_info - member val enumOfValue_vref = ValRefForIntrinsic v_enumOfValue_info - member val range_op_vref = ValRefForIntrinsic v_range_op_info - member val range_step_op_vref = ValRefForIntrinsic v_range_step_op_info - member val range_int32_op_vref = ValRefForIntrinsic v_range_int32_op_info - member val range_int64_op_vref = ValRefForIntrinsic v_range_int64_op_info - member val range_uint64_op_vref = ValRefForIntrinsic v_range_uint64_op_info - member val range_uint32_op_vref = ValRefForIntrinsic v_range_uint32_op_info - member val range_nativeint_op_vref = ValRefForIntrinsic v_range_nativeint_op_info - member val range_unativeint_op_vref = ValRefForIntrinsic v_range_unativeint_op_info - member val range_int16_op_vref = ValRefForIntrinsic v_range_int16_op_info - member val range_uint16_op_vref = ValRefForIntrinsic v_range_uint16_op_info - member val range_sbyte_op_vref = ValRefForIntrinsic v_range_sbyte_op_info - member val range_byte_op_vref = ValRefForIntrinsic v_range_byte_op_info - member val range_char_op_vref = ValRefForIntrinsic v_range_char_op_info - member val range_generic_op_vref = ValRefForIntrinsic v_range_generic_op_info - member val range_step_generic_op_vref = ValRefForIntrinsic v_range_step_generic_op_info - member val array_get_vref = ValRefForIntrinsic v_array_get_info - member val array2D_get_vref = ValRefForIntrinsic v_array2D_get_info - member val array3D_get_vref = ValRefForIntrinsic v_array3D_get_info - member val array4D_get_vref = ValRefForIntrinsic v_array4D_get_info - member val seq_singleton_vref = ValRefForIntrinsic v_seq_singleton_info - member val seq_collect_vref = ValRefForIntrinsic v_seq_collect_info - member val nativeptr_tobyref_vref = ValRefForIntrinsic v_nativeptr_tobyref_info - member val seq_using_vref = ValRefForIntrinsic v_seq_using_info - member val seq_delay_vref = ValRefForIntrinsic v_seq_delay_info - member val seq_append_vref = ValRefForIntrinsic v_seq_append_info - member val seq_generated_vref = ValRefForIntrinsic v_seq_generated_info - member val seq_finally_vref = ValRefForIntrinsic v_seq_finally_info - member val seq_map_vref = ValRefForIntrinsic v_seq_map_info - member val seq_empty_vref = ValRefForIntrinsic v_seq_empty_info - member val new_format_vref = ValRefForIntrinsic v_new_format_info - member val sprintf_vref = ValRefForIntrinsic v_sprintf_info - member val unbox_vref = ValRefForIntrinsic v_unbox_info - member val unbox_fast_vref = ValRefForIntrinsic v_unbox_fast_info - member val istype_vref = ValRefForIntrinsic v_istype_info - member val istype_fast_vref = ValRefForIntrinsic v_istype_fast_info - member val query_source_vref = ValRefForIntrinsic v_query_source_info - member val query_value_vref = ValRefForIntrinsic v_query_value_info - member val query_run_value_vref = ValRefForIntrinsic v_query_run_value_info - member val query_run_enumerable_vref = ValRefForIntrinsic v_query_run_enumerable_info - member val query_for_vref = ValRefForIntrinsic v_query_for_value_info - member val query_yield_vref = ValRefForIntrinsic v_query_yield_value_info - member val query_yield_from_vref = ValRefForIntrinsic v_query_yield_from_value_info - member val query_select_vref = ValRefForIntrinsic v_query_select_value_info - member val query_zero_vref = ValRefForIntrinsic v_query_zero_value_info - member val seq_to_list_vref = ValRefForIntrinsic v_seq_to_list_info - member val seq_to_array_vref = ValRefForIntrinsic v_seq_to_array_info - - member _.seq_collect_info = v_seq_collect_info - member _.seq_using_info = v_seq_using_info - member _.seq_delay_info = v_seq_delay_info - member _.seq_append_info = v_seq_append_info - member _.seq_generated_info = v_seq_generated_info - member _.seq_finally_info = v_seq_finally_info - member _.seq_trywith_info = v_seq_trywith_info - member _.seq_of_functions_info = v_seq_of_functions_info - member _.seq_map_info = v_seq_map_info - member _.seq_singleton_info = v_seq_singleton_info - member _.seq_empty_info = v_seq_empty_info - member _.sprintf_info = v_sprintf_info - member _.new_format_info = v_new_format_info - member _.unbox_info = v_unbox_info - member _.get_generic_comparer_info = v_get_generic_comparer_info - member _.get_generic_er_equality_comparer_info = v_get_generic_er_equality_comparer_info - member _.get_generic_per_equality_comparer_info = v_get_generic_per_equality_comparer_info - member _.dispose_info = v_dispose_info - member _.getstring_info = v_getstring_info - member _.unbox_fast_info = v_unbox_fast_info - member _.istype_info = v_istype_info - member _.lazy_force_info = v_lazy_force_info - member _.lazy_create_info = v_lazy_create_info - member _.create_instance_info = v_create_instance_info - member _.create_event_info = v_create_event_info - member _.seq_to_list_info = v_seq_to_list_info - member _.seq_to_array_info = v_seq_to_array_info - - member _.array_length_info = v_array_length_info - member _.array_get_info = v_array_get_info - member _.array2D_get_info = v_array2D_get_info - member _.array3D_get_info = v_array3D_get_info - member _.array4D_get_info = v_array4D_get_info - member _.array_set_info = v_array_set_info - member _.array2D_set_info = v_array2D_set_info - member _.array3D_set_info = v_array3D_set_info - member _.array4D_set_info = v_array4D_set_info - - member val option_toNullable_info = v_option_toNullable_info - member val option_defaultValue_info = v_option_defaultValue_info - - member _.deserialize_quoted_FSharp_20_plus_info = v_deserialize_quoted_FSharp_20_plus_info - member _.deserialize_quoted_FSharp_40_plus_info = v_deserialize_quoted_FSharp_40_plus_info - member _.call_with_witnesses_info = v_call_with_witnesses_info - member _.cast_quotation_info = v_cast_quotation_info - member _.lift_value_info = v_lift_value_info - member _.lift_value_with_name_info = v_lift_value_with_name_info - member _.lift_value_with_defn_info = v_lift_value_with_defn_info - member _.query_source_as_enum_info = v_query_source_as_enum_info - member _.new_query_source_info = v_new_query_source_info - member _.query_builder_tcref = v_query_builder_tcref - member _.fail_init_info = v_fail_init_info - member _.fail_static_init_info = v_fail_static_init_info - member _.check_this_info = v_check_this_info - member _.quote_to_linq_lambda_info = v_quote_to_linq_lambda_info - - - member val cgh__stateMachine_vref = ValRefForIntrinsic v_cgh__stateMachine_info - member val cgh__useResumableCode_vref = ValRefForIntrinsic v_cgh__useResumableCode_info - member val cgh__debugPoint_vref = ValRefForIntrinsic v_cgh__debugPoint_info - member val cgh__resumeAt_vref = ValRefForIntrinsic v_cgh__resumeAt_info - member val cgh__resumableEntry_vref = ValRefForIntrinsic v_cgh__resumableEntry_info - - member val generic_hash_withc_tuple2_vref = ValRefForIntrinsic v_generic_hash_withc_tuple2_info - member val generic_hash_withc_tuple3_vref = ValRefForIntrinsic v_generic_hash_withc_tuple3_info - member val generic_hash_withc_tuple4_vref = ValRefForIntrinsic v_generic_hash_withc_tuple4_info - member val generic_hash_withc_tuple5_vref = ValRefForIntrinsic v_generic_hash_withc_tuple5_info - member val generic_equals_withc_tuple2_vref = ValRefForIntrinsic v_generic_equals_withc_tuple2_info - member val generic_equals_withc_tuple3_vref = ValRefForIntrinsic v_generic_equals_withc_tuple3_info - member val generic_equals_withc_tuple4_vref = ValRefForIntrinsic v_generic_equals_withc_tuple4_info - member val generic_equals_withc_tuple5_vref = ValRefForIntrinsic v_generic_equals_withc_tuple5_info - member val generic_compare_withc_tuple2_vref = ValRefForIntrinsic v_generic_compare_withc_tuple2_info - member val generic_compare_withc_tuple3_vref = ValRefForIntrinsic v_generic_compare_withc_tuple3_info - member val generic_compare_withc_tuple4_vref = ValRefForIntrinsic v_generic_compare_withc_tuple4_info - member val generic_compare_withc_tuple5_vref = ValRefForIntrinsic v_generic_compare_withc_tuple5_info - member val generic_equality_withc_outer_vref = ValRefForIntrinsic v_generic_equality_withc_outer_info - - - member _.cons_ucref = v_cons_ucref - member _.nil_ucref = v_nil_ucref + member _.il_arr_tcr_map = v_il_arr_tcr_map + member _.ref_tuple1_tcr = v_ref_tuple1_tcr + member _.ref_tuple2_tcr = v_ref_tuple2_tcr + member _.ref_tuple3_tcr = v_ref_tuple3_tcr + member _.ref_tuple4_tcr = v_ref_tuple4_tcr + member _.ref_tuple5_tcr = v_ref_tuple5_tcr + member _.ref_tuple6_tcr = v_ref_tuple6_tcr + member _.ref_tuple7_tcr = v_ref_tuple7_tcr + member _.ref_tuple8_tcr = v_ref_tuple8_tcr + member _.struct_tuple1_tcr = v_struct_tuple1_tcr + member _.struct_tuple2_tcr = v_struct_tuple2_tcr + member _.struct_tuple3_tcr = v_struct_tuple3_tcr + member _.struct_tuple4_tcr = v_struct_tuple4_tcr + member _.struct_tuple5_tcr = v_struct_tuple5_tcr + member _.struct_tuple6_tcr = v_struct_tuple6_tcr + member _.struct_tuple7_tcr = v_struct_tuple7_tcr + member _.struct_tuple8_tcr = v_struct_tuple8_tcr + member _.choice2_tcr = v_choice2_tcr + member _.choice3_tcr = v_choice3_tcr + member _.choice4_tcr = v_choice4_tcr + member _.choice5_tcr = v_choice5_tcr + member _.choice6_tcr = v_choice6_tcr + member _.choice7_tcr = v_choice7_tcr + member val nativeint_ty = v_nativeint_ty + member val unativeint_ty = v_unativeint_ty + member val int32_ty = v_int32_ty + member val int16_ty = v_int16_ty + member val int64_ty = v_int64_ty + member val uint16_ty = v_uint16_ty + member val uint32_ty = v_uint32_ty + member val uint64_ty = v_uint64_ty + member val sbyte_ty = v_sbyte_ty + member _.byte_ty = v_byte_ty + member _.bool_ty = v_bool_ty + member _.int_ty = v_int_ty + member _.string_ty = v_string_ty + member _.string_ty_ambivalent = v_string_ty_ambivalent + member _.system_IFormattable_tcref = v_IFormattable_tcref + member _.system_FormattableString_tcref = v_FormattableString_tcref + member _.system_IFormattable_ty = v_IFormattable_ty + member _.system_FormattableString_ty = v_FormattableString_ty + member _.system_FormattableStringFactory_ty = v_FormattableStringFactory_ty + member _.unit_ty = v_unit_ty + member _.obj_ty_noNulls = v_obj_ty_without_null + member _.obj_ty_ambivalent = v_obj_ty_ambivalent + member _.obj_ty_withNulls = v_obj_ty_with_null + member _.char_ty = v_char_ty + member _.decimal_ty = v_decimal_ty + + member val exn_ty = mkNonGenericTy v_exn_tcr + member val float_ty = v_float_ty + member val float32_ty = v_float32_ty + + /// Memoization table to help minimize the number of ILSourceDocument objects we create + member _.memoize_file x = v_memoize_file.Apply x + + member val system_Array_ty = mkSysNonGenericTy sys "Array" + member val system_Object_ty = mkSysNonGenericTy sys "Object" + member val system_IDisposable_ty = mkSysNonGenericTy sys "IDisposable" + member val system_IDisposableNull_ty = mkNonGenericTyWithNullness (findSysTyconRef sys "IDisposable") v_knownWithNull + member val system_RuntimeHelpers_ty = mkSysNonGenericTy sysCompilerServices "RuntimeHelpers" + member val system_Value_ty = mkSysNonGenericTy sys "ValueType" + member val system_Delegate_ty = mkSysNonGenericTy sys "Delegate" + member val system_MulticastDelegate_ty = mkSysNonGenericTy sys "MulticastDelegate" + member val system_Enum_ty = mkSysNonGenericTy sys "Enum" + member val system_String_tcref = findSysTyconRef sys "String" + member _.system_Type_ty = v_system_Type_ty + member val system_TypedReference_tcref = tryFindSysTyconRef sys "TypedReference" + member val system_ArgIterator_tcref = tryFindSysTyconRef sys "ArgIterator" + member val system_RuntimeArgumentHandle_tcref = tryFindSysTyconRef sys "RuntimeArgumentHandle" + member val system_SByte_tcref = findSysTyconRef sys "SByte" + member val system_Decimal_tcref = findSysTyconRef sys "Decimal" + member val system_Int16_tcref = findSysTyconRef sys "Int16" + member val system_Int32_tcref = findSysTyconRef sys "Int32" + member val system_Int64_tcref = findSysTyconRef sys "Int64" + member val system_IntPtr_tcref = findSysTyconRef sys "IntPtr" + member val system_Bool_tcref = findSysTyconRef sys "Boolean" + member val system_Byte_tcref = findSysTyconRef sys "Byte" + member val system_UInt16_tcref = findSysTyconRef sys "UInt16" + member val system_Char_tcref = findSysTyconRef sys "Char" + member val system_UInt32_tcref = findSysTyconRef sys "UInt32" + member val system_UInt64_tcref = findSysTyconRef sys "UInt64" + member val system_UIntPtr_tcref = findSysTyconRef sys "UIntPtr" + member val system_Single_tcref = findSysTyconRef sys "Single" + member val system_Double_tcref = findSysTyconRef sys "Double" + member val system_RuntimeTypeHandle_ty = mkSysNonGenericTy sys "RuntimeTypeHandle" + + member val system_MarshalByRefObject_tcref = tryFindSysTyconRef sys "MarshalByRefObject" + member val system_MarshalByRefObject_ty = tryMkSysNonGenericTy sys "MarshalByRefObject" + + member val system_ExceptionDispatchInfo_ty = tryMkSysNonGenericTy [ "System"; "Runtime"; "ExceptionServices" ] "ExceptionDispatchInfo" + + member _.mk_IAsyncStateMachine_ty = + mkSysNonGenericTy sysCompilerServices "IAsyncStateMachine" + + member val system_Object_tcref = findSysTyconRef sys "Object" + member val system_Value_tcref = findSysTyconRef sys "ValueType" + member val system_Void_tcref = findSysTyconRef sys "Void" + member val system_Nullable_tcref = v_nullable_tcr + member val system_GenericIComparable_tcref = findSysTyconRef sys "IComparable`1" + member val system_GenericIEquatable_tcref = findSysTyconRef sys "IEquatable`1" + member val mk_IComparable_ty = mkSysNonGenericTy sys "IComparable" + member val mk_Attribute_ty = mkSysNonGenericTy sys "Attribute" + member val system_LinqExpression_tcref = v_linqExpression_tcr + + member val mk_IStructuralComparable_ty = mkSysNonGenericTy sysCollections "IStructuralComparable" + + member val mk_IStructuralEquatable_ty = mkSysNonGenericTy sysCollections "IStructuralEquatable" + + member _.IComparer_ty = v_IComparer_ty + member _.IEqualityComparer_ty = v_IEqualityComparer_ty + member val tcref_System_Collections_IComparer = findSysTyconRef sysCollections "IComparer" + member val tcref_System_Collections_IEqualityComparer = findSysTyconRef sysCollections "IEqualityComparer" + member val tcref_System_Collections_Generic_IEqualityComparer = findSysTyconRef sysGenerics "IEqualityComparer`1" + member val tcref_System_Collections_Generic_Dictionary = findSysTyconRef sysGenerics "Dictionary`2" + + member val tcref_System_IComparable = findSysTyconRef sys "IComparable" + member val tcref_System_IStructuralComparable = findSysTyconRef sysCollections "IStructuralComparable" + member val tcref_System_IStructuralEquatable = findSysTyconRef sysCollections "IStructuralEquatable" + member val tcref_System_IDisposable = findSysTyconRef sys "IDisposable" + + member val tcref_LanguagePrimitives = mk_MFCore_tcref fslibCcu "LanguagePrimitives" + + member val tcref_System_Collections_Generic_IList = findSysTyconRef sysGenerics "IList`1" + member val tcref_System_Collections_Generic_IReadOnlyList = findSysTyconRef sysGenerics "IReadOnlyList`1" + member val tcref_System_Collections_Generic_ICollection = findSysTyconRef sysGenerics "ICollection`1" + member val tcref_System_Collections_Generic_IReadOnlyCollection = findSysTyconRef sysGenerics "IReadOnlyCollection`1" + member _.tcref_System_Collections_IEnumerable = v_tcref_System_Collections_IEnumerable + + member _.tcref_System_Collections_Generic_IEnumerable = v_IEnumerable_tcr + member _.tcref_System_Collections_Generic_IEnumerator = v_IEnumerator_tcr + + member _.tcref_System_Attribute = v_System_Attribute_tcr + + // Review: Does this need to be an option type? + member val System_Runtime_CompilerServices_RuntimeFeature_ty = + tryFindSysTyconRef sysCompilerServices "RuntimeFeature" + |> Option.map mkNonGenericTy + + member val iltyp_StreamingContext = tryFindSysILTypeRef tname_StreamingContext |> Option.map mkILNonGenericValueTy + member val iltyp_SerializationInfo = tryFindSysILTypeRef tname_SerializationInfo |> Option.map mkILNonGenericBoxedTy + member val iltyp_Missing = findSysILTypeRef tname_Missing |> mkILNonGenericBoxedTy + member val iltyp_AsyncCallback = findSysILTypeRef tname_AsyncCallback |> mkILNonGenericBoxedTy + member val iltyp_IAsyncResult = findSysILTypeRef tname_IAsyncResult |> mkILNonGenericBoxedTy + member val iltyp_IComparable = findSysILTypeRef tname_IComparable |> mkILNonGenericBoxedTy + member val iltyp_Exception = findSysILTypeRef tname_Exception |> mkILNonGenericBoxedTy + member val iltyp_ValueType = findSysILTypeRef tname_ValueType |> mkILNonGenericBoxedTy + member val iltyp_RuntimeFieldHandle = findSysILTypeRef tname_RuntimeFieldHandle |> mkILNonGenericValueTy + member val iltyp_RuntimeMethodHandle = findSysILTypeRef tname_RuntimeMethodHandle |> mkILNonGenericValueTy + member val iltyp_RuntimeTypeHandle = findSysILTypeRef tname_RuntimeTypeHandle |> mkILNonGenericValueTy + + member val iltyp_ReferenceAssemblyAttributeOpt = + tryFindSysILTypeRef tname_ReferenceAssemblyAttribute + |> Option.map mkILNonGenericBoxedTy + + member val iltyp_UnmanagedType = findSysILTypeRef tname_UnmanagedType |> mkILNonGenericValueTy + member val attrib_AttributeUsageAttribute = findSysAttrib "System.AttributeUsageAttribute" + member val attrib_ParamArrayAttribute = findSysAttrib "System.ParamArrayAttribute" + member val attrib_IDispatchConstantAttribute = tryFindSysAttrib "System.Runtime.CompilerServices.IDispatchConstantAttribute" + member val attrib_IUnknownConstantAttribute = tryFindSysAttrib "System.Runtime.CompilerServices.IUnknownConstantAttribute" + member val attrib_RequiresLocationAttribute = findSysAttrib "System.Runtime.CompilerServices.RequiresLocationAttribute" + + // We use 'findSysAttrib' here because lookup on attribute is done by name comparison, and can proceed + // even if the type is not found in a system assembly. + member val attrib_IsReadOnlyAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.IsReadOnlyAttribute" + member val attrib_IsUnmanagedAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.IsUnmanagedAttribute" + member val attrib_DynamicDependencyAttribute = findOrEmbedSysPublicType "System.Diagnostics.CodeAnalysis.DynamicDependencyAttribute" + member val attrib_NullableAttribute_opt = tryFindSysAttrib "System.Runtime.CompilerServices.NullableAttribute" + member val attrib_NullableContextAttribute_opt = tryFindSysAttrib "System.Runtime.CompilerServices.NullableContextAttribute" + member val attrib_NullableAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.NullableAttribute" + member val attrib_NullableContextAttribute = findOrEmbedSysPublicType "System.Runtime.CompilerServices.NullableContextAttribute" + member val attrib_MemberNotNullWhenAttribute = findOrEmbedSysPublicType "System.Diagnostics.CodeAnalysis.MemberNotNullWhenAttribute" + + member val enum_DynamicallyAccessedMemberTypes = + findOrEmbedSysPublicType "System.Diagnostics.CodeAnalysis.DynamicallyAccessedMemberTypes" + + member val attrib_SystemObsolete = findSysAttrib "System.ObsoleteAttribute" + member val attrib_DllImportAttribute = tryFindSysAttrib "System.Runtime.InteropServices.DllImportAttribute" + member val attrib_StructLayoutAttribute = findSysAttrib "System.Runtime.InteropServices.StructLayoutAttribute" + member val attrib_TypeForwardedToAttribute = findSysAttrib "System.Runtime.CompilerServices.TypeForwardedToAttribute" + member val attrib_ComVisibleAttribute = findSysAttrib "System.Runtime.InteropServices.ComVisibleAttribute" + member val attrib_ComImportAttribute = tryFindSysAttrib "System.Runtime.InteropServices.ComImportAttribute" + member val attrib_FieldOffsetAttribute = findSysAttrib "System.Runtime.InteropServices.FieldOffsetAttribute" + member val attrib_MarshalAsAttribute = tryFindSysAttrib "System.Runtime.InteropServices.MarshalAsAttribute" + member val attrib_InAttribute = findSysAttrib "System.Runtime.InteropServices.InAttribute" + member val attrib_OutAttribute = findSysAttrib "System.Runtime.InteropServices.OutAttribute" + member val attrib_OptionalAttribute = tryFindSysAttrib "System.Runtime.InteropServices.OptionalAttribute" + member val attrib_DefaultParameterValueAttribute = tryFindSysAttrib "System.Runtime.InteropServices.DefaultParameterValueAttribute" + member val attrib_ThreadStaticAttribute = tryFindSysAttrib "System.ThreadStaticAttribute" + member val attrib_VolatileFieldAttribute = mk_MFCore_attrib "VolatileFieldAttribute" + member val attrib_NoEagerConstraintApplicationAttribute = mk_MFCompilerServices_attrib "NoEagerConstraintApplicationAttribute" + member val attrib_ContextStaticAttribute = tryFindSysAttrib "System.ContextStaticAttribute" + member val attrib_FlagsAttribute = findSysAttrib "System.FlagsAttribute" + member val attrib_DefaultMemberAttribute = findSysAttrib "System.Reflection.DefaultMemberAttribute" + member val attrib_DebuggerDisplayAttribute = findSysAttrib "System.Diagnostics.DebuggerDisplayAttribute" + member val attrib_DebuggerTypeProxyAttribute = findSysAttrib "System.Diagnostics.DebuggerTypeProxyAttribute" + member val attrib_PreserveSigAttribute = tryFindSysAttrib "System.Runtime.InteropServices.PreserveSigAttribute" + member val attrib_MethodImplAttribute = findSysAttrib "System.Runtime.CompilerServices.MethodImplAttribute" + member val attrib_ExtensionAttribute = findSysAttrib "System.Runtime.CompilerServices.ExtensionAttribute" + member val attrib_CallerLineNumberAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerLineNumberAttribute" + member val attrib_CallerFilePathAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerFilePathAttribute" + member val attrib_CallerMemberNameAttribute = findSysAttrib "System.Runtime.CompilerServices.CallerMemberNameAttribute" + member val attrib_SkipLocalsInitAttribute = findSysAttrib "System.Runtime.CompilerServices.SkipLocalsInitAttribute" + member val attrib_DecimalConstantAttribute = findSysAttrib "System.Runtime.CompilerServices.DecimalConstantAttribute" + member val attribs_Unsupported = v_attribs_Unsupported + + member val attrib_ProjectionParameterAttribute = mk_MFCore_attrib "ProjectionParameterAttribute" + member val attrib_CustomOperationAttribute = mk_MFCore_attrib "CustomOperationAttribute" + member val attrib_NonSerializedAttribute = tryFindSysAttrib "System.NonSerializedAttribute" + + member val attrib_AutoSerializableAttribute = mk_MFCore_attrib "AutoSerializableAttribute" + member val attrib_RequireQualifiedAccessAttribute = mk_MFCore_attrib "RequireQualifiedAccessAttribute" + member val attrib_EntryPointAttribute = mk_MFCore_attrib "EntryPointAttribute" + member val attrib_DefaultAugmentationAttribute = mk_MFCore_attrib "DefaultAugmentationAttribute" + member val attrib_CompilerMessageAttribute = mk_MFCore_attrib "CompilerMessageAttribute" + member val attrib_ExperimentalAttribute = mk_MFCore_attrib "ExperimentalAttribute" + member val attrib_UnverifiableAttribute = mk_MFCore_attrib "UnverifiableAttribute" + member val attrib_LiteralAttribute = mk_MFCore_attrib "LiteralAttribute" + member val attrib_ConditionalAttribute = findSysAttrib "System.Diagnostics.ConditionalAttribute" + member val attrib_OptionalArgumentAttribute = mk_MFCore_attrib "OptionalArgumentAttribute" + member val attrib_RequiresExplicitTypeArgumentsAttribute = mk_MFCore_attrib "RequiresExplicitTypeArgumentsAttribute" + member val attrib_DefaultValueAttribute = mk_MFCore_attrib "DefaultValueAttribute" + member val attrib_ClassAttribute = mk_MFCore_attrib "ClassAttribute" + member val attrib_InterfaceAttribute = mk_MFCore_attrib "InterfaceAttribute" + member val attrib_StructAttribute = mk_MFCore_attrib "StructAttribute" + member val attrib_ReflectedDefinitionAttribute = mk_MFCore_attrib "ReflectedDefinitionAttribute" + member val attrib_CompiledNameAttribute = mk_MFCore_attrib "CompiledNameAttribute" + member val attrib_AutoOpenAttribute = mk_MFCore_attrib "AutoOpenAttribute" + member val attrib_InternalsVisibleToAttribute = findSysAttrib tname_InternalsVisibleToAttribute + member val attrib_CompilationRepresentationAttribute = mk_MFCore_attrib "CompilationRepresentationAttribute" + member val attrib_CompilationArgumentCountsAttribute = mk_MFCore_attrib "CompilationArgumentCountsAttribute" + member val attrib_CompilationMappingAttribute = mk_MFCore_attrib "CompilationMappingAttribute" + member val attrib_CLIEventAttribute = mk_MFCore_attrib "CLIEventAttribute" + member val attrib_InlineIfLambdaAttribute = mk_MFCore_attrib "InlineIfLambdaAttribute" + member val attrib_CLIMutableAttribute = mk_MFCore_attrib "CLIMutableAttribute" + member val attrib_AllowNullLiteralAttribute = mk_MFCore_attrib "AllowNullLiteralAttribute" + member val attrib_NoEqualityAttribute = mk_MFCore_attrib "NoEqualityAttribute" + member val attrib_NoComparisonAttribute = mk_MFCore_attrib "NoComparisonAttribute" + member val attrib_CustomEqualityAttribute = mk_MFCore_attrib "CustomEqualityAttribute" + member val attrib_CustomComparisonAttribute = mk_MFCore_attrib "CustomComparisonAttribute" + member val attrib_EqualityConditionalOnAttribute = mk_MFCore_attrib "EqualityConditionalOnAttribute" + member val attrib_ComparisonConditionalOnAttribute = mk_MFCore_attrib "ComparisonConditionalOnAttribute" + member val attrib_ReferenceEqualityAttribute = mk_MFCore_attrib "ReferenceEqualityAttribute" + member val attrib_StructuralEqualityAttribute = mk_MFCore_attrib "StructuralEqualityAttribute" + member val attrib_StructuralComparisonAttribute = mk_MFCore_attrib "StructuralComparisonAttribute" + member val attrib_SealedAttribute = mk_MFCore_attrib "SealedAttribute" + member val attrib_AbstractClassAttribute = mk_MFCore_attrib "AbstractClassAttribute" + member val attrib_GeneralizableValueAttribute = mk_MFCore_attrib "GeneralizableValueAttribute" + member val attrib_MeasureAttribute = mk_MFCore_attrib "MeasureAttribute" + member val attrib_MeasureableAttribute = mk_MFCore_attrib "MeasureAnnotatedAbbreviationAttribute" + member val attrib_NoDynamicInvocationAttribute = mk_MFCore_attrib "NoDynamicInvocationAttribute" + member val attrib_NoCompilerInliningAttribute = mk_MFCore_attrib "NoCompilerInliningAttribute" + member val attrib_WarnOnWithoutNullArgumentAttribute = mk_MFCore_attrib "WarnOnWithoutNullArgumentAttribute" + member val attrib_SecurityAttribute = tryFindSysAttrib "System.Security.Permissions.SecurityAttribute" + member val attrib_SecurityCriticalAttribute = findSysAttrib "System.Security.SecurityCriticalAttribute" + member val attrib_SecuritySafeCriticalAttribute = findSysAttrib "System.Security.SecuritySafeCriticalAttribute" + member val attrib_ComponentModelEditorBrowsableAttribute = findSysAttrib "System.ComponentModel.EditorBrowsableAttribute" + member val attrib_CompilerFeatureRequiredAttribute = findSysAttrib "System.Runtime.CompilerServices.CompilerFeatureRequiredAttribute" + member val attrib_SetsRequiredMembersAttribute = findSysAttrib "System.Diagnostics.CodeAnalysis.SetsRequiredMembersAttribute" + member val attrib_RequiredMemberAttribute = findSysAttrib "System.Runtime.CompilerServices.RequiredMemberAttribute" + member val attrib_IlExperimentalAttribute = findSysAttrib "System.Diagnostics.CodeAnalysis.ExperimentalAttribute" + + member g.improveType tcref tinst = improveTy tcref tinst + + member g.decompileType tcref tinst = decompileTy tcref tinst + + member _.new_decimal_info = v_new_decimal_info + member _.seq_info = v_seq_info + member val seq_vref = (ValRefForIntrinsic v_seq_info) + member val and_vref = (ValRefForIntrinsic v_and_info) + member val and2_vref = (ValRefForIntrinsic v_and2_info) + member val addrof_vref = (ValRefForIntrinsic v_addrof_info) + member val addrof2_vref = (ValRefForIntrinsic v_addrof2_info) + member val or_vref = (ValRefForIntrinsic v_or_info) + member val splice_expr_vref = (ValRefForIntrinsic v_splice_expr_info) + member val splice_raw_expr_vref = (ValRefForIntrinsic v_splice_raw_expr_info) + member val or2_vref = (ValRefForIntrinsic v_or2_info) + member val generic_equality_er_inner_vref = ValRefForIntrinsic v_generic_equality_er_inner_info + member val generic_equality_per_inner_vref = ValRefForIntrinsic v_generic_equality_per_inner_info + member val generic_equality_withc_inner_vref = ValRefForIntrinsic v_generic_equality_withc_inner_info + member val generic_comparison_inner_vref = ValRefForIntrinsic v_generic_comparison_inner_info + member val generic_comparison_withc_inner_vref = ValRefForIntrinsic v_generic_comparison_withc_inner_info + member _.generic_comparison_withc_outer_info = v_generic_comparison_withc_outer_info + member _.generic_equality_er_outer_info = v_generic_equality_er_outer_info + member _.generic_equality_withc_outer_info = v_generic_equality_withc_outer_info + member _.generic_hash_withc_outer_info = v_generic_hash_withc_outer_info + member val generic_hash_inner_vref = ValRefForIntrinsic v_generic_hash_inner_info + member val generic_hash_withc_inner_vref = ValRefForIntrinsic v_generic_hash_withc_inner_info + + member val reference_equality_inner_vref = ValRefForIntrinsic v_reference_equality_inner_info + + member val piperight_vref = ValRefForIntrinsic v_piperight_info + member val piperight2_vref = ValRefForIntrinsic v_piperight2_info + member val piperight3_vref = ValRefForIntrinsic v_piperight3_info + member val bitwise_or_vref = ValRefForIntrinsic v_bitwise_or_info + member val bitwise_and_vref = ValRefForIntrinsic v_bitwise_and_info + member val bitwise_xor_vref = ValRefForIntrinsic v_bitwise_xor_info + member val bitwise_unary_not_vref = ValRefForIntrinsic v_bitwise_unary_not_info + member val bitwise_shift_left_vref = ValRefForIntrinsic v_bitwise_shift_left_info + member val bitwise_shift_right_vref = ValRefForIntrinsic v_bitwise_shift_right_info + member val exponentiation_vref = ValRefForIntrinsic v_exponentiation_info + member val unchecked_addition_vref = ValRefForIntrinsic v_unchecked_addition_info + member val unchecked_unary_plus_vref = ValRefForIntrinsic v_unchecked_unary_plus_info + member val unchecked_unary_minus_vref = ValRefForIntrinsic v_unchecked_unary_minus_info + member val unchecked_unary_not_vref = ValRefForIntrinsic v_unchecked_unary_not_info + member val unchecked_subtraction_vref = ValRefForIntrinsic v_unchecked_subtraction_info + member val unchecked_multiply_vref = ValRefForIntrinsic v_unchecked_multiply_info + member val unchecked_division_vref = ValRefForIntrinsic v_unchecked_division_info + member val unchecked_modulus_vref = ValRefForIntrinsic v_unchecked_modulus_info + member val unchecked_defaultof_vref = ValRefForIntrinsic v_unchecked_defaultof_info + member val refcell_deref_vref = ValRefForIntrinsic v_refcell_deref_info + member val refcell_assign_vref = ValRefForIntrinsic v_refcell_assign_info + member val refcell_incr_vref = ValRefForIntrinsic v_refcell_incr_info + member val refcell_decr_vref = ValRefForIntrinsic v_refcell_decr_info + + member _.bitwise_or_info = v_bitwise_or_info + member _.bitwise_and_info = v_bitwise_and_info + member _.bitwise_xor_info = v_bitwise_xor_info + member _.bitwise_unary_not_info = v_bitwise_unary_not_info + member _.bitwise_shift_left_info = v_bitwise_shift_left_info + member _.bitwise_shift_right_info = v_bitwise_shift_right_info + member _.unchecked_addition_info = v_unchecked_addition_info + member _.unchecked_subtraction_info = v_unchecked_subtraction_info + member _.unchecked_multiply_info = v_unchecked_multiply_info + member _.unchecked_division_info = v_unchecked_division_info + member _.unchecked_modulus_info = v_unchecked_modulus_info + member _.unchecked_unary_minus_info = v_unchecked_unary_minus_info + member _.unchecked_defaultof_info = v_unchecked_defaultof_info + + member _.checked_addition_info = v_checked_addition_info + member _.checked_subtraction_info = v_checked_subtraction_info + member _.checked_multiply_info = v_checked_multiply_info + member _.checked_unary_minus_info = v_checked_unary_minus_info + + member _.byte_checked_info = v_byte_checked_info + member _.sbyte_checked_info = v_sbyte_checked_info + member _.int16_checked_info = v_int16_checked_info + member _.uint16_checked_info = v_uint16_checked_info + member _.int_checked_info = v_int_checked_info + member _.int32_checked_info = v_int32_checked_info + member _.uint32_checked_info = v_uint32_checked_info + member _.int64_checked_info = v_int64_checked_info + member _.uint64_checked_info = v_uint64_checked_info + member _.nativeint_checked_info = v_nativeint_checked_info + member _.unativeint_checked_info = v_unativeint_checked_info + + member _.byte_operator_info = v_byte_operator_info + member _.sbyte_operator_info = v_sbyte_operator_info + member _.int16_operator_info = v_int16_operator_info + member _.uint16_operator_info = v_uint16_operator_info + member _.int32_operator_info = v_int32_operator_info + member _.uint32_operator_info = v_uint32_operator_info + member _.int64_operator_info = v_int64_operator_info + member _.uint64_operator_info = v_uint64_operator_info + member _.float32_operator_info = v_float32_operator_info + member _.float_operator_info = v_float_operator_info + member _.nativeint_operator_info = v_nativeint_operator_info + member _.unativeint_operator_info = v_unativeint_operator_info + + member _.char_operator_info = v_char_operator_info + member _.enum_operator_info = v_enum_operator_info + + member val compare_operator_vref = ValRefForIntrinsic v_compare_operator_info + member val equals_operator_vref = ValRefForIntrinsic v_equals_operator_info + member val equals_nullable_operator_vref = ValRefForIntrinsic v_equals_nullable_operator_info + member val nullable_equals_nullable_operator_vref = ValRefForIntrinsic v_nullable_equals_nullable_operator_info + member val nullable_equals_operator_vref = ValRefForIntrinsic v_nullable_equals_operator_info + member val not_equals_operator_vref = ValRefForIntrinsic v_not_equals_operator_info + member val less_than_operator_vref = ValRefForIntrinsic v_less_than_operator_info + member val less_than_or_equals_operator_vref = ValRefForIntrinsic v_less_than_or_equals_operator_info + member val greater_than_operator_vref = ValRefForIntrinsic v_greater_than_operator_info + member val greater_than_or_equals_operator_vref = ValRefForIntrinsic v_greater_than_or_equals_operator_info + + member val raise_vref = ValRefForIntrinsic v_raise_info + member val failwith_vref = ValRefForIntrinsic v_failwith_info + member val invalid_arg_vref = ValRefForIntrinsic v_invalid_arg_info + member val null_arg_vref = ValRefForIntrinsic v_null_arg_info + member val invalid_op_vref = ValRefForIntrinsic v_invalid_op_info + member val failwithf_vref = ValRefForIntrinsic v_failwithf_info + + member _.equals_operator_info = v_equals_operator_info + member _.not_equals_operator = v_not_equals_operator_info + member _.less_than_operator = v_less_than_operator_info + member _.less_than_or_equals_operator = v_less_than_or_equals_operator_info + member _.greater_than_operator = v_greater_than_operator_info + member _.greater_than_or_equals_operator = v_greater_than_or_equals_operator_info + + member _.hash_info = v_hash_info + member _.box_info = v_box_info + member _.isnull_info = v_isnull_info + member _.raise_info = v_raise_info + member _.reraise_info = v_reraise_info + member _.typeof_info = v_typeof_info + member _.typedefof_info = v_typedefof_info + + member val reraise_vref = ValRefForIntrinsic v_reraise_info + member val methodhandleof_vref = ValRefForIntrinsic v_methodhandleof_info + member val typeof_vref = ValRefForIntrinsic v_typeof_info + member val sizeof_vref = ValRefForIntrinsic v_sizeof_info + member val nameof_vref = ValRefForIntrinsic v_nameof_info + member val typedefof_vref = ValRefForIntrinsic v_typedefof_info + member val enum_vref = ValRefForIntrinsic v_enum_operator_info + member val enumOfValue_vref = ValRefForIntrinsic v_enumOfValue_info + member val range_op_vref = ValRefForIntrinsic v_range_op_info + member val range_step_op_vref = ValRefForIntrinsic v_range_step_op_info + member val range_int32_op_vref = ValRefForIntrinsic v_range_int32_op_info + member val range_int64_op_vref = ValRefForIntrinsic v_range_int64_op_info + member val range_uint64_op_vref = ValRefForIntrinsic v_range_uint64_op_info + member val range_uint32_op_vref = ValRefForIntrinsic v_range_uint32_op_info + member val range_nativeint_op_vref = ValRefForIntrinsic v_range_nativeint_op_info + member val range_unativeint_op_vref = ValRefForIntrinsic v_range_unativeint_op_info + member val range_int16_op_vref = ValRefForIntrinsic v_range_int16_op_info + member val range_uint16_op_vref = ValRefForIntrinsic v_range_uint16_op_info + member val range_sbyte_op_vref = ValRefForIntrinsic v_range_sbyte_op_info + member val range_byte_op_vref = ValRefForIntrinsic v_range_byte_op_info + member val range_char_op_vref = ValRefForIntrinsic v_range_char_op_info + member val range_generic_op_vref = ValRefForIntrinsic v_range_generic_op_info + member val range_step_generic_op_vref = ValRefForIntrinsic v_range_step_generic_op_info + member val array_get_vref = ValRefForIntrinsic v_array_get_info + member val array2D_get_vref = ValRefForIntrinsic v_array2D_get_info + member val array3D_get_vref = ValRefForIntrinsic v_array3D_get_info + member val array4D_get_vref = ValRefForIntrinsic v_array4D_get_info + member val seq_singleton_vref = ValRefForIntrinsic v_seq_singleton_info + member val seq_collect_vref = ValRefForIntrinsic v_seq_collect_info + member val nativeptr_tobyref_vref = ValRefForIntrinsic v_nativeptr_tobyref_info + member val seq_using_vref = ValRefForIntrinsic v_seq_using_info + member val seq_delay_vref = ValRefForIntrinsic v_seq_delay_info + member val seq_append_vref = ValRefForIntrinsic v_seq_append_info + member val seq_generated_vref = ValRefForIntrinsic v_seq_generated_info + member val seq_finally_vref = ValRefForIntrinsic v_seq_finally_info + member val seq_map_vref = ValRefForIntrinsic v_seq_map_info + member val seq_empty_vref = ValRefForIntrinsic v_seq_empty_info + member val new_format_vref = ValRefForIntrinsic v_new_format_info + member val sprintf_vref = ValRefForIntrinsic v_sprintf_info + member val unbox_vref = ValRefForIntrinsic v_unbox_info + member val unbox_fast_vref = ValRefForIntrinsic v_unbox_fast_info + member val istype_vref = ValRefForIntrinsic v_istype_info + member val istype_fast_vref = ValRefForIntrinsic v_istype_fast_info + member val query_source_vref = ValRefForIntrinsic v_query_source_info + member val query_value_vref = ValRefForIntrinsic v_query_value_info + member val query_run_value_vref = ValRefForIntrinsic v_query_run_value_info + member val query_run_enumerable_vref = ValRefForIntrinsic v_query_run_enumerable_info + member val query_for_vref = ValRefForIntrinsic v_query_for_value_info + member val query_yield_vref = ValRefForIntrinsic v_query_yield_value_info + member val query_yield_from_vref = ValRefForIntrinsic v_query_yield_from_value_info + member val query_select_vref = ValRefForIntrinsic v_query_select_value_info + member val query_zero_vref = ValRefForIntrinsic v_query_zero_value_info + member val seq_to_list_vref = ValRefForIntrinsic v_seq_to_list_info + member val seq_to_array_vref = ValRefForIntrinsic v_seq_to_array_info + + member _.seq_collect_info = v_seq_collect_info + member _.seq_using_info = v_seq_using_info + member _.seq_delay_info = v_seq_delay_info + member _.seq_append_info = v_seq_append_info + member _.seq_generated_info = v_seq_generated_info + member _.seq_finally_info = v_seq_finally_info + member _.seq_trywith_info = v_seq_trywith_info + member _.seq_of_functions_info = v_seq_of_functions_info + member _.seq_map_info = v_seq_map_info + member _.seq_singleton_info = v_seq_singleton_info + member _.seq_empty_info = v_seq_empty_info + member _.sprintf_info = v_sprintf_info + member _.new_format_info = v_new_format_info + member _.unbox_info = v_unbox_info + member _.get_generic_comparer_info = v_get_generic_comparer_info + + member _.get_generic_er_equality_comparer_info = + v_get_generic_er_equality_comparer_info + + member _.get_generic_per_equality_comparer_info = + v_get_generic_per_equality_comparer_info + + member _.dispose_info = v_dispose_info + member _.getstring_info = v_getstring_info + member _.unbox_fast_info = v_unbox_fast_info + member _.istype_info = v_istype_info + member _.lazy_force_info = v_lazy_force_info + member _.lazy_create_info = v_lazy_create_info + member _.create_instance_info = v_create_instance_info + member _.create_event_info = v_create_event_info + member _.seq_to_list_info = v_seq_to_list_info + member _.seq_to_array_info = v_seq_to_array_info + + member _.array_length_info = v_array_length_info + member _.array_get_info = v_array_get_info + member _.array2D_get_info = v_array2D_get_info + member _.array3D_get_info = v_array3D_get_info + member _.array4D_get_info = v_array4D_get_info + member _.array_set_info = v_array_set_info + member _.array2D_set_info = v_array2D_set_info + member _.array3D_set_info = v_array3D_set_info + member _.array4D_set_info = v_array4D_set_info + + member val option_toNullable_info = v_option_toNullable_info + member val option_defaultValue_info = v_option_defaultValue_info + + member _.deserialize_quoted_FSharp_20_plus_info = + v_deserialize_quoted_FSharp_20_plus_info + + member _.deserialize_quoted_FSharp_40_plus_info = + v_deserialize_quoted_FSharp_40_plus_info + + member _.call_with_witnesses_info = v_call_with_witnesses_info + member _.cast_quotation_info = v_cast_quotation_info + member _.lift_value_info = v_lift_value_info + member _.lift_value_with_name_info = v_lift_value_with_name_info + member _.lift_value_with_defn_info = v_lift_value_with_defn_info + member _.query_source_as_enum_info = v_query_source_as_enum_info + member _.new_query_source_info = v_new_query_source_info + member _.query_builder_tcref = v_query_builder_tcref + member _.fail_init_info = v_fail_init_info + member _.fail_static_init_info = v_fail_static_init_info + member _.check_this_info = v_check_this_info + member _.quote_to_linq_lambda_info = v_quote_to_linq_lambda_info + + member val cgh__stateMachine_vref = ValRefForIntrinsic v_cgh__stateMachine_info + member val cgh__useResumableCode_vref = ValRefForIntrinsic v_cgh__useResumableCode_info + member val cgh__debugPoint_vref = ValRefForIntrinsic v_cgh__debugPoint_info + member val cgh__resumeAt_vref = ValRefForIntrinsic v_cgh__resumeAt_info + member val cgh__resumableEntry_vref = ValRefForIntrinsic v_cgh__resumableEntry_info + + member val generic_hash_withc_tuple2_vref = ValRefForIntrinsic v_generic_hash_withc_tuple2_info + member val generic_hash_withc_tuple3_vref = ValRefForIntrinsic v_generic_hash_withc_tuple3_info + member val generic_hash_withc_tuple4_vref = ValRefForIntrinsic v_generic_hash_withc_tuple4_info + member val generic_hash_withc_tuple5_vref = ValRefForIntrinsic v_generic_hash_withc_tuple5_info + member val generic_equals_withc_tuple2_vref = ValRefForIntrinsic v_generic_equals_withc_tuple2_info + member val generic_equals_withc_tuple3_vref = ValRefForIntrinsic v_generic_equals_withc_tuple3_info + member val generic_equals_withc_tuple4_vref = ValRefForIntrinsic v_generic_equals_withc_tuple4_info + member val generic_equals_withc_tuple5_vref = ValRefForIntrinsic v_generic_equals_withc_tuple5_info + member val generic_compare_withc_tuple2_vref = ValRefForIntrinsic v_generic_compare_withc_tuple2_info + member val generic_compare_withc_tuple3_vref = ValRefForIntrinsic v_generic_compare_withc_tuple3_info + member val generic_compare_withc_tuple4_vref = ValRefForIntrinsic v_generic_compare_withc_tuple4_info + member val generic_compare_withc_tuple5_vref = ValRefForIntrinsic v_generic_compare_withc_tuple5_info + member val generic_equality_withc_outer_vref = ValRefForIntrinsic v_generic_equality_withc_outer_info + + member _.cons_ucref = v_cons_ucref + member _.nil_ucref = v_nil_ucref // A list of types that are explicitly suppressed from the F# intellisense // Note that the suppression checks for the precise name of the type // so the lowercase versions are visible - member _.suppressed_types = v_suppressed_types + member _.suppressed_types = v_suppressed_types - /// Are we assuming all code gen is for F# interactive, with no static linking - member _.isInteractive=isInteractive + /// Are we assuming all code gen is for F# interactive, with no static linking + member _.isInteractive = isInteractive - member val compilationMode = compilationMode + member val compilationMode = compilationMode - /// Indicates if we are generating witness arguments for SRTP constraints. Only done if the FSharp.Core - /// supports witness arguments. - member g.generateWitnesses = - compilingFSharpCore || - ((ValRefForIntrinsic g.call_with_witnesses_info).TryDeref.IsSome && langVersion.SupportsFeature LanguageFeature.WitnessPassing) + /// Indicates if we are generating witness arguments for SRTP constraints. Only done if the FSharp.Core + /// supports witness arguments. + member g.generateWitnesses = + compilingFSharpCore + || ((ValRefForIntrinsic g.call_with_witnesses_info).TryDeref.IsSome + && langVersion.SupportsFeature LanguageFeature.WitnessPassing) - /// Indicates if we can use System.Array.Empty when emitting IL for empty array literals - member val isArrayEmptyAvailable = v_Array_tcref.ILTyconRawMetadata.Methods.FindByName "Empty" |> List.isEmpty |> not + /// Indicates if we can use System.Array.Empty when emitting IL for empty array literals + member val isArrayEmptyAvailable = + v_Array_tcref.ILTyconRawMetadata.Methods.FindByName "Empty" + |> List.isEmpty + |> not - member g.isSpliceOperator v = - primValRefEq g.compilingFSharpCore g.fslibCcu v g.splice_expr_vref || - primValRefEq g.compilingFSharpCore g.fslibCcu v g.splice_raw_expr_vref + member g.isSpliceOperator v = + primValRefEq g.compilingFSharpCore g.fslibCcu v g.splice_expr_vref + || primValRefEq g.compilingFSharpCore g.fslibCcu v g.splice_raw_expr_vref - member _.FindSysTyconRef path nm = findSysTyconRef path nm + member _.FindSysTyconRef path nm = findSysTyconRef path nm - member _.TryFindSysTyconRef path nm = tryFindSysTyconRef path nm + member _.TryFindSysTyconRef path nm = tryFindSysTyconRef path nm - member _.FindSysILTypeRef nm = findSysILTypeRef nm + member _.FindSysILTypeRef nm = findSysILTypeRef nm - member _.TryFindSysILTypeRef nm = tryFindSysILTypeRef nm + member _.TryFindSysILTypeRef nm = tryFindSysILTypeRef nm - member _.FindSysAttrib nm = findSysAttrib nm + member _.FindSysAttrib nm = findSysAttrib nm - member _.TryFindSysAttrib nm = tryFindSysAttrib nm + member _.TryFindSysAttrib nm = tryFindSysAttrib nm - member _.AddGeneratedAttributes attrs = addGeneratedAttrs attrs + member _.AddGeneratedAttributes attrs = addGeneratedAttrs attrs - member _.AddValGeneratedAttributes v = addValGeneratedAttrs v + member _.AddValGeneratedAttributes v = addValGeneratedAttrs v - member _.AddMethodGeneratedAttributes mdef = addMethodGeneratedAttrs mdef + member _.AddMethodGeneratedAttributes mdef = addMethodGeneratedAttrs mdef - member _.AddPropertyGeneratedAttributes mdef = addPropertyGeneratedAttrs mdef + member _.AddPropertyGeneratedAttributes mdef = addPropertyGeneratedAttrs mdef - member _.AddFieldGeneratedAttributes mdef = addFieldGeneratedAttrs mdef + member _.AddFieldGeneratedAttributes mdef = addFieldGeneratedAttrs mdef - member _.AddPropertyNeverAttributes mdef = addPropertyNeverAttrs mdef + member _.AddPropertyNeverAttributes mdef = addPropertyNeverAttrs mdef - member _.AddFieldNeverAttributes mdef = addFieldNeverAttrs mdef + member _.AddFieldNeverAttributes mdef = addFieldNeverAttrs mdef - member _.MkDebuggerTypeProxyAttribute ty = mkDebuggerTypeProxyAttribute ty + member _.MkDebuggerTypeProxyAttribute ty = mkDebuggerTypeProxyAttribute ty - member _.mkDebuggerDisplayAttribute s = mkILCustomAttribute (findSysILTypeRef tname_DebuggerDisplayAttribute, [ilg.typ_String], [ILAttribElem.String (Some s)], []) + member _.mkDebuggerDisplayAttribute s = + mkILCustomAttribute (findSysILTypeRef tname_DebuggerDisplayAttribute, [ ilg.typ_String ], [ ILAttribElem.String(Some s) ], []) - member _.DebuggerBrowsableNeverAttribute = debuggerBrowsableNeverAttribute + member _.DebuggerBrowsableNeverAttribute = debuggerBrowsableNeverAttribute - member _.mkDebuggableAttributeV2(jitTracking, jitOptimizerDisabled) = + member _.mkDebuggableAttributeV2(jitTracking, jitOptimizerDisabled) = let debuggingMode = - 0x3 (* Default ||| IgnoreSymbolStoreSequencePoints *) ||| - (if jitTracking then 1 else 0) ||| - (if jitOptimizerDisabled then 256 else 0) - let tref_DebuggableAttribute_DebuggingModes = mkILTyRefInTyRef (tref_DebuggableAttribute, tname_DebuggableAttribute_DebuggingModes) - mkILCustomAttribute - (tref_DebuggableAttribute, [mkILNonGenericValueTy tref_DebuggableAttribute_DebuggingModes], - (* See System.Diagnostics.DebuggableAttribute.DebuggingModes *) - [ILAttribElem.Int32( debuggingMode )], []) - - member internal _.CompilerGlobalState = Some compilerGlobalState - - member _.CompilerGeneratedAttribute = compilerGeneratedAttribute - - member _.DebuggerNonUserCodeAttribute = debuggerNonUserCodeAttribute - - member _.HasTailCallAttrib (attribs: Attribs) = - attribs - |> List.exists (fun a -> a.TyconRef.CompiledRepresentationForNamedType.FullName = "Microsoft.FSharp.Core.TailCallAttribute") - - member _.MakeInternalsVisibleToAttribute(simpleAssemName) = - mkILCustomAttribute (tref_InternalsVisibleToAttribute, [ilg.typ_String], [ILAttribElem.String (Some simpleAssemName)], []) - - /// Find an FSharp.Core LanguagePrimitives dynamic function that corresponds to a trait witness, e.g. - /// AdditionDynamic for op_Addition. Also work out the type instantiation of the dynamic function. - member _.MakeBuiltInWitnessInfo (t: TraitConstraintInfo) = - let memberName = - let nm = t.MemberLogicalName - let coreName = - if nm.StartsWithOrdinal "op_" then nm[3..] - elif nm = "get_Zero" then "GenericZero" - elif nm = "get_One" then "GenericOne" - else nm - coreName + "Dynamic" - - let gtps, argTys, retTy, tinst = - match memberName, t.CompiledObjectAndArgumentTypes, t.CompiledReturnType with - | ("AdditionDynamic" | "MultiplyDynamic" | "SubtractionDynamic"| "DivisionDynamic" | "ModulusDynamic" | "CheckedAdditionDynamic" | "CheckedMultiplyDynamic" | "CheckedSubtractionDynamic" | "LeftShiftDynamic" | "RightShiftDynamic" | "BitwiseAndDynamic" | "BitwiseOrDynamic" | "ExclusiveOrDynamic" | "LessThanDynamic" | "GreaterThanDynamic" | "LessThanOrEqualDynamic" | "GreaterThanOrEqualDynamic" | "EqualityDynamic" | "InequalityDynamic"), - [ arg0Ty; arg1Ty ], - Some retTy -> - [vara; varb; varc], [ varaTy; varbTy ], varcTy, [ arg0Ty; arg1Ty; retTy ] - | ("UnaryNegationDynamic" | "CheckedUnaryNegationDynamic" | "LogicalNotDynamic" | "ExplicitDynamic" | "CheckedExplicitDynamic"), - [ arg0Ty ], - Some retTy -> - [vara; varb ], [ varaTy ], varbTy, [ arg0Ty; retTy ] - | "DivideByIntDynamic", [arg0Ty; _], _ -> - [vara], [ varaTy; v_int32_ty ], varaTy, [ arg0Ty ] - | ("GenericZeroDynamic" | "GenericOneDynamic"), [], Some retTy -> - [vara], [ ], varaTy, [ retTy ] - | _ -> failwithf "unknown builtin witness '%s'" memberName - - let vref = makeOtherIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, memberName, None, None, gtps, (List.map List.singleton argTys, retTy)) - vref, tinst - - /// Find an FSharp.Core operator that corresponds to a trait witness - member g.TryMakeOperatorAsBuiltInWitnessInfo isStringTy isArrayTy (t: TraitConstraintInfo) argExprs = - - match t.MemberLogicalName, t.CompiledObjectAndArgumentTypes, t.CompiledReturnType, argExprs with - | "get_Sign", [aty], _, objExpr :: _ -> - // Call Operators.sign - let info = makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "sign", None, Some "Sign", [vara], ([[varaTy]], v_int32_ty)) - let tyargs = [aty] - Some (info, tyargs, [objExpr]) - | "Sqrt", [aty], Some bty, [_] -> - // Call Operators.sqrt - let info = makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "sqrt", None, Some "Sqrt", [vara; varb], ([[varaTy]], varbTy)) - let tyargs = [aty; bty] - Some (info, tyargs, argExprs) - | "Pow", [aty;bty], _, [_;_] -> - // Call Operators.(**) - let info = v_exponentiation_info - let tyargs = [aty;bty] - Some (info, tyargs, argExprs) - | "Atan2", [aty;_], Some bty, [_;_] -> - // Call Operators.atan2 - let info = makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "atan2", None, Some "Atan2", [vara; varb], ([[varaTy]; [varaTy]], varbTy)) - let tyargs = [aty;bty] - Some (info, tyargs, argExprs) - | "get_Zero", _, Some aty, ([] | [_]) -> - // Call LanguagePrimitives.GenericZero - let info = makeOtherIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericZero", None, None, [vara], ([], varaTy)) - let tyargs = [aty] - Some (info, tyargs, []) - | "get_One", _, Some aty, ([] | [_]) -> - // Call LanguagePrimitives.GenericOne - let info = makeOtherIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericOne", None, None, [vara], ([], varaTy)) - let tyargs = [aty] - Some (info, tyargs, []) - | ("Abs" | "Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10"| "Log"), [aty], _, [_] -> - // Call corresponding Operators.* - let nm = t.MemberLogicalName - let lower = if nm = "Ceiling" then "ceil" else nm.ToLowerInvariant() - let info = makeOtherIntrinsicValRef (fslib_MFOperators_nleref, lower, None, Some nm, [vara], ([[varaTy]], varaTy)) - let tyargs = [aty] - Some (info, tyargs, argExprs) - | "get_Item", [arrTy; _], Some retTy, [_; _] when isArrayTy g arrTy -> - Some (g.array_get_info, [retTy], argExprs) - | "set_Item", [arrTy; _; elemTy], _, [_; _; _] when isArrayTy g arrTy -> - Some (g.array_set_info, [elemTy], argExprs) - | "get_Item", [stringTy; _; _], _, [_; _] when isStringTy g stringTy -> - Some (g.getstring_info, [], argExprs) - | "op_UnaryPlus", [aty], _, [_] -> - // Call Operators.id - let info = makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "id", None, None, [vara], ([[varaTy]], varaTy)) - let tyargs = [aty] - Some (info, tyargs, argExprs) - | _ -> - None + 0x3 (* Default ||| IgnoreSymbolStoreSequencePoints *) + ||| (if jitTracking then 1 else 0) + ||| (if jitOptimizerDisabled then 256 else 0) + + let tref_DebuggableAttribute_DebuggingModes = + mkILTyRefInTyRef (tref_DebuggableAttribute, tname_DebuggableAttribute_DebuggingModes) + + mkILCustomAttribute ( + tref_DebuggableAttribute, + [ mkILNonGenericValueTy tref_DebuggableAttribute_DebuggingModes ], + (* See System.Diagnostics.DebuggableAttribute.DebuggingModes *) + [ ILAttribElem.Int32(debuggingMode) ], + [] + ) + + member internal _.CompilerGlobalState = Some compilerGlobalState + + member _.CompilerGeneratedAttribute = compilerGeneratedAttribute + + member _.DebuggerNonUserCodeAttribute = debuggerNonUserCodeAttribute + + member _.HasTailCallAttrib(attribs: Attribs) = + attribs + |> List.exists (fun a -> a.TyconRef.CompiledRepresentationForNamedType.FullName = "Microsoft.FSharp.Core.TailCallAttribute") + + member _.MakeInternalsVisibleToAttribute(simpleAssemName) = + mkILCustomAttribute (tref_InternalsVisibleToAttribute, [ ilg.typ_String ], [ ILAttribElem.String(Some simpleAssemName) ], []) + + /// Find an FSharp.Core LanguagePrimitives dynamic function that corresponds to a trait witness, e.g. + /// AdditionDynamic for op_Addition. Also work out the type instantiation of the dynamic function. + member _.MakeBuiltInWitnessInfo(t: TraitConstraintInfo) = + let memberName = + let nm = t.MemberLogicalName + + let coreName = + if nm.StartsWithOrdinal "op_" then nm[3..] + elif nm = "get_Zero" then "GenericZero" + elif nm = "get_One" then "GenericOne" + else nm + + coreName + "Dynamic" + + let gtps, argTys, retTy, tinst = + match memberName, t.CompiledObjectAndArgumentTypes, t.CompiledReturnType with + | ("AdditionDynamic" | "MultiplyDynamic" | "SubtractionDynamic" | "DivisionDynamic" | "ModulusDynamic" | "CheckedAdditionDynamic" | "CheckedMultiplyDynamic" | "CheckedSubtractionDynamic" | "LeftShiftDynamic" | "RightShiftDynamic" | "BitwiseAndDynamic" | "BitwiseOrDynamic" | "ExclusiveOrDynamic" | "LessThanDynamic" | "GreaterThanDynamic" | "LessThanOrEqualDynamic" | "GreaterThanOrEqualDynamic" | "EqualityDynamic" | "InequalityDynamic"), + [ arg0Ty; arg1Ty ], + Some retTy -> [ vara; varb; varc ], [ varaTy; varbTy ], varcTy, [ arg0Ty; arg1Ty; retTy ] + | ("UnaryNegationDynamic" | "CheckedUnaryNegationDynamic" | "LogicalNotDynamic" | "ExplicitDynamic" | "CheckedExplicitDynamic"), + [ arg0Ty ], + Some retTy -> [ vara; varb ], [ varaTy ], varbTy, [ arg0Ty; retTy ] + | "DivideByIntDynamic", [ arg0Ty; _ ], _ -> [ vara ], [ varaTy; v_int32_ty ], varaTy, [ arg0Ty ] + | ("GenericZeroDynamic" | "GenericOneDynamic"), [], Some retTy -> [ vara ], [], varaTy, [ retTy ] + | _ -> failwithf "unknown builtin witness '%s'" memberName + + let vref = + makeOtherIntrinsicValRef ( + fslib_MFLanguagePrimitives_nleref, + memberName, + None, + None, + gtps, + (List.map List.singleton argTys, retTy) + ) + + vref, tinst + + /// Find an FSharp.Core operator that corresponds to a trait witness + member g.TryMakeOperatorAsBuiltInWitnessInfo isStringTy isArrayTy (t: TraitConstraintInfo) argExprs = + + match t.MemberLogicalName, t.CompiledObjectAndArgumentTypes, t.CompiledReturnType, argExprs with + | "get_Sign", [ aty ], _, objExpr :: _ -> + // Call Operators.sign + let info = + makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "sign", None, Some "Sign", [ vara ], ([ [ varaTy ] ], v_int32_ty)) + + let tyargs = [ aty ] + Some(info, tyargs, [ objExpr ]) + | "Sqrt", [ aty ], Some bty, [ _ ] -> + // Call Operators.sqrt + let info = + makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "sqrt", None, Some "Sqrt", [ vara; varb ], ([ [ varaTy ] ], varbTy)) + + let tyargs = [ aty; bty ] + Some(info, tyargs, argExprs) + | "Pow", [ aty; bty ], _, [ _; _ ] -> + // Call Operators.(**) + let info = v_exponentiation_info + let tyargs = [ aty; bty ] + Some(info, tyargs, argExprs) + | "Atan2", [ aty; _ ], Some bty, [ _; _ ] -> + // Call Operators.atan2 + let info = + makeOtherIntrinsicValRef ( + fslib_MFOperators_nleref, + "atan2", + None, + Some "Atan2", + [ vara; varb ], + ([ [ varaTy ]; [ varaTy ] ], varbTy) + ) + + let tyargs = [ aty; bty ] + Some(info, tyargs, argExprs) + | "get_Zero", _, Some aty, ([] | [ _ ]) -> + // Call LanguagePrimitives.GenericZero + let info = + makeOtherIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericZero", None, None, [ vara ], ([], varaTy)) + + let tyargs = [ aty ] + Some(info, tyargs, []) + | "get_One", _, Some aty, ([] | [ _ ]) -> + // Call LanguagePrimitives.GenericOne + let info = + makeOtherIntrinsicValRef (fslib_MFLanguagePrimitives_nleref, "GenericOne", None, None, [ vara ], ([], varaTy)) + + let tyargs = [ aty ] + Some(info, tyargs, []) + | ("Abs" | "Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log"), + [ aty ], + _, + [ _ ] -> + // Call corresponding Operators.* + let nm = t.MemberLogicalName + let lower = if nm = "Ceiling" then "ceil" else nm.ToLowerInvariant() + + let info = + makeOtherIntrinsicValRef (fslib_MFOperators_nleref, lower, None, Some nm, [ vara ], ([ [ varaTy ] ], varaTy)) + + let tyargs = [ aty ] + Some(info, tyargs, argExprs) + | "get_Item", [ arrTy; _ ], Some retTy, [ _; _ ] when isArrayTy g arrTy -> Some(g.array_get_info, [ retTy ], argExprs) + | "set_Item", [ arrTy; _; elemTy ], _, [ _; _; _ ] when isArrayTy g arrTy -> Some(g.array_set_info, [ elemTy ], argExprs) + | "get_Item", [ stringTy; _; _ ], _, [ _; _ ] when isStringTy g stringTy -> Some(g.getstring_info, [], argExprs) + | "op_UnaryPlus", [ aty ], _, [ _ ] -> + // Call Operators.id + let info = + makeOtherIntrinsicValRef (fslib_MFOperators_nleref, "id", None, None, [ vara ], ([ [ varaTy ] ], varaTy)) + + let tyargs = [ aty ] + Some(info, tyargs, argExprs) + | _ -> None #if DEBUG // This global is only used during debug output -let mutable global_g = None : TcGlobals option +let mutable global_g = None: TcGlobals option #endif diff --git a/src/Compiler/TypedTree/TypeProviders.fs b/src/Compiler/TypedTree/TypeProviders.fs index 425e31ea453..51003d3d85a 100644 --- a/src/Compiler/TypedTree/TypeProviders.fs +++ b/src/Compiler/TypedTree/TypeProviders.fs @@ -12,7 +12,7 @@ open System.IO open System.Collections.Generic open System.Reflection open Internal.Utilities.Library -open Internal.Utilities.FSharpEnvironment +open Internal.Utilities.FSharpEnvironment open FSharp.Core.CompilerServices open FSharp.Quotations open FSharp.Compiler.AbstractIL.IL @@ -22,9 +22,10 @@ open FSharp.Compiler.Text open FSharp.Compiler.Text.Range type TypeProviderDesignation = TypeProviderDesignation of string -type 'a ProvidedArray= ('a[]) MaybeNull +type 'a ProvidedArray = ('a[]) MaybeNull + module ProvidedArray = - let map f (arr:_ ProvidedArray) : _ ProvidedArray = + let map f (arr: _ ProvidedArray) : _ ProvidedArray = match arr with | null -> null | notNull -> notNull |> Array.map f @@ -33,168 +34,204 @@ exception ProvidedTypeResolution of range * exn exception ProvidedTypeResolutionNoRange of exn -let toolingCompatiblePaths() = Internal.Utilities.FSharpEnvironment.toolingCompatiblePaths () +let toolingCompatiblePaths () = + Internal.Utilities.FSharpEnvironment.toolingCompatiblePaths () -/// Represents some of the configuration parameters passed to type provider components +/// Represents some of the configuration parameters passed to type provider components type ResolutionEnvironment = - { ResolutionFolder: string - OutputFile: string option - ShowResolutionMessages: bool - GetReferencedAssemblies: unit -> string[] - TemporaryFolder: string } + { + ResolutionFolder: string + OutputFile: string option + ShowResolutionMessages: bool + GetReferencedAssemblies: unit -> string[] + TemporaryFolder: string + } /// Load the design-time part of a type-provider into the host process, and look for types /// marked with the TypeProviderAttribute attribute. -let GetTypeProviderImplementationTypes ( - runTimeAssemblyFileName, - designTimeAssemblyNameString, - m:range, - compilerToolPaths:string list - ) = +let GetTypeProviderImplementationTypes (runTimeAssemblyFileName, designTimeAssemblyNameString, m: range, compilerToolPaths: string list) = // Report an error, blaming the particular type provider component let raiseError designTimeAssemblyPathOpt (e: exn) = let attrName = typeof.Name - let exnTypeName = !! e.GetType().FullName + let exnTypeName = !!e.GetType().FullName let exnMsg = e.Message - match designTimeAssemblyPathOpt with - | None -> - let msg = FSComp.SR.etProviderHasWrongDesignerAssemblyNoPath(attrName, designTimeAssemblyNameString, exnTypeName, exnMsg) + + match designTimeAssemblyPathOpt with + | None -> + let msg = + FSComp.SR.etProviderHasWrongDesignerAssemblyNoPath (attrName, designTimeAssemblyNameString, exnTypeName, exnMsg) + raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) - | Some designTimeAssemblyPath -> - let msg = FSComp.SR.etProviderHasWrongDesignerAssembly(attrName, designTimeAssemblyNameString, designTimeAssemblyPath, exnTypeName, exnMsg) + | Some designTimeAssemblyPath -> + let msg = + FSComp.SR.etProviderHasWrongDesignerAssembly ( + attrName, + designTimeAssemblyNameString, + designTimeAssemblyPath, + exnTypeName, + exnMsg + ) + raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) - let designTimeAssemblyOpt = getTypeProviderAssembly (runTimeAssemblyFileName, designTimeAssemblyNameString, compilerToolPaths, raiseError) + let designTimeAssemblyOpt = + getTypeProviderAssembly (runTimeAssemblyFileName, designTimeAssemblyNameString, compilerToolPaths, raiseError) match designTimeAssemblyOpt with | Some loadedDesignTimeAssembly -> try - let exportedTypes = loadedDesignTimeAssembly.GetExportedTypes() - let filtered = + let exportedTypes = loadedDesignTimeAssembly.GetExportedTypes() + + let filtered = [ - for t in exportedTypes do + for t in exportedTypes do let ca = t.GetCustomAttributes(typeof, true) - if ca.Length > 0 then + + if ca.Length > 0 then yield t ] + filtered with e -> - let folder = !! Path.GetDirectoryName(loadedDesignTimeAssembly.Location) - let exnTypeName = !! e.GetType().FullName + let folder = !!Path.GetDirectoryName(loadedDesignTimeAssembly.Location) + let exnTypeName = !!e.GetType().FullName let exnMsg = e.Message - match e with - | :? FileLoadException -> - let msg = FSComp.SR.etProviderHasDesignerAssemblyDependency(designTimeAssemblyNameString, folder, exnTypeName, exnMsg) + + match e with + | :? FileLoadException -> + let msg = + FSComp.SR.etProviderHasDesignerAssemblyDependency (designTimeAssemblyNameString, folder, exnTypeName, exnMsg) + raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) - - | _ -> - let msg = FSComp.SR.etProviderHasDesignerAssemblyException(designTimeAssemblyNameString, folder, exnTypeName, exnMsg) + + | _ -> + let msg = + FSComp.SR.etProviderHasDesignerAssemblyException (designTimeAssemblyNameString, folder, exnTypeName, exnMsg) + raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) | None -> [] let StripException (e: exn) = match e with - | :? TargetInvocationException as e when isNotNull e.InnerException -> !! e.InnerException - | :? TypeInitializationException as e when isNotNull e.InnerException -> !! e.InnerException + | :? TargetInvocationException as e when isNotNull e.InnerException -> !!e.InnerException + | :? TypeInitializationException as e when isNotNull e.InnerException -> !!e.InnerException | _ -> e /// Create an instance of a type provider from the implementation type for the type provider in the /// design-time assembly by using reflection-invoke on a constructor for the type provider. -let CreateTypeProvider ( - typeProviderImplementationType: Type, - runtimeAssemblyPath, - resolutionEnvironment: ResolutionEnvironment, - isInvalidationSupported: bool, - isInteractive: bool, - systemRuntimeContainsType, - systemRuntimeAssemblyVersion, +let CreateTypeProvider + ( + typeProviderImplementationType: Type, + runtimeAssemblyPath, + resolutionEnvironment: ResolutionEnvironment, + isInvalidationSupported: bool, + isInteractive: bool, + systemRuntimeContainsType, + systemRuntimeAssemblyVersion, m ) = - // Protect a .NET reflection call as we load the type provider component into the host process, + // Protect a .NET reflection call as we load the type provider component into the host process, // reporting errors. let protect f = - try + try f () with err -> - let e = StripException (StripException err) - raise (TypeProviderError(FSComp.SR.etTypeProviderConstructorException(e.Message), !! typeProviderImplementationType.FullName, m)) + let e = StripException(StripException err) + + raise ( + TypeProviderError(FSComp.SR.etTypeProviderConstructorException (e.Message), !!typeProviderImplementationType.FullName, m) + ) let getReferencedAssemblies () = resolutionEnvironment.GetReferencedAssemblies() |> Array.distinct - if not(isNull(typeProviderImplementationType.GetConstructor([| typeof |]))) then + if not (isNull (typeProviderImplementationType.GetConstructor([| typeof |]))) then // Create the TypeProviderConfig to pass to the type provider constructor let e = - TypeProviderConfig(systemRuntimeContainsType, - ReferencedAssemblies=getReferencedAssemblies(), - ResolutionFolder=resolutionEnvironment.ResolutionFolder, - RuntimeAssembly=runtimeAssemblyPath, - TemporaryFolder=resolutionEnvironment.TemporaryFolder, - IsInvalidationSupported=isInvalidationSupported, - IsHostedExecution= isInteractive, - SystemRuntimeAssemblyVersion = systemRuntimeAssemblyVersion) - - protect (fun () -> !!(Activator.CreateInstance(typeProviderImplementationType, [| box e|])) :?> ITypeProvider ) - - elif not(isNull(typeProviderImplementationType.GetConstructor [| |])) then - protect (fun () -> !!(Activator.CreateInstance typeProviderImplementationType) :?> ITypeProvider ) + TypeProviderConfig( + systemRuntimeContainsType, + ReferencedAssemblies = getReferencedAssemblies (), + ResolutionFolder = resolutionEnvironment.ResolutionFolder, + RuntimeAssembly = runtimeAssemblyPath, + TemporaryFolder = resolutionEnvironment.TemporaryFolder, + IsInvalidationSupported = isInvalidationSupported, + IsHostedExecution = isInteractive, + SystemRuntimeAssemblyVersion = systemRuntimeAssemblyVersion + ) + + protect (fun () -> !!(Activator.CreateInstance(typeProviderImplementationType, [| box e |])) :?> ITypeProvider) + + elif not (isNull (typeProviderImplementationType.GetConstructor [||])) then + protect (fun () -> !!(Activator.CreateInstance typeProviderImplementationType) :?> ITypeProvider) else // No appropriate constructor found - raise (TypeProviderError(FSComp.SR.etProviderDoesNotHaveValidConstructor(), !! typeProviderImplementationType.FullName, m)) - -let GetTypeProvidersOfAssembly ( - runtimeAssemblyFilename: string, - ilScopeRefOfRuntimeAssembly: ILScopeRef, - designTimeName: string, - resolutionEnvironment: ResolutionEnvironment, - isInvalidationSupported: bool, - isInteractive: bool, - systemRuntimeContainsType: string -> bool, - systemRuntimeAssemblyVersion: Version, + raise (TypeProviderError(FSComp.SR.etProviderDoesNotHaveValidConstructor (), !!typeProviderImplementationType.FullName, m)) + +let GetTypeProvidersOfAssembly + ( + runtimeAssemblyFilename: string, + ilScopeRefOfRuntimeAssembly: ILScopeRef, + designTimeName: string, + resolutionEnvironment: ResolutionEnvironment, + isInvalidationSupported: bool, + isInteractive: bool, + systemRuntimeContainsType: string -> bool, + systemRuntimeAssemblyVersion: Version, compilerToolPaths: string list, - m:range + m: range ) = - let providerSpecs = + let providerSpecs = try - let designTimeAssemblyName = + let designTimeAssemblyName = try if designTimeName.EndsWith(".dll", StringComparison.OrdinalIgnoreCase) then - Some (AssemblyName (!!Path.GetFileNameWithoutExtension(designTimeName))) + Some(AssemblyName(!!Path.GetFileNameWithoutExtension(designTimeName))) else - Some (AssemblyName designTimeName) + Some(AssemblyName designTimeName) with :? ArgumentException -> - errorR(Error(FSComp.SR.etInvalidTypeProviderAssemblyName(runtimeAssemblyFilename, designTimeName), m)) + errorR (Error(FSComp.SR.etInvalidTypeProviderAssemblyName (runtimeAssemblyFilename, designTimeName), m)) None [ match designTimeAssemblyName, resolutionEnvironment.OutputFile with // Check if the attribute is pointing to the file being compiled, in which case ignore it // This checks seems like legacy but is included for compat. - | Some designTimeAssemblyName, Some path - when String.Compare(designTimeAssemblyName.Name, Path.GetFileNameWithoutExtension path, StringComparison.OrdinalIgnoreCase) = 0 -> + | Some designTimeAssemblyName, Some path when + String.Compare(designTimeAssemblyName.Name, Path.GetFileNameWithoutExtension path, StringComparison.OrdinalIgnoreCase) = 0 + -> () | Some _, _ -> - let provImplTypes = GetTypeProviderImplementationTypes (runtimeAssemblyFilename, designTimeName, m, compilerToolPaths) + let provImplTypes = + GetTypeProviderImplementationTypes(runtimeAssemblyFilename, designTimeName, m, compilerToolPaths) + for t in provImplTypes do let resolver = - CreateTypeProvider (t, runtimeAssemblyFilename, resolutionEnvironment, isInvalidationSupported, - isInteractive, systemRuntimeContainsType, systemRuntimeAssemblyVersion, m) - match box resolver with + CreateTypeProvider( + t, + runtimeAssemblyFilename, + resolutionEnvironment, + isInvalidationSupported, + isInteractive, + systemRuntimeContainsType, + systemRuntimeAssemblyVersion, + m + ) + + match box resolver with | null -> () | _ -> yield (resolver, ilScopeRefOfRuntimeAssembly) - | None, _ -> - () + | None, _ -> () ] with :? TypeProviderError as tpe -> - tpe.Iter(fun e -> errorR(Error((e.Number, e.ContextualErrorMessage), m)) ) + tpe.Iter(fun e -> errorR (Error((e.Number, e.ContextualErrorMessage), m))) [] let providers = Tainted<_>.CreateAll(providerSpecs) @@ -204,11 +241,13 @@ let GetTypeProvidersOfAssembly ( let unmarshal (t: Tainted<_>) = t.PUntaintNoFailure id /// Try to access a member on a provided type, catching and reporting errors -let TryTypeMember<'T,'U>(st: Tainted<'T>, fullName, memberName, m, recover, f: 'T -> 'U) : Tainted<'U> = +let TryTypeMember<'T, 'U> (st: Tainted<'T>, fullName, memberName, m, recover, f: 'T -> 'U) : Tainted<'U> = try - st.PApply (f, m) - with :? TypeProviderError as tpe -> - tpe.Iter (fun e -> errorR(Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember(fullName, memberName, e.ContextualErrorMessage), m))) + st.PApply(f, m) + with :? TypeProviderError as tpe -> + tpe.Iter(fun e -> + errorR (Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember (fullName, memberName, e.ContextualErrorMessage), m))) + st.PApplyNoFailure(fun _ -> recover) /// Try to access a member on a provided type, where the result is an array of values, catching and reporting errors @@ -216,49 +255,64 @@ let TryTypeMemberArray (st: Tainted<_>, fullName, memberName, m, f) = try st.PApplyArray(f, memberName, m) with :? TypeProviderError as tpe -> - tpe.Iter (fun e -> error(Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember(fullName, memberName, e.ContextualErrorMessage), m))) + tpe.Iter(fun e -> + error (Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember (fullName, memberName, e.ContextualErrorMessage), m))) + [||] -/// Try to access a member on a provided type, catching and reporting errors and checking the result is non-null, -let TryTypeMemberNonNull<'T, 'U when 'U : not null and 'U : not struct>(st: Tainted<'T>, fullName, memberName, m, recover: 'U, (f: 'T -> 'U | null)) : Tainted<'U> = - match TryTypeMember<'T, 'U | null>(st, fullName, memberName, m, withNull recover, f) with - | Tainted.Null -> - errorR(Error(FSComp.SR.etUnexpectedNullFromProvidedTypeMember(fullName, memberName), m)) +/// Try to access a member on a provided type, catching and reporting errors and checking the result is non-null, +let TryTypeMemberNonNull<'T, 'U when 'U: not null and 'U: not struct> + (st: Tainted<'T>, fullName, memberName, m, recover: 'U, (f: 'T -> 'U | null)) + : Tainted<'U> = + match TryTypeMember<'T, 'U | null>(st, fullName, memberName, m, withNull recover, f) with + | Tainted.Null -> + errorR (Error(FSComp.SR.etUnexpectedNullFromProvidedTypeMember (fullName, memberName), m)) st.PApplyNoFailure(fun _ -> recover) - | Tainted.NonNull r -> - r + | Tainted.NonNull r -> r /// Try to access a property or method on a provided member, catching and reporting errors -let TryMemberMember (mi: Tainted<_>, typeName, memberName, memberMemberName, m, recover, f) = +let TryMemberMember (mi: Tainted<_>, typeName, memberName, memberMemberName, m, recover, f) = try - mi.PApply (f, m) + mi.PApply(f, m) with :? TypeProviderError as tpe -> - tpe.Iter (fun e -> errorR(Error(FSComp.SR.etUnexpectedExceptionFromProvidedMemberMember(memberMemberName, typeName, memberName, e.ContextualErrorMessage), m))) + tpe.Iter(fun e -> + errorR ( + Error( + FSComp.SR.etUnexpectedExceptionFromProvidedMemberMember ( + memberMemberName, + typeName, + memberName, + e.ContextualErrorMessage + ), + m + ) + )) + mi.PApplyNoFailure(fun _ -> recover) /// Get the string to show for the name of a type provider -let DisplayNameOfTypeProvider(resolver: Tainted, m: range) = +let DisplayNameOfTypeProvider (resolver: Tainted, m: range) = resolver.PUntaint((fun tp -> tp.GetType().Name), m) /// Validate a provided namespace name -let ValidateNamespaceName(name, typeProvider: Tainted, m, nsp: string MaybeNull) = - match nsp with +let ValidateNamespaceName (name, typeProvider: Tainted, m, nsp: string MaybeNull) = + match nsp with | Null -> () - | NonNull nsp -> + | NonNull nsp -> if String.IsNullOrWhiteSpace nsp then // Empty namespace is not allowed - errorR(Error(FSComp.SR.etEmptyNamespaceOfTypeNotAllowed(name, typeProvider.PUntaint((fun tp -> tp.GetType().Name), m)), m)) + errorR (Error(FSComp.SR.etEmptyNamespaceOfTypeNotAllowed (name, typeProvider.PUntaint((fun tp -> tp.GetType().Name), m)), m)) else for s in nsp.Split('.') do match s.IndexOfAny(PrettyNaming.IllegalCharactersInTypeAndNamespaceNames) with | -1 -> () - | n -> errorR(Error(FSComp.SR.etIllegalCharactersInNamespaceName(string s[n], s), m)) + | n -> errorR (Error(FSComp.SR.etIllegalCharactersInNamespaceName (string s[n], s), m)) let bindingFlags = - BindingFlags.DeclaredOnly ||| - BindingFlags.Static ||| - BindingFlags.Instance ||| - BindingFlags.Public + BindingFlags.DeclaredOnly + ||| BindingFlags.Static + ||| BindingFlags.Instance + ||| BindingFlags.Public // NOTE: for the purposes of remapping the closure of generated types, the FullName is sufficient. // We do _not_ rely on object identity or any other notion of equivalence provided by System.Type @@ -266,11 +320,11 @@ let bindingFlags = // example RuntimeType overrides the equality relation to be reference equality for the Equals(object) // override, but the other subtypes of System.Type do not, making the relation non-reflective. // -// Further, avoiding reliance on canonicalization (UnderlyingSystemType) or System.Type object identity means that +// Further, avoiding reliance on canonicalization (UnderlyingSystemType) or System.Type object identity means that // providers can implement wrap-and-filter "views" over existing System.Type clusters without needing // to preserve object identity when presenting the types to the F# compiler. -type ProvidedTypeComparer() = +type ProvidedTypeComparer() = let key (ty: ProvidedType) = match ty.Assembly with | Null -> ("", ty.FullName) @@ -280,9 +334,11 @@ type ProvidedTypeComparer() = interface IEqualityComparer with member _.GetHashCode(ty: ProvidedType) = hash (key ty) - member _.Equals(ty1: ProvidedType, ty2: ProvidedType) = nullSafeEquality ty1 ty2 (fun ty1 ty2 -> key ty1 = key ty2) -/// The context used to interpret information in the closure of System.Type, System.MethodInfo and other + member _.Equals(ty1: ProvidedType, ty2: ProvidedType) = + nullSafeEquality ty1 ty2 (fun ty1 ty2 -> key ty1 = key ty2) + +/// The context used to interpret information in the closure of System.Type, System.MethodInfo and other /// info objects coming from the type provider. /// /// This is the "Type --> Tycon" remapping context of the type. This is only present for generated provided types, and contains @@ -290,7 +346,7 @@ type ProvidedTypeComparer() = /// /// Laziness is used "to prevent needless computation for every type during remapping". However it /// appears that the laziness likely serves no purpose and could be safely removed. -type ProvidedTypeContext = +type ProvidedTypeContext = | NoEntries // The dictionaries are safe because the ProvidedType with the ProvidedTypeContext are only accessed one thread at a time during type-checking. | Entries of ConcurrentDictionary * InterruptibleLazy> @@ -299,119 +355,154 @@ type ProvidedTypeContext = static member Create(d1, d2) = Entries(d1, notlazy d2) - member ctxt.GetDictionaries() = + member ctxt.GetDictionaries() = + match ctxt with + | NoEntries -> + ConcurrentDictionary(ProvidedTypeComparer.Instance), + ConcurrentDictionary(ProvidedTypeComparer.Instance) + | Entries(lookupILTR, lookupILTCR) -> lookupILTR, lookupILTCR.Force() + + member ctxt.TryGetILTypeRef st = match ctxt with - | NoEntries -> - ConcurrentDictionary(ProvidedTypeComparer.Instance), ConcurrentDictionary(ProvidedTypeComparer.Instance) - | Entries (lookupILTR, lookupILTCR) -> - lookupILTR, lookupILTCR.Force() - - member ctxt.TryGetILTypeRef st = - match ctxt with - | NoEntries -> None - | Entries(d, _) -> + | NoEntries -> None + | Entries(d, _) -> match d.TryGetValue st with | true, res -> Some res | _ -> None - member ctxt.TryGetTyconRef st = - match ctxt with - | NoEntries -> None - | Entries(_, d) -> + member ctxt.TryGetTyconRef st = + match ctxt with + | NoEntries -> None + | Entries(_, d) -> let d = d.Force() + match d.TryGetValue st with | true, res -> Some res | _ -> None - member ctxt.RemapTyconRefs (f: obj->obj) = - match ctxt with + member ctxt.RemapTyconRefs(f: obj -> obj) = + match ctxt with | NoEntries -> NoEntries | Entries(d1, d2) -> - Entries(d1, InterruptibleLazy(fun _ -> - let dict = ConcurrentDictionary(ProvidedTypeComparer.Instance) - for KeyValue (st, tcref) in d2.Force() do dict.TryAdd(st, f tcref) |> ignore - dict - )) + Entries( + d1, + InterruptibleLazy(fun _ -> + let dict = ConcurrentDictionary(ProvidedTypeComparer.Instance) + + for KeyValue(st, tcref) in d2.Force() do + dict.TryAdd(st, f tcref) |> ignore + + dict) + ) [] -type ProvidedType (x: Type, ctxt: ProvidedTypeContext) = +type ProvidedType(x: Type, ctxt: ProvidedTypeContext) = inherit ProvidedMemberInfo(x, ctxt) - let isMeasure = + let isMeasure = lazy - x.CustomAttributes - |> Seq.exists (fun a -> (!! a.Constructor.DeclaringType).FullName = typeof.FullName) + x.CustomAttributes + |> Seq.exists (fun a -> (!!a.Constructor.DeclaringType).FullName = typeof.FullName) - let provide () = ProvidedCustomAttributeProvider (fun _ -> x.CustomAttributes) :> IProvidedCustomAttributeProvider + let provide () = + ProvidedCustomAttributeProvider(fun _ -> x.CustomAttributes) :> IProvidedCustomAttributeProvider + + interface IProvidedCustomAttributeProvider with + member _.GetHasTypeProviderEditorHideMethodsAttribute provider = + provide().GetHasTypeProviderEditorHideMethodsAttribute provider + + member _.GetDefinitionLocationAttribute provider = + provide().GetDefinitionLocationAttribute provider - interface IProvidedCustomAttributeProvider with - member _.GetHasTypeProviderEditorHideMethodsAttribute provider = provide().GetHasTypeProviderEditorHideMethodsAttribute provider - member _.GetDefinitionLocationAttribute provider = provide().GetDefinitionLocationAttribute provider member _.GetXmlDocAttributes provider = provide().GetXmlDocAttributes provider - - // The type provider spec distinguishes between + + // The type provider spec distinguishes between // - calls that can be made on provided types (i.e. types given by ReturnType, ParameterType, and generic argument types) // - calls that can be made on provided type definitions (types returned by ResolveTypeName, GetTypes etc.) // Ideally we would enforce this decision structurally by having both ProvidedType and ProvidedTypeDefinition. // Alternatively we could use assertions to enforce this. // Suppress relocation of generated types - member _.IsSuppressRelocate = (x.Attributes &&& enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) <> enum 0 + member _.IsSuppressRelocate = + (x.Attributes &&& enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) + <> enum 0 - member _.IsErased = (x.Attributes &&& enum (int32 TypeProviderTypeAttributes.IsErased)) <> enum 0 + member _.IsErased = + (x.Attributes &&& enum (int32 TypeProviderTypeAttributes.IsErased)) <> enum 0 member _.IsGenericType = x.IsGenericType - member _.Namespace : string MaybeNull = x.Namespace + member _.Namespace: string MaybeNull = x.Namespace - member _.FullName : string MaybeNull = x.FullName + member _.FullName: string MaybeNull = x.FullName member _.IsArray = x.IsArray member _.Assembly: ProvidedAssembly MaybeNull = x.Assembly |> ProvidedAssembly.Create - member _.GetInterfaces() = x.GetInterfaces() |> ProvidedType.CreateArray ctxt + member _.GetInterfaces() = + x.GetInterfaces() |> ProvidedType.CreateArray ctxt - member _.GetMethods() = x.GetMethods bindingFlags |> ProvidedMethodInfo.CreateArray ctxt + member _.GetMethods() = + x.GetMethods bindingFlags |> ProvidedMethodInfo.CreateArray ctxt - member _.GetEvents() = x.GetEvents bindingFlags |> ProvidedEventInfo.CreateArray ctxt + member _.GetEvents() = + x.GetEvents bindingFlags |> ProvidedEventInfo.CreateArray ctxt - member _.GetEvent nm = x.GetEvent(nm, bindingFlags) |> ProvidedEventInfo.Create ctxt + member _.GetEvent nm = + x.GetEvent(nm, bindingFlags) |> ProvidedEventInfo.Create ctxt - member _.GetProperties() = x.GetProperties bindingFlags |> ProvidedPropertyInfo.CreateArray ctxt + member _.GetProperties() = + x.GetProperties bindingFlags |> ProvidedPropertyInfo.CreateArray ctxt - member _.GetProperty nm = x.GetProperty(nm, bindingFlags) |> ProvidedPropertyInfo.Create ctxt + member _.GetProperty nm = + x.GetProperty(nm, bindingFlags) |> ProvidedPropertyInfo.Create ctxt - member _.GetConstructors() = x.GetConstructors bindingFlags |> ProvidedConstructorInfo.CreateArray ctxt + member _.GetConstructors() = + x.GetConstructors bindingFlags |> ProvidedConstructorInfo.CreateArray ctxt - member _.GetFields() = x.GetFields bindingFlags |> ProvidedFieldInfo.CreateArray ctxt + member _.GetFields() = + x.GetFields bindingFlags |> ProvidedFieldInfo.CreateArray ctxt - member _.GetField nm = x.GetField(nm, bindingFlags) |> ProvidedFieldInfo.Create ctxt + member _.GetField nm = + x.GetField(nm, bindingFlags) |> ProvidedFieldInfo.Create ctxt - member _.GetAllNestedTypes() = x.GetNestedTypes(bindingFlags ||| BindingFlags.NonPublic) |> ProvidedType.CreateArray ctxt + member _.GetAllNestedTypes() = + x.GetNestedTypes(bindingFlags ||| BindingFlags.NonPublic) + |> ProvidedType.CreateArray ctxt - member _.GetNestedTypes() = x.GetNestedTypes bindingFlags |> ProvidedType.CreateArray ctxt + member _.GetNestedTypes() = + x.GetNestedTypes bindingFlags |> ProvidedType.CreateArray ctxt /// Type.GetNestedType(string) can return null if there is no nested type with given name - member _.GetNestedType nm = x.GetNestedType (nm, bindingFlags) |> ProvidedType.Create ctxt + member _.GetNestedType nm = + x.GetNestedType(nm, bindingFlags) |> ProvidedType.Create ctxt /// Type.GetGenericTypeDefinition() either returns type or throws exception, null is not permitted - member _.GetGenericTypeDefinition() = x.GetGenericTypeDefinition() |> ProvidedType.CreateWithNullCheck ctxt "GenericTypeDefinition" + member _.GetGenericTypeDefinition() = + x.GetGenericTypeDefinition() + |> ProvidedType.CreateWithNullCheck ctxt "GenericTypeDefinition" /// Type.BaseType can be null when Type is interface or object member _.BaseType = x.BaseType |> ProvidedType.Create ctxt - member _.GetStaticParameters(provider: ITypeProvider) : ProvidedParameterInfo ProvidedArray = provider.GetStaticParameters x |> ProvidedParameterInfo.CreateArray ctxt + member _.GetStaticParameters(provider: ITypeProvider) : ProvidedParameterInfo ProvidedArray = + provider.GetStaticParameters x |> ProvidedParameterInfo.CreateArray ctxt /// Type.GetElementType can be null if i.e. Type is not array\pointer\byref type - member _.GetElementType() = x.GetElementType() |> ProvidedType.Create ctxt + member _.GetElementType() = + x.GetElementType() |> ProvidedType.Create ctxt - member _.GetGenericArguments() = x.GetGenericArguments() |> ProvidedType.CreateArray ctxt + member _.GetGenericArguments() = + x.GetGenericArguments() |> ProvidedType.CreateArray ctxt - member _.ApplyStaticArguments(provider: ITypeProvider, fullTypePathAfterArguments, staticArgs: objnull[]) = - provider.ApplyStaticArguments(x, fullTypePathAfterArguments, staticArgs) |> ProvidedType.Create ctxt + member _.ApplyStaticArguments(provider: ITypeProvider, fullTypePathAfterArguments, staticArgs: objnull[]) = + provider.ApplyStaticArguments(x, fullTypePathAfterArguments, staticArgs) + |> ProvidedType.Create ctxt - member _.IsVoid = (Type.op_Equality(x, typeof) || (x.Namespace = "System" && x.Name = "Void")) + member _.IsVoid = + (Type.op_Equality (x, typeof) + || (x.Namespace = "System" && x.Name = "Void")) member _.IsGenericParameter = x.IsGenericParameter @@ -444,48 +535,61 @@ type ProvidedType (x: Type, ctxt: ProvidedTypeContext) = member _.RawSystemType = x /// Type.GetEnumUnderlyingType either returns type or raises exception, null is not permitted - member _.GetEnumUnderlyingType() = - x.GetEnumUnderlyingType() - |> ProvidedType.CreateWithNullCheck ctxt "EnumUnderlyingType" + member _.GetEnumUnderlyingType() = + x.GetEnumUnderlyingType() + |> ProvidedType.CreateWithNullCheck ctxt "EnumUnderlyingType" - member _.MakePointerType() = ProvidedType.CreateNoContext(x.MakePointerType()) + member _.MakePointerType() = + ProvidedType.CreateNoContext(x.MakePointerType()) - member _.MakeByRefType() = ProvidedType.CreateNoContext(x.MakeByRefType()) + member _.MakeByRefType() = + ProvidedType.CreateNoContext(x.MakeByRefType()) - member _.MakeArrayType() = ProvidedType.CreateNoContext(x.MakeArrayType()) + member _.MakeArrayType() = + ProvidedType.CreateNoContext(x.MakeArrayType()) - member _.MakeArrayType rank = ProvidedType.CreateNoContext(x.MakeArrayType(rank)) + member _.MakeArrayType rank = + ProvidedType.CreateNoContext(x.MakeArrayType(rank)) - member _.MakeGenericType (args: ProvidedType[]) = + member _.MakeGenericType(args: ProvidedType[]) = let argTypes = args |> Array.map (fun arg -> arg.RawSystemType) ProvidedType.CreateNoContext(x.MakeGenericType(argTypes)) - member _.AsProvidedVar name = ProvidedVar.CreateNonNull ctxt (Quotations.Var(name, x)) + member _.AsProvidedVar name = + ProvidedVar.CreateNonNull ctxt (Quotations.Var(name, x)) - static member Create ctxt x : ProvidedType MaybeNull = - match x with - | Null -> null - | NonNull t -> ProvidedType (t, ctxt) + static member Create ctxt x : ProvidedType MaybeNull = + match x with + | Null -> null + | NonNull t -> ProvidedType(t, ctxt) - static member CreateNonNull ctxt x = ProvidedType (x, ctxt) + static member CreateNonNull ctxt x = ProvidedType(x, ctxt) - static member CreateWithNullCheck ctxt name (x:Type MaybeNull) = + static member CreateWithNullCheck ctxt name (x: Type MaybeNull) = match x with - | null -> nullArg name - | t -> ProvidedType (t, ctxt) + | null -> nullArg name + | t -> ProvidedType(t, ctxt) - static member CreateArray ctxt (xs:_ ProvidedArray) = + static member CreateArray ctxt (xs: _ ProvidedArray) = xs |> ProvidedArray.map (ProvidedType.CreateNonNull ctxt) - static member CreateNoContext (x:Type) = ProvidedType.CreateNonNull ProvidedTypeContext.Empty x + static member CreateNoContext(x: Type) = + ProvidedType.CreateNonNull ProvidedTypeContext.Empty x static member Void = ProvidedType.CreateNoContext typeof member _.Handle = x - override _.Equals y = assert false; match y with :? ProvidedType as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false - override _.GetHashCode() = assert false; x.GetHashCode() + match y with + | :? ProvidedType as y -> x.Equals y.Handle + | _ -> false + + override _.GetHashCode() = + assert false + x.GetHashCode() member _.Context = ctxt @@ -493,97 +597,142 @@ type ProvidedType (x: Type, ctxt: ProvidedTypeContext) = member this.TryGetTyconRef() = this.Context.TryGetTyconRef this - static member ApplyContext (pt: ProvidedType, ctxt) = ProvidedType(pt.Handle, ctxt) + static member ApplyContext(pt: ProvidedType, ctxt) = ProvidedType(pt.Handle, ctxt) - static member TaintedEquals (pt1: Tainted, pt2: Tainted) = + static member TaintedEquals(pt1: Tainted, pt2: Tainted) = Tainted.EqTainted (pt1.PApplyNoFailure(fun st -> st.Handle)) (pt2.PApplyNoFailure(fun st -> st.Handle)) type IProvidedCustomAttributeProvider = - abstract GetDefinitionLocationAttribute : provider: ITypeProvider -> (string MaybeNull * int * int) option + abstract GetDefinitionLocationAttribute: provider: ITypeProvider -> (string MaybeNull * int * int) option - abstract GetXmlDocAttributes : provider: ITypeProvider -> string[] + abstract GetXmlDocAttributes: provider: ITypeProvider -> string[] - abstract GetHasTypeProviderEditorHideMethodsAttribute : provider:ITypeProvider -> bool + abstract GetHasTypeProviderEditorHideMethodsAttribute: provider: ITypeProvider -> bool - abstract GetAttributeConstructorArgs: provider:ITypeProvider * attribName:string -> (obj option list * (string * obj option) list) option + abstract GetAttributeConstructorArgs: + provider: ITypeProvider * attribName: string -> (obj option list * (string * obj option) list) option -type ProvidedCustomAttributeProvider (attributes :ITypeProvider -> seq) = +type ProvidedCustomAttributeProvider(attributes: ITypeProvider -> seq) = [] - let (|Member|_|) (s: string) (x: CustomAttributeNamedArgument) = if x.MemberName = s then ValueSome x.TypedValue else ValueNone + let (|Member|_|) (s: string) (x: CustomAttributeNamedArgument) = + if x.MemberName = s then + ValueSome x.TypedValue + else + ValueNone [] - let (|Arg|_|) (x: CustomAttributeTypedArgument) = match x.Value with null -> ValueNone | v -> ValueSome v + let (|Arg|_|) (x: CustomAttributeTypedArgument) = + match x.Value with + | null -> ValueNone + | v -> ValueSome v - let findAttribByName tyFullName (a: CustomAttributeData) = ((!!a.Constructor.DeclaringType).FullName = tyFullName) + let findAttribByName tyFullName (a: CustomAttributeData) = + ((!!a.Constructor.DeclaringType).FullName = tyFullName) let findAttrib (ty: Type) a = findAttribByName ty.FullName a - interface IProvidedCustomAttributeProvider with - member _.GetAttributeConstructorArgs (provider, attribName) = - attributes provider - |> Seq.tryFind (findAttribByName attribName) - |> Option.map (fun a -> - let ctorArgs = - a.ConstructorArguments - |> Seq.toList - |> List.map (function Arg obj -> Some obj | _ -> None) - let namedArgs = - a.NamedArguments - |> Seq.toList - |> List.map (fun arg -> arg.MemberName, match arg.TypedValue with Arg obj -> Some obj | _ -> None) + + interface IProvidedCustomAttributeProvider with + member _.GetAttributeConstructorArgs(provider, attribName) = + attributes provider + |> Seq.tryFind (findAttribByName attribName) + |> Option.map (fun a -> + let ctorArgs = + a.ConstructorArguments + |> Seq.toList + |> List.map (function + | Arg obj -> Some obj + | _ -> None) + + let namedArgs = + a.NamedArguments + |> Seq.toList + |> List.map (fun arg -> + arg.MemberName, + match arg.TypedValue with + | Arg obj -> Some obj + | _ -> None) + ctorArgs, namedArgs) - member _.GetHasTypeProviderEditorHideMethodsAttribute provider = - attributes provider - |> Seq.exists (findAttrib typeof) - - member _.GetDefinitionLocationAttribute provider = - attributes provider - |> Seq.tryFind (findAttrib typeof) - |> Option.map (fun a -> - let filePath : string MaybeNull = defaultArg (a.NamedArguments |> Seq.tryPick (function Member "FilePath" (Arg (:? string as v)) -> Some v | _ -> None)) null - let line = defaultArg (a.NamedArguments |> Seq.tryPick (function Member "Line" (Arg (:? int as v)) -> Some v | _ -> None)) 0 - let column = defaultArg (a.NamedArguments |> Seq.tryPick (function Member "Column" (Arg (:? int as v)) -> Some v | _ -> None)) 0 + member _.GetHasTypeProviderEditorHideMethodsAttribute provider = + attributes provider + |> Seq.exists (findAttrib typeof) + + member _.GetDefinitionLocationAttribute provider = + attributes provider + |> Seq.tryFind (findAttrib typeof) + |> Option.map (fun a -> + let filePath: string MaybeNull = + defaultArg + (a.NamedArguments + |> Seq.tryPick (function + | Member "FilePath" (Arg(:? string as v)) -> Some v + | _ -> None)) + null + + let line = + defaultArg + (a.NamedArguments + |> Seq.tryPick (function + | Member "Line" (Arg(:? int as v)) -> Some v + | _ -> None)) + 0 + + let column = + defaultArg + (a.NamedArguments + |> Seq.tryPick (function + | Member "Column" (Arg(:? int as v)) -> Some v + | _ -> None)) + 0 + (filePath, line, column)) - member _.GetXmlDocAttributes provider = - attributes provider - |> Seq.choose (fun a -> - if findAttrib typeof a then - match a.ConstructorArguments |> Seq.toList with + member _.GetXmlDocAttributes provider = + attributes provider + |> Seq.choose (fun a -> + if findAttrib typeof a then + match a.ConstructorArguments |> Seq.toList with | [ Arg(:? string as s) ] -> Some s | _ -> None - else - None) + else + None) |> Seq.toArray -[] -type ProvidedMemberInfo (x: MemberInfo, ctxt) = - let provide () = ProvidedCustomAttributeProvider (fun _ -> x.CustomAttributes) :> IProvidedCustomAttributeProvider +[] +type ProvidedMemberInfo(x: MemberInfo, ctxt) = + let provide () = + ProvidedCustomAttributeProvider(fun _ -> x.CustomAttributes) :> IProvidedCustomAttributeProvider member _.Name = x.Name /// DeclaringType can be null if MemberInfo belongs to Module, not to Type member _.DeclaringType = ProvidedType.Create ctxt x.DeclaringType - interface IProvidedCustomAttributeProvider with + interface IProvidedCustomAttributeProvider with member _.GetHasTypeProviderEditorHideMethodsAttribute provider = provide().GetHasTypeProviderEditorHideMethodsAttribute provider member _.GetDefinitionLocationAttribute provider = provide().GetDefinitionLocationAttribute provider - member _.GetXmlDocAttributes provider = - provide().GetXmlDocAttributes provider + member _.GetXmlDocAttributes provider = provide().GetXmlDocAttributes provider - member _.GetAttributeConstructorArgs (provider, attribName) = - provide().GetAttributeConstructorArgs (provider, attribName) + member _.GetAttributeConstructorArgs(provider, attribName) = + provide().GetAttributeConstructorArgs(provider, attribName) + +[] +type ProvidedParameterInfo(x: ParameterInfo, ctxt) = + let provide () = + ProvidedCustomAttributeProvider(fun _ -> x.CustomAttributes) :> IProvidedCustomAttributeProvider -[] -type ProvidedParameterInfo (x: ParameterInfo, ctxt) = - let provide () = ProvidedCustomAttributeProvider (fun _ -> x.CustomAttributes) :> IProvidedCustomAttributeProvider + member _.Name = + let nm = x.Name in - member _.Name = let nm = x.Name in match box nm with null -> "" | _ -> !!nm + match box nm with + | null -> "" + | _ -> !!nm member _.IsOut = x.IsOut @@ -591,44 +740,51 @@ type ProvidedParameterInfo (x: ParameterInfo, ctxt) = member _.IsOptional = x.IsOptional - member _.RawDefaultValue : objnull = x.RawDefaultValue + member _.RawDefaultValue: objnull = x.RawDefaultValue member _.HasDefaultValue = x.Attributes.HasFlag(ParameterAttributes.HasDefault) /// ParameterInfo.ParameterType cannot be null - member _.ParameterType = ProvidedType.CreateWithNullCheck ctxt "ParameterType" x.ParameterType - - static member Create ctxt (x: ParameterInfo MaybeNull) : ProvidedParameterInfo MaybeNull = - match x with - | Null -> null - | NonNull x -> ProvidedParameterInfo (x, ctxt) - - static member CreateNonNull ctxt x = ProvidedParameterInfo (x, ctxt) - - static member CreateArray ctxt (xs: ParameterInfo ProvidedArray) : ProvidedParameterInfo ProvidedArray = + member _.ParameterType = + ProvidedType.CreateWithNullCheck ctxt "ParameterType" x.ParameterType + + static member Create ctxt (x: ParameterInfo MaybeNull) : ProvidedParameterInfo MaybeNull = + match x with + | Null -> null + | NonNull x -> ProvidedParameterInfo(x, ctxt) + + static member CreateNonNull ctxt x = ProvidedParameterInfo(x, ctxt) + + static member CreateArray ctxt (xs: ParameterInfo ProvidedArray) : ProvidedParameterInfo ProvidedArray = xs |> ProvidedArray.map (ProvidedParameterInfo.CreateNonNull ctxt) - - interface IProvidedCustomAttributeProvider with + + interface IProvidedCustomAttributeProvider with member _.GetHasTypeProviderEditorHideMethodsAttribute provider = provide().GetHasTypeProviderEditorHideMethodsAttribute provider member _.GetDefinitionLocationAttribute provider = provide().GetDefinitionLocationAttribute provider - member _.GetXmlDocAttributes provider = - provide().GetXmlDocAttributes provider + member _.GetXmlDocAttributes provider = provide().GetXmlDocAttributes provider - member _.GetAttributeConstructorArgs (provider, attribName) = - provide().GetAttributeConstructorArgs (provider, attribName) + member _.GetAttributeConstructorArgs(provider, attribName) = + provide().GetAttributeConstructorArgs(provider, attribName) member _.Handle = x - override _.Equals y = assert false; match y with :? ProvidedParameterInfo as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false - override _.GetHashCode() = assert false; x.GetHashCode() + match y with + | :? ProvidedParameterInfo as y -> x.Equals y.Handle + | _ -> false -[] -type ProvidedAssembly (x: Assembly) = + override _.GetHashCode() = + assert false + x.GetHashCode() + +[] +type ProvidedAssembly(x: Assembly) = member _.GetName() = x.GetName() @@ -636,120 +792,155 @@ type ProvidedAssembly (x: Assembly) = member _.GetManifestModuleContents(provider: ITypeProvider) = provider.GetGeneratedAssemblyContents x - static member Create (x: Assembly MaybeNull) : ProvidedAssembly MaybeNull = match x with null -> null | t -> ProvidedAssembly (t) + static member Create(x: Assembly MaybeNull) : ProvidedAssembly MaybeNull = + match x with + | null -> null + | t -> ProvidedAssembly(t) member _.Handle = x - override _.Equals y = assert false; match y with :? ProvidedAssembly as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false + + match y with + | :? ProvidedAssembly as y -> x.Equals y.Handle + | _ -> false - override _.GetHashCode() = assert false; x.GetHashCode() + override _.GetHashCode() = + assert false + x.GetHashCode() -[] -type ProvidedMethodBase (x: MethodBase, ctxt) = +[] +type ProvidedMethodBase(x: MethodBase, ctxt) = inherit ProvidedMemberInfo(x, ctxt) member _.Context = ctxt member _.IsGenericMethod = x.IsGenericMethod - member _.IsStatic = x.IsStatic + member _.IsStatic = x.IsStatic - member _.IsFamily = x.IsFamily + member _.IsFamily = x.IsFamily member _.IsFamilyOrAssembly = x.IsFamilyOrAssembly member _.IsFamilyAndAssembly = x.IsFamilyAndAssembly - member _.IsVirtual = x.IsVirtual + member _.IsVirtual = x.IsVirtual member _.IsFinal = x.IsFinal member _.IsPublic = x.IsPublic - member _.IsAbstract = x.IsAbstract + member _.IsAbstract = x.IsAbstract member _.IsHideBySig = x.IsHideBySig - member _.IsConstructor = x.IsConstructor + member _.IsConstructor = x.IsConstructor - member _.GetParameters() = x.GetParameters() |> ProvidedParameterInfo.CreateArray ctxt + member _.GetParameters() = + x.GetParameters() |> ProvidedParameterInfo.CreateArray ctxt - member _.GetGenericArguments() = x.GetGenericArguments() |> ProvidedType.CreateArray ctxt + member _.GetGenericArguments() = + x.GetGenericArguments() |> ProvidedType.CreateArray ctxt member _.Handle = x - static member TaintedGetHashCode (x: Tainted) = - Tainted.GetHashCodeTainted - (x.PApplyNoFailure(fun st -> (st.Name, (nonNull (nonNull st.DeclaringType).Assembly).FullName, - (nonNull st.DeclaringType).FullName))) + static member TaintedGetHashCode(x: Tainted) = + Tainted.GetHashCodeTainted( + x.PApplyNoFailure(fun st -> + (st.Name, + (nonNull (nonNull st.DeclaringType).Assembly).FullName, + (nonNull st.DeclaringType).FullName)) + ) - static member TaintedEquals (pt1: Tainted, pt2: Tainted) = + static member TaintedEquals(pt1: Tainted, pt2: Tainted) = Tainted.EqTainted (pt1.PApplyNoFailure(fun st -> st.Handle)) (pt2.PApplyNoFailure(fun st -> st.Handle)) - member _.GetStaticParametersForMethod(provider: ITypeProvider) : ProvidedParameterInfo ProvidedArray = - let bindingFlags = BindingFlags.Instance ||| BindingFlags.NonPublic ||| BindingFlags.Public + member _.GetStaticParametersForMethod(provider: ITypeProvider) : ProvidedParameterInfo ProvidedArray = + let bindingFlags = + BindingFlags.Instance ||| BindingFlags.NonPublic ||| BindingFlags.Public - let staticParams = - match provider with - | :? ITypeProvider2 as itp2 -> - itp2.GetStaticParametersForMethod x - | _ -> + let staticParams = + match provider with + | :? ITypeProvider2 as itp2 -> itp2.GetStaticParametersForMethod x + | _ -> // To allow a type provider to depend only on FSharp.Core 4.3.0.0, it can alternatively // implement an appropriate method called GetStaticParametersForMethod let meth = - provider.GetType().GetMethod( "GetStaticParametersForMethod", bindingFlags, null, - [| typeof |], null) - if isNull meth then [| |] else - let paramsAsObj = - try (!!meth).Invoke(provider, bindingFlags ||| BindingFlags.InvokeMethod, null, [| box x |], null) - with err -> raise (StripException (StripException err)) - !!paramsAsObj :?> ParameterInfo[] + provider.GetType().GetMethod("GetStaticParametersForMethod", bindingFlags, null, [| typeof |], null) + + if isNull meth then + [||] + else + let paramsAsObj = + try + (!!meth).Invoke(provider, bindingFlags ||| BindingFlags.InvokeMethod, null, [| box x |], null) + with err -> + raise (StripException(StripException err)) + + !!paramsAsObj :?> ParameterInfo[] staticParams |> ProvidedParameterInfo.CreateArray ctxt - member _.ApplyStaticArgumentsForMethod(provider: ITypeProvider, fullNameAfterArguments: string, staticArgs: objnull[]) = - let bindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.InvokeMethod + member _.ApplyStaticArgumentsForMethod(provider: ITypeProvider, fullNameAfterArguments: string, staticArgs: objnull[]) = + let bindingFlags = + BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.InvokeMethod - let mb = - match provider with - | :? ITypeProvider2 as itp2 -> - itp2.ApplyStaticArgumentsForMethod(x, fullNameAfterArguments, staticArgs) - | _ -> + let mb = + match provider with + | :? ITypeProvider2 as itp2 -> itp2.ApplyStaticArgumentsForMethod(x, fullNameAfterArguments, staticArgs) + | _ -> // To allow a type provider to depend only on FSharp.Core 4.3.0.0, it can alternatively implement a method called GetStaticParametersForMethod let meth = - provider.GetType().GetMethod( "ApplyStaticArgumentsForMethod", bindingFlags, null, - [| typeof; typeof; typeof |], null) - - match meth with - | null -> failwith (FSComp.SR.estApplyStaticArgumentsForMethodNotImplemented()) - | meth -> - - let mbAsObj = - try meth.Invoke(provider, bindingFlags ||| BindingFlags.InvokeMethod, null, [| box x; box fullNameAfterArguments; box staticArgs |], null) - with err -> raise (StripException (StripException err)) - - match mbAsObj with - | :? MethodBase as mb -> mb - | _ -> failwith (FSComp.SR.estApplyStaticArgumentsForMethodNotImplemented()) - match mb with - | :? MethodInfo as mi -> (mi |> ProvidedMethodInfo.CreateNonNull ctxt : ProvidedMethodInfo) :> ProvidedMethodBase - | :? ConstructorInfo as ci -> (ci |> ProvidedConstructorInfo.CreateNonNull ctxt : ProvidedConstructorInfo) :> ProvidedMethodBase - | _ -> failwith (FSComp.SR.estApplyStaticArgumentsForMethodNotImplemented()) + provider + .GetType() + .GetMethod( + "ApplyStaticArgumentsForMethod", + bindingFlags, + null, + [| typeof; typeof; typeof |], + null + ) + + match meth with + | null -> failwith (FSComp.SR.estApplyStaticArgumentsForMethodNotImplemented ()) + | meth -> + + let mbAsObj = + try + meth.Invoke( + provider, + bindingFlags ||| BindingFlags.InvokeMethod, + null, + [| box x; box fullNameAfterArguments; box staticArgs |], + null + ) + with err -> + raise (StripException(StripException err)) + + match mbAsObj with + | :? MethodBase as mb -> mb + | _ -> failwith (FSComp.SR.estApplyStaticArgumentsForMethodNotImplemented ()) + + match mb with + | :? MethodInfo as mi -> (mi |> ProvidedMethodInfo.CreateNonNull ctxt: ProvidedMethodInfo) :> ProvidedMethodBase + | :? ConstructorInfo as ci -> (ci |> ProvidedConstructorInfo.CreateNonNull ctxt: ProvidedConstructorInfo) :> ProvidedMethodBase + | _ -> failwith (FSComp.SR.estApplyStaticArgumentsForMethodNotImplemented ()) - -[] -type ProvidedFieldInfo (x: FieldInfo, ctxt) = +[] +type ProvidedFieldInfo(x: FieldInfo, ctxt) = inherit ProvidedMemberInfo(x, ctxt) - static member CreateNonNull ctxt x = ProvidedFieldInfo (x, ctxt) + static member CreateNonNull ctxt x = ProvidedFieldInfo(x, ctxt) - static member Create ctxt x : ProvidedFieldInfo MaybeNull = - match x with - | Null -> null - | NonNull x -> ProvidedFieldInfo (x, ctxt) + static member Create ctxt x : ProvidedFieldInfo MaybeNull = + match x with + | Null -> null + | NonNull x -> ProvidedFieldInfo(x, ctxt) - static member CreateArray ctxt (xs: FieldInfo ProvidedArray) : ProvidedFieldInfo ProvidedArray = + static member CreateArray ctxt (xs: FieldInfo ProvidedArray) : ProvidedFieldInfo ProvidedArray = xs |> ProvidedArray.map (ProvidedFieldInfo.CreateNonNull ctxt) member _.IsInitOnly = x.IsInitOnly @@ -764,7 +955,7 @@ type ProvidedFieldInfo (x: FieldInfo, ctxt) = /// FieldInfo.FieldType cannot be null - member _.FieldType = x.FieldType |> ProvidedType.CreateWithNullCheck ctxt "FieldType" + member _.FieldType = x.FieldType |> ProvidedType.CreateWithNullCheck ctxt "FieldType" member _.Handle = x @@ -778,134 +969,181 @@ type ProvidedFieldInfo (x: FieldInfo, ctxt) = member _.IsFamilyAndAssembly = x.IsFamilyAndAssembly - override _.Equals y = assert false; match y with :? ProvidedFieldInfo as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false + + match y with + | :? ProvidedFieldInfo as y -> x.Equals y.Handle + | _ -> false - override _.GetHashCode() = assert false; x.GetHashCode() + override _.GetHashCode() = + assert false + x.GetHashCode() - static member TaintedEquals (pt1: Tainted, pt2: Tainted) = + static member TaintedEquals(pt1: Tainted, pt2: Tainted) = Tainted.EqTainted (pt1.PApplyNoFailure(fun st -> st.Handle)) (pt2.PApplyNoFailure(fun st -> st.Handle)) -[] -type ProvidedMethodInfo (x: MethodInfo, ctxt) = +[] +type ProvidedMethodInfo(x: MethodInfo, ctxt) = inherit ProvidedMethodBase(x, ctxt) - member _.ReturnType = x.ReturnType |> ProvidedType.CreateWithNullCheck ctxt "ReturnType" + member _.ReturnType = + x.ReturnType |> ProvidedType.CreateWithNullCheck ctxt "ReturnType" - static member CreateNonNull ctxt (x: MethodInfo) : ProvidedMethodInfo = - ProvidedMethodInfo (x, ctxt) + static member CreateNonNull ctxt (x: MethodInfo) : ProvidedMethodInfo = ProvidedMethodInfo(x, ctxt) - static member Create ctxt (x: MethodInfo MaybeNull) : ProvidedMethodInfo MaybeNull = - match x with + static member Create ctxt (x: MethodInfo MaybeNull) : ProvidedMethodInfo MaybeNull = + match x with | Null -> null - | NonNull x -> ProvidedMethodInfo (x, ctxt) - + | NonNull x -> ProvidedMethodInfo(x, ctxt) - static member CreateArray ctxt (xs: MethodInfo ProvidedArray) : ProvidedMethodInfo ProvidedArray = + static member CreateArray ctxt (xs: MethodInfo ProvidedArray) : ProvidedMethodInfo ProvidedArray = xs |> ProvidedArray.map (ProvidedMethodInfo.CreateNonNull ctxt) member _.Handle = x member _.MetadataToken = x.MetadataToken - override _.Equals y = assert false; match y with :? ProvidedMethodInfo as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false - override _.GetHashCode() = assert false; x.GetHashCode() + match y with + | :? ProvidedMethodInfo as y -> x.Equals y.Handle + | _ -> false -[] -type ProvidedPropertyInfo (x: PropertyInfo, ctxt) = + override _.GetHashCode() = + assert false + x.GetHashCode() + +[] +type ProvidedPropertyInfo(x: PropertyInfo, ctxt) = inherit ProvidedMemberInfo(x, ctxt) - member _.GetGetMethod() = x.GetGetMethod() |> ProvidedMethodInfo.Create ctxt + member _.GetGetMethod() = + x.GetGetMethod() |> ProvidedMethodInfo.Create ctxt - member _.GetSetMethod() = x.GetSetMethod() |> ProvidedMethodInfo.Create ctxt + member _.GetSetMethod() = + x.GetSetMethod() |> ProvidedMethodInfo.Create ctxt member _.CanRead = x.CanRead member _.CanWrite = x.CanWrite - member _.GetIndexParameters() = x.GetIndexParameters() |> ProvidedParameterInfo.CreateArray ctxt + member _.GetIndexParameters() = + x.GetIndexParameters() |> ProvidedParameterInfo.CreateArray ctxt /// PropertyInfo.PropertyType cannot be null - member _.PropertyType = x.PropertyType |> ProvidedType.CreateWithNullCheck ctxt "PropertyType" + member _.PropertyType = + x.PropertyType |> ProvidedType.CreateWithNullCheck ctxt "PropertyType" - static member CreateNonNull ctxt x = ProvidedPropertyInfo (x, ctxt) + static member CreateNonNull ctxt x = ProvidedPropertyInfo(x, ctxt) static member Create ctxt x : ProvidedPropertyInfo MaybeNull = - match x with - | Null -> null - | NonNull x -> ProvidedPropertyInfo (x, ctxt) + match x with + | Null -> null + | NonNull x -> ProvidedPropertyInfo(x, ctxt) - static member CreateArray ctxt (xs: PropertyInfo ProvidedArray) : ProvidedPropertyInfo ProvidedArray = + static member CreateArray ctxt (xs: PropertyInfo ProvidedArray) : ProvidedPropertyInfo ProvidedArray = xs |> ProvidedArray.map (ProvidedPropertyInfo.CreateNonNull ctxt) member _.Handle = x - override _.Equals y = assert false; match y with :? ProvidedPropertyInfo as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false + + match y with + | :? ProvidedPropertyInfo as y -> x.Equals y.Handle + | _ -> false - override _.GetHashCode() = assert false; x.GetHashCode() + override _.GetHashCode() = + assert false + x.GetHashCode() - static member TaintedGetHashCode (x: Tainted) = - Tainted.GetHashCodeTainted - (x.PApplyNoFailure(fun st -> (st.Name, (nonNull (nonNull st.DeclaringType).Assembly).FullName, - (nonNull st.DeclaringType).FullName))) + static member TaintedGetHashCode(x: Tainted) = + Tainted.GetHashCodeTainted( + x.PApplyNoFailure(fun st -> + (st.Name, + (nonNull (nonNull st.DeclaringType).Assembly).FullName, + (nonNull st.DeclaringType).FullName)) + ) - static member TaintedEquals (pt1: Tainted, pt2: Tainted) = + static member TaintedEquals(pt1: Tainted, pt2: Tainted) = Tainted.EqTainted (pt1.PApplyNoFailure(fun st -> st.Handle)) (pt2.PApplyNoFailure(fun st -> st.Handle)) -[] -type ProvidedEventInfo (x: EventInfo, ctxt) = +[] +type ProvidedEventInfo(x: EventInfo, ctxt) = inherit ProvidedMemberInfo(x, ctxt) - member _.GetAddMethod() = x.GetAddMethod() |> ProvidedMethodInfo.Create ctxt + member _.GetAddMethod() = + x.GetAddMethod() |> ProvidedMethodInfo.Create ctxt - member _.GetRemoveMethod() = x.GetRemoveMethod() |> ProvidedMethodInfo.Create ctxt + member _.GetRemoveMethod() = + x.GetRemoveMethod() |> ProvidedMethodInfo.Create ctxt /// EventInfo.EventHandlerType cannot be null - member _.EventHandlerType = x.EventHandlerType |> ProvidedType.CreateWithNullCheck ctxt "EventHandlerType" - - static member CreateNonNull ctxt x = ProvidedEventInfo (x, ctxt) - - static member Create ctxt x : ProvidedEventInfo MaybeNull = - match x with - | Null -> null - | NonNull x -> ProvidedEventInfo (x, ctxt) - - static member CreateArray ctxt (xs: EventInfo ProvidedArray) : ProvidedEventInfo ProvidedArray = + member _.EventHandlerType = + x.EventHandlerType |> ProvidedType.CreateWithNullCheck ctxt "EventHandlerType" + + static member CreateNonNull ctxt x = ProvidedEventInfo(x, ctxt) + + static member Create ctxt x : ProvidedEventInfo MaybeNull = + match x with + | Null -> null + | NonNull x -> ProvidedEventInfo(x, ctxt) + + static member CreateArray ctxt (xs: EventInfo ProvidedArray) : ProvidedEventInfo ProvidedArray = xs |> ProvidedArray.map (ProvidedEventInfo.CreateNonNull ctxt) - + member _.Handle = x - override _.Equals y = assert false; match y with :? ProvidedEventInfo as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false + + match y with + | :? ProvidedEventInfo as y -> x.Equals y.Handle + | _ -> false - override _.GetHashCode() = assert false; x.GetHashCode() + override _.GetHashCode() = + assert false + x.GetHashCode() - static member TaintedGetHashCode (x: Tainted) = - Tainted.GetHashCodeTainted - (x.PApplyNoFailure(fun st -> (st.Name, (nonNull (nonNull st.DeclaringType).Assembly).FullName, - (nonNull st.DeclaringType).FullName))) + static member TaintedGetHashCode(x: Tainted) = + Tainted.GetHashCodeTainted( + x.PApplyNoFailure(fun st -> + (st.Name, + (nonNull (nonNull st.DeclaringType).Assembly).FullName, + (nonNull st.DeclaringType).FullName)) + ) - static member TaintedEquals (pt1: Tainted, pt2: Tainted) = + static member TaintedEquals(pt1: Tainted, pt2: Tainted) = Tainted.EqTainted (pt1.PApplyNoFailure(fun st -> st.Handle)) (pt2.PApplyNoFailure(fun st -> st.Handle)) -[] -type ProvidedConstructorInfo (x: ConstructorInfo, ctxt) = +[] +type ProvidedConstructorInfo(x: ConstructorInfo, ctxt) = inherit ProvidedMethodBase(x, ctxt) - static member CreateNonNull ctxt x = ProvidedConstructorInfo (x, ctxt) + static member CreateNonNull ctxt x = ProvidedConstructorInfo(x, ctxt) - static member Create ctxt (x: ConstructorInfo MaybeNull) : ProvidedConstructorInfo MaybeNull = - match x with - | Null -> null - | NonNull x -> ProvidedConstructorInfo (x, ctxt) + static member Create ctxt (x: ConstructorInfo MaybeNull) : ProvidedConstructorInfo MaybeNull = + match x with + | Null -> null + | NonNull x -> ProvidedConstructorInfo(x, ctxt) - static member CreateArray ctxt (xs: ConstructorInfo ProvidedArray) : ProvidedConstructorInfo ProvidedArray = + static member CreateArray ctxt (xs: ConstructorInfo ProvidedArray) : ProvidedConstructorInfo ProvidedArray = xs |> ProvidedArray.map (ProvidedConstructorInfo.CreateNonNull ctxt) member _.Handle = x - override _.Equals y = assert false; match y with :? ProvidedConstructorInfo as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + assert false - override _.GetHashCode() = assert false; x.GetHashCode() + match y with + | :? ProvidedConstructorInfo as y -> x.Equals y.Handle + | _ -> false + + override _.GetHashCode() = + assert false + x.GetHashCode() type ProvidedExprType = | ProvidedNewArrayExpr of ProvidedType * ProvidedExpr ProvidedArray @@ -917,7 +1155,7 @@ type ProvidedExprType = | ProvidedTryWithExpr of ProvidedExpr * ProvidedVar * ProvidedExpr * ProvidedVar * ProvidedExpr | ProvidedTryFinallyExpr of ProvidedExpr * ProvidedExpr | ProvidedLambdaExpr of ProvidedVar * ProvidedExpr - | ProvidedCallExpr of ProvidedExpr option * ProvidedMethodInfo * ProvidedExpr ProvidedArray + | ProvidedCallExpr of ProvidedExpr option * ProvidedMethodInfo * ProvidedExpr ProvidedArray | ProvidedConstantExpr of objnull * ProvidedType | ProvidedDefaultExpr of ProvidedType | ProvidedNewTupleExpr of ProvidedExpr ProvidedArray @@ -929,9 +1167,8 @@ type ProvidedExprType = | ProvidedIfThenElseExpr of ProvidedExpr * ProvidedExpr * ProvidedExpr | ProvidedVarExpr of ProvidedVar - [] -type ProvidedExpr (x: Expr, ctxt) = +type ProvidedExpr(x: Expr, ctxt) = member _.Type = x.Type |> ProvidedType.CreateNonNull ctxt @@ -944,153 +1181,218 @@ type ProvidedExpr (x: Expr, ctxt) = member _.GetExprType() = match x with | Patterns.NewObject(ctor, args) -> - Some (ProvidedNewObjectExpr (ProvidedConstructorInfo.CreateNonNull ctxt ctor, [| for a in args -> ProvidedExpr.CreateNonNull ctxt a |])) + Some( + ProvidedNewObjectExpr( + ProvidedConstructorInfo.CreateNonNull ctxt ctor, + [| for a in args -> ProvidedExpr.CreateNonNull ctxt a |] + ) + ) | Patterns.WhileLoop(guardExpr, bodyExpr) -> - Some (ProvidedWhileLoopExpr (ProvidedExpr.CreateNonNull ctxt guardExpr, ProvidedExpr.CreateNonNull ctxt bodyExpr)) + Some(ProvidedWhileLoopExpr(ProvidedExpr.CreateNonNull ctxt guardExpr, ProvidedExpr.CreateNonNull ctxt bodyExpr)) | Patterns.NewDelegate(ty, vs, expr) -> - Some (ProvidedNewDelegateExpr(ProvidedType.CreateNonNull ctxt ty, ProvidedVar.CreateArray ctxt (List.toArray vs), ProvidedExpr.CreateNonNull ctxt expr)) + Some( + ProvidedNewDelegateExpr( + ProvidedType.CreateNonNull ctxt ty, + ProvidedVar.CreateArray ctxt (List.toArray vs), + ProvidedExpr.CreateNonNull ctxt expr + ) + ) | Patterns.Call(objOpt, meth, args) -> - Some (ProvidedCallExpr((match objOpt with None -> None | Some obj -> Some (ProvidedExpr.CreateNonNull ctxt obj)), - ProvidedMethodInfo.CreateNonNull ctxt meth, [| for a in args -> ProvidedExpr.CreateNonNull ctxt a |])) - | Patterns.DefaultValue ty -> - Some (ProvidedDefaultExpr (ProvidedType.CreateNonNull ctxt ty)) - | Patterns.Value(obj, ty) -> - Some (ProvidedConstantExpr (obj, ProvidedType.CreateNonNull ctxt ty)) - | Patterns.Coerce(arg, ty) -> - Some (ProvidedTypeAsExpr (ProvidedExpr.CreateNonNull ctxt arg, ProvidedType.CreateNonNull ctxt ty)) - | Patterns.NewTuple args -> - Some (ProvidedNewTupleExpr(ProvidedExpr.CreateArray ctxt (Array.ofList args))) - | Patterns.TupleGet(arg, n) -> - Some (ProvidedTupleGetExpr (ProvidedExpr.CreateNonNull ctxt arg, n)) + Some( + ProvidedCallExpr( + (match objOpt with + | None -> None + | Some obj -> Some(ProvidedExpr.CreateNonNull ctxt obj)), + ProvidedMethodInfo.CreateNonNull ctxt meth, + [| for a in args -> ProvidedExpr.CreateNonNull ctxt a |] + ) + ) + | Patterns.DefaultValue ty -> Some(ProvidedDefaultExpr(ProvidedType.CreateNonNull ctxt ty)) + | Patterns.Value(obj, ty) -> Some(ProvidedConstantExpr(obj, ProvidedType.CreateNonNull ctxt ty)) + | Patterns.Coerce(arg, ty) -> Some(ProvidedTypeAsExpr(ProvidedExpr.CreateNonNull ctxt arg, ProvidedType.CreateNonNull ctxt ty)) + | Patterns.NewTuple args -> Some(ProvidedNewTupleExpr(ProvidedExpr.CreateArray ctxt (Array.ofList args))) + | Patterns.TupleGet(arg, n) -> Some(ProvidedTupleGetExpr(ProvidedExpr.CreateNonNull ctxt arg, n)) | Patterns.NewArray(ty, args) -> - Some (ProvidedNewArrayExpr(ProvidedType.CreateNonNull ctxt ty, ProvidedExpr.CreateArray ctxt (Array.ofList args))) + Some(ProvidedNewArrayExpr(ProvidedType.CreateNonNull ctxt ty, ProvidedExpr.CreateArray ctxt (Array.ofList args))) | Patterns.Sequential(e1, e2) -> - Some (ProvidedSequentialExpr(ProvidedExpr.CreateNonNull ctxt e1, ProvidedExpr.CreateNonNull ctxt e2)) - | Patterns.Lambda(v, body) -> - Some (ProvidedLambdaExpr (ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt body)) + Some(ProvidedSequentialExpr(ProvidedExpr.CreateNonNull ctxt e1, ProvidedExpr.CreateNonNull ctxt e2)) + | Patterns.Lambda(v, body) -> Some(ProvidedLambdaExpr(ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt body)) | Patterns.TryFinally(b1, b2) -> - Some (ProvidedTryFinallyExpr (ProvidedExpr.CreateNonNull ctxt b1, ProvidedExpr.CreateNonNull ctxt b2)) + Some(ProvidedTryFinallyExpr(ProvidedExpr.CreateNonNull ctxt b1, ProvidedExpr.CreateNonNull ctxt b2)) | Patterns.TryWith(b, v1, e1, v2, e2) -> - Some (ProvidedTryWithExpr (ProvidedExpr.CreateNonNull ctxt b, ProvidedVar.CreateNonNull ctxt v1, ProvidedExpr.CreateNonNull ctxt e1, ProvidedVar.CreateNonNull ctxt v2, ProvidedExpr.CreateNonNull ctxt e2)) - | Patterns.TypeTest(e, ty) -> - Some (ProvidedTypeTestExpr(ProvidedExpr.CreateNonNull ctxt e, ProvidedType.CreateNonNull ctxt ty)) + Some( + ProvidedTryWithExpr( + ProvidedExpr.CreateNonNull ctxt b, + ProvidedVar.CreateNonNull ctxt v1, + ProvidedExpr.CreateNonNull ctxt e1, + ProvidedVar.CreateNonNull ctxt v2, + ProvidedExpr.CreateNonNull ctxt e2 + ) + ) + | Patterns.TypeTest(e, ty) -> Some(ProvidedTypeTestExpr(ProvidedExpr.CreateNonNull ctxt e, ProvidedType.CreateNonNull ctxt ty)) | Patterns.Let(v, e, b) -> - Some (ProvidedLetExpr (ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt e, ProvidedExpr.CreateNonNull ctxt b)) - | Patterns.ForIntegerRangeLoop (v, e1, e2, e3) -> - Some (ProvidedForIntegerRangeLoopExpr (ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt e1, ProvidedExpr.CreateNonNull ctxt e2, ProvidedExpr.CreateNonNull ctxt e3)) - | Patterns.VarSet(v, e) -> - Some (ProvidedVarSetExpr (ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt e)) + Some(ProvidedLetExpr(ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt e, ProvidedExpr.CreateNonNull ctxt b)) + | Patterns.ForIntegerRangeLoop(v, e1, e2, e3) -> + Some( + ProvidedForIntegerRangeLoopExpr( + ProvidedVar.CreateNonNull ctxt v, + ProvidedExpr.CreateNonNull ctxt e1, + ProvidedExpr.CreateNonNull ctxt e2, + ProvidedExpr.CreateNonNull ctxt e3 + ) + ) + | Patterns.VarSet(v, e) -> Some(ProvidedVarSetExpr(ProvidedVar.CreateNonNull ctxt v, ProvidedExpr.CreateNonNull ctxt e)) | Patterns.IfThenElse(g, t, e) -> - Some (ProvidedIfThenElseExpr (ProvidedExpr.CreateNonNull ctxt g, ProvidedExpr.CreateNonNull ctxt t, ProvidedExpr.CreateNonNull ctxt e)) - | Patterns.Var v -> - Some (ProvidedVarExpr (ProvidedVar.CreateNonNull ctxt v)) + Some( + ProvidedIfThenElseExpr( + ProvidedExpr.CreateNonNull ctxt g, + ProvidedExpr.CreateNonNull ctxt t, + ProvidedExpr.CreateNonNull ctxt e + ) + ) + | Patterns.Var v -> Some(ProvidedVarExpr(ProvidedVar.CreateNonNull ctxt v)) | _ -> None - static member Create ctxt t : ProvidedExpr MaybeNull = - match box t with - | Null -> null - | _ -> ProvidedExpr (t, ctxt) - static member CreateNonNull ctxt t : ProvidedExpr = - ProvidedExpr (t, ctxt) + static member Create ctxt t : ProvidedExpr MaybeNull = + match box t with + | Null -> null + | _ -> ProvidedExpr(t, ctxt) - static member CreateArray ctxt xs : ProvidedExpr[] = - match box xs with - | Null -> [| |] + static member CreateNonNull ctxt t : ProvidedExpr = ProvidedExpr(t, ctxt) + + static member CreateArray ctxt xs : ProvidedExpr[] = + match box xs with + | Null -> [||] | _ -> xs |> Array.map (ProvidedExpr.CreateNonNull ctxt) - override _.Equals y = match y with :? ProvidedExpr as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + match y with + | :? ProvidedExpr as y -> x.Equals y.Handle + | _ -> false override _.GetHashCode() = x.GetHashCode() [] -type ProvidedVar (x: Var, ctxt) = +type ProvidedVar(x: Var, ctxt) = member _.Type = x.Type |> ProvidedType.CreateNonNull ctxt member _.Name = x.Name member _.IsMutable = x.IsMutable member _.Handle = x member _.Context = ctxt - static member CreateNonNull ctxt t = - ProvidedVar (t, ctxt) + static member CreateNonNull ctxt t = ProvidedVar(t, ctxt) - static member CreateArray ctxt xs : ProvidedVar[] = - match box xs with - | Null -> [| |] + static member CreateArray ctxt xs : ProvidedVar[] = + match box xs with + | Null -> [||] | _ -> xs |> Array.map (ProvidedVar.CreateNonNull ctxt) - override _.Equals y = match y with :? ProvidedVar as y -> x.Equals y.Handle | _ -> false + override _.Equals y = + match y with + | :? ProvidedVar as y -> x.Equals y.Handle + | _ -> false override _.GetHashCode() = x.GetHashCode() /// Get the provided invoker expression for a particular use of a method. -let GetInvokerExpression (provider: ITypeProvider, methodBase: ProvidedMethodBase, paramExprs: ProvidedVar[]) = - provider.GetInvokerExpression(methodBase.Handle, [| for p in paramExprs -> Quotations.Expr.Var p.Handle |]) |> ProvidedExpr.Create methodBase.Context +let GetInvokerExpression (provider: ITypeProvider, methodBase: ProvidedMethodBase, paramExprs: ProvidedVar[]) = + provider.GetInvokerExpression(methodBase.Handle, [| for p in paramExprs -> Quotations.Expr.Var p.Handle |]) + |> ProvidedExpr.Create methodBase.Context /// Compute the Name or FullName property of a provided type, reporting appropriate errors -let CheckAndComputeProvidedNameProperty(m, st: Tainted, proj, propertyString) = - let name : string MaybeNull = - try st.PUntaint(proj, m) - with :? TypeProviderError as tpe -> - let newError = tpe.MapText((fun msg -> FSComp.SR.etProvidedTypeWithNameException(propertyString, msg)), st.TypeProviderDesignation, m) +let CheckAndComputeProvidedNameProperty (m, st: Tainted, proj, propertyString) = + let name: string MaybeNull = + try + st.PUntaint(proj, m) + with :? TypeProviderError as tpe -> + let newError = + tpe.MapText((fun msg -> FSComp.SR.etProvidedTypeWithNameException (propertyString, msg)), st.TypeProviderDesignation, m) + raise newError + if String.IsNullOrEmpty name then raise (TypeProviderError(FSComp.SR.etProvidedTypeWithNullOrEmptyName propertyString, st.TypeProviderDesignation, m)) + !!name /// Verify that this type provider has supported attributes -let ValidateAttributesOfProvidedType (m, st: Tainted) = - let fullName = CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.FullName), "FullName") - if TryTypeMember(st, fullName, "IsGenericType", m, false, fun st->st.IsGenericType) |> unmarshal then - errorR(Error(FSComp.SR.etMustNotBeGeneric fullName, m)) - if TryTypeMember(st, fullName, "IsArray", m, false, fun st->st.IsArray) |> unmarshal then - errorR(Error(FSComp.SR.etMustNotBeAnArray fullName, m)) - TryTypeMemberNonNull(st, fullName, "GetInterfaces", m, [||], fun st -> st.GetInterfaces()) |> ignore +let ValidateAttributesOfProvidedType (m, st: Tainted) = + let fullName = + CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.FullName), "FullName") + + if + TryTypeMember(st, fullName, "IsGenericType", m, false, fun st -> st.IsGenericType) + |> unmarshal + then + errorR (Error(FSComp.SR.etMustNotBeGeneric fullName, m)) + + if + TryTypeMember(st, fullName, "IsArray", m, false, fun st -> st.IsArray) + |> unmarshal + then + errorR (Error(FSComp.SR.etMustNotBeAnArray fullName, m)) + + TryTypeMemberNonNull(st, fullName, "GetInterfaces", m, [||], fun st -> st.GetInterfaces()) + |> ignore /// Verify that a provided type has the expected name let ValidateExpectedName m expectedPath expectedName (st: Tainted) = let name = CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.Name), "Name") - if name <> expectedName then - raise (TypeProviderError(FSComp.SR.etProvidedTypeHasUnexpectedName(expectedName, name), st.TypeProviderDesignation, m)) - - let namespaceName = TryTypeMember(st, name, "Namespace", m, ("":_|null), fun st -> st.Namespace) |> unmarshal + if name <> expectedName then + raise (TypeProviderError(FSComp.SR.etProvidedTypeHasUnexpectedName (expectedName, name), st.TypeProviderDesignation, m)) + let namespaceName = + TryTypeMember(st, name, "Namespace", m, ("": _ | null), fun st -> st.Namespace) + |> unmarshal let rec declaringTypes (st: Tainted) accu = match TryTypeMember(st, name, "DeclaringType", m, null, fun st -> st.DeclaringType) with | Tainted.Null -> accu | Tainted.NonNull dt -> declaringTypes dt (CheckAndComputeProvidedNameProperty(m, dt, (fun dt -> dt.Name), "Name") :: accu) - let path = - [| match namespaceName with + let path = + [| + match namespaceName with | Null -> () - | NonNull namespaceName -> yield! namespaceName.Split([|'.'|]) - yield! declaringTypes st [] |] - + | NonNull namespaceName -> yield! namespaceName.Split([| '.' |]) + yield! declaringTypes st [] + |] + if path <> expectedPath then let expectedPath = String.Join(".", expectedPath) let path = String.Join(".", path) - errorR(Error(FSComp.SR.etProvidedTypeHasUnexpectedPath(expectedPath, path), m)) + errorR (Error(FSComp.SR.etProvidedTypeHasUnexpectedPath (expectedPath, path), m)) /// Eagerly validate a range of conditions on a provided type, after static instantiation (if any) has occurred -let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, expectedPath: string[], expectedName: string) = +let ValidateProvidedTypeAfterStaticInstantiation (m, st: Tainted, expectedPath: string[], expectedName: string) = // Do all the calling into st up front with recovery let fullName, namespaceName, usedMembers = let name = CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.Name), "Name") - let namespaceName = TryTypeMember<_, string | null>(st, name, "Namespace", m, FSComp.SR.invalidNamespaceForProvidedType(), fun st -> st.Namespace) |> unmarshal - let fullName = TryTypeMemberNonNull(st, name, "FullName", m, FSComp.SR.invalidFullNameForProvidedType(), fun st -> st.FullName) |> unmarshal + + let namespaceName = + TryTypeMember<_, string | null>(st, name, "Namespace", m, FSComp.SR.invalidNamespaceForProvidedType (), fun st -> st.Namespace) + |> unmarshal + + let fullName = + TryTypeMemberNonNull(st, name, "FullName", m, FSComp.SR.invalidFullNameForProvidedType (), fun st -> st.FullName) + |> unmarshal + ValidateExpectedName m expectedPath expectedName st // Must be able to call (GetMethods|GetEvents|GetProperties|GetNestedTypes|GetConstructors)(bindingFlags). - let usedMembers: Tainted[] = + let usedMembers: Tainted[] = // These are the members the compiler will actually use - [| for x in TryTypeMemberArray(st, fullName, "GetMethods", m, fun st -> st.GetMethods()) -> x.Coerce m - for x in TryTypeMemberArray(st, fullName, "GetEvents", m, fun st -> st.GetEvents()) -> x.Coerce m - for x in TryTypeMemberArray(st, fullName, "GetFields", m, fun st -> st.GetFields()) -> x.Coerce m - for x in TryTypeMemberArray(st, fullName, "GetProperties", m, fun st -> st.GetProperties()) -> x.Coerce m - // These will be validated on-demand - //for x in TryTypeMemberArray(st, fullName, "GetNestedTypes", m, fun st -> st.GetNestedTypes bindingFlags) -> x.Coerce() - for x in TryTypeMemberArray(st, fullName, "GetConstructors", m, fun st -> st.GetConstructors()) -> x.Coerce m |] - fullName, namespaceName, usedMembers + [| + for x in TryTypeMemberArray(st, fullName, "GetMethods", m, fun st -> st.GetMethods()) -> x.Coerce m + for x in TryTypeMemberArray(st, fullName, "GetEvents", m, fun st -> st.GetEvents()) -> x.Coerce m + for x in TryTypeMemberArray(st, fullName, "GetFields", m, fun st -> st.GetFields()) -> x.Coerce m + for x in TryTypeMemberArray(st, fullName, "GetProperties", m, fun st -> st.GetProperties()) -> x.Coerce m + // These will be validated on-demand + //for x in TryTypeMemberArray(st, fullName, "GetNestedTypes", m, fun st -> st.GetNestedTypes bindingFlags) -> x.Coerce() + for x in TryTypeMemberArray(st, fullName, "GetConstructors", m, fun st -> st.GetConstructors()) -> x.Coerce m + |] + + fullName, namespaceName, usedMembers // We scrutinize namespaces for invalid characters on open, but this provides better diagnostics ValidateNamespaceName(fullName, st.TypeProvider, m, namespaceName) @@ -1100,90 +1402,141 @@ let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, e // Those members must have this type. // This needs to be a *shallow* exploration. Otherwise, as in Freebase sample the entire database could be explored. for mi in usedMembers do - match mi with - | Tainted.Null -> errorR(Error(FSComp.SR.etNullMember fullName, m)) - | Tainted.NonNull _ -> - let memberName = TryMemberMember(mi, fullName, "Name", "Name", m, "invalid provided type member name", fun mi -> mi.Name) |> unmarshal - if String.IsNullOrEmpty memberName then - errorR(Error(FSComp.SR.etNullOrEmptyMemberName fullName, m)) - else - let miDeclaringType = TryMemberMember(mi, fullName, memberName, "DeclaringType", m, (ProvidedType.CreateNoContext(typeof) |> withNull), fun mi -> mi.DeclaringType) - match miDeclaringType with - // Generated nested types may have null DeclaringType + match mi with + | Tainted.Null -> errorR (Error(FSComp.SR.etNullMember fullName, m)) + | Tainted.NonNull _ -> + let memberName = + TryMemberMember(mi, fullName, "Name", "Name", m, "invalid provided type member name", fun mi -> mi.Name) + |> unmarshal + + if String.IsNullOrEmpty memberName then + errorR (Error(FSComp.SR.etNullOrEmptyMemberName fullName, m)) + else + let miDeclaringType = + TryMemberMember( + mi, + fullName, + memberName, + "DeclaringType", + m, + (ProvidedType.CreateNoContext(typeof) |> withNull), + fun mi -> mi.DeclaringType + ) + + match miDeclaringType with + // Generated nested types may have null DeclaringType | Tainted.Null when mi.OfType().IsSome -> () - | Tainted.Null -> - errorR(Error(FSComp.SR.etNullMemberDeclaringType(fullName, memberName), m)) - | Tainted.NonNull miDeclaringType -> - let miDeclaringTypeFullName = - TryMemberMember (miDeclaringType, fullName, memberName, "FullName", m, + | Tainted.Null -> errorR (Error(FSComp.SR.etNullMemberDeclaringType (fullName, memberName), m)) + | Tainted.NonNull miDeclaringType -> + let miDeclaringTypeFullName = + TryMemberMember( + miDeclaringType, + fullName, + memberName, + "FullName", + m, "invalid declaring type full name", - fun miDeclaringType -> !!miDeclaringType.FullName) + fun miDeclaringType -> !!miDeclaringType.FullName + ) |> unmarshal - if not (ProvidedType.TaintedEquals (st, miDeclaringType)) then - errorR(Error(FSComp.SR.etNullMemberDeclaringTypeDifferentFromProvidedType(fullName, memberName, miDeclaringTypeFullName), m)) + if not (ProvidedType.TaintedEquals(st, miDeclaringType)) then + errorR ( + Error( + FSComp.SR.etNullMemberDeclaringTypeDifferentFromProvidedType (fullName, memberName, miDeclaringTypeFullName), + m + ) + ) match mi.OfType() with | Some mi -> - let isPublic = TryMemberMember(mi, fullName, memberName, "IsPublic", m, true, fun mi->mi.IsPublic) |> unmarshal - let isGenericMethod = TryMemberMember(mi, fullName, memberName, "IsGenericMethod", m, true, fun mi->mi.IsGenericMethod) |> unmarshal - if not isPublic || isGenericMethod then - errorR(Error(FSComp.SR.etMethodHasRequirements(fullName, memberName), m)) - | None -> - match mi.OfType() with - | Some subType -> ValidateAttributesOfProvidedType(m, subType) - | None -> - match mi.OfType() with - | Some pi -> - // Property must have a getter or setter - // TODO: Property must be public etc. - let expectRead = - match TryMemberMember(pi, fullName, memberName, "GetGetMethod", m, null, fun pi -> pi.GetGetMethod()) with - | Tainted.Null -> false - | _ -> true - let expectWrite = - match TryMemberMember(pi, fullName, memberName, "GetSetMethod", m, null, fun pi-> pi.GetSetMethod()) with - | Tainted.Null -> false - | _ -> true - let canRead = TryMemberMember(pi, fullName, memberName, "CanRead", m, expectRead, fun pi-> pi.CanRead) |> unmarshal - let canWrite = TryMemberMember(pi, fullName, memberName, "CanWrite", m, expectWrite, fun pi-> pi.CanWrite) |> unmarshal - match expectRead, canRead with - | false, false | true, true-> () - | false, true -> errorR(Error(FSComp.SR.etPropertyCanReadButHasNoGetter(memberName, fullName), m)) - | true, false -> errorR(Error(FSComp.SR.etPropertyHasGetterButNoCanRead(memberName, fullName), m)) - match expectWrite, canWrite with - | false, false | true, true-> () - | false, true -> errorR(Error(FSComp.SR.etPropertyCanWriteButHasNoSetter(memberName, fullName), m)) - | true, false -> errorR(Error(FSComp.SR.etPropertyHasSetterButNoCanWrite(memberName, fullName), m)) - if not canRead && not canWrite then - errorR(Error(FSComp.SR.etPropertyNeedsCanWriteOrCanRead(memberName, fullName), m)) + let isPublic = + TryMemberMember(mi, fullName, memberName, "IsPublic", m, true, fun mi -> mi.IsPublic) + |> unmarshal - | None -> - match mi.OfType() with - | Some ei -> - // Event must have adder and remover - // TODO: Event must be public etc. - let adder = TryMemberMember(ei, fullName, memberName, "GetAddMethod", m, null, fun ei-> ei.GetAddMethod()) - let remover = TryMemberMember(ei, fullName, memberName, "GetRemoveMethod", m, null, fun ei-> ei.GetRemoveMethod()) - match adder, remover with - | Tainted.Null, _ -> errorR(Error(FSComp.SR.etEventNoAdd(memberName, fullName), m)) - | _, Tainted.Null -> errorR(Error(FSComp.SR.etEventNoRemove(memberName, fullName), m)) - | _, _ -> () - | None -> - match mi.OfType() with - | Some _ -> () // TODO: Constructors must be public etc. - | None -> - match mi.OfType() with - | Some _ -> () // TODO: Fields must be public, literals must have a value etc. - | None -> - errorR(Error(FSComp.SR.etUnsupportedMemberKind(memberName, fullName), m)) + let isGenericMethod = + TryMemberMember(mi, fullName, memberName, "IsGenericMethod", m, true, fun mi -> mi.IsGenericMethod) + |> unmarshal -let ValidateProvidedTypeDefinition(m, st: Tainted, expectedPath: string[], expectedName: string) = + if not isPublic || isGenericMethod then + errorR (Error(FSComp.SR.etMethodHasRequirements (fullName, memberName), m)) + | None -> + match mi.OfType() with + | Some subType -> ValidateAttributesOfProvidedType(m, subType) + | None -> + match mi.OfType() with + | Some pi -> + // Property must have a getter or setter + // TODO: Property must be public etc. + let expectRead = + match TryMemberMember(pi, fullName, memberName, "GetGetMethod", m, null, fun pi -> pi.GetGetMethod()) with + | Tainted.Null -> false + | _ -> true + + let expectWrite = + match TryMemberMember(pi, fullName, memberName, "GetSetMethod", m, null, fun pi -> pi.GetSetMethod()) with + | Tainted.Null -> false + | _ -> true + + let canRead = + TryMemberMember(pi, fullName, memberName, "CanRead", m, expectRead, fun pi -> pi.CanRead) + |> unmarshal + + let canWrite = + TryMemberMember(pi, fullName, memberName, "CanWrite", m, expectWrite, fun pi -> pi.CanWrite) + |> unmarshal + + match expectRead, canRead with + | false, false + | true, true -> () + | false, true -> errorR (Error(FSComp.SR.etPropertyCanReadButHasNoGetter (memberName, fullName), m)) + | true, false -> errorR (Error(FSComp.SR.etPropertyHasGetterButNoCanRead (memberName, fullName), m)) + + match expectWrite, canWrite with + | false, false + | true, true -> () + | false, true -> errorR (Error(FSComp.SR.etPropertyCanWriteButHasNoSetter (memberName, fullName), m)) + | true, false -> errorR (Error(FSComp.SR.etPropertyHasSetterButNoCanWrite (memberName, fullName), m)) + + if not canRead && not canWrite then + errorR (Error(FSComp.SR.etPropertyNeedsCanWriteOrCanRead (memberName, fullName), m)) + + | None -> + match mi.OfType() with + | Some ei -> + // Event must have adder and remover + // TODO: Event must be public etc. + let adder = + TryMemberMember(ei, fullName, memberName, "GetAddMethod", m, null, fun ei -> ei.GetAddMethod()) + + let remover = + TryMemberMember(ei, fullName, memberName, "GetRemoveMethod", m, null, fun ei -> ei.GetRemoveMethod()) + + match adder, remover with + | Tainted.Null, _ -> errorR (Error(FSComp.SR.etEventNoAdd (memberName, fullName), m)) + | _, Tainted.Null -> errorR (Error(FSComp.SR.etEventNoRemove (memberName, fullName), m)) + | _, _ -> () + | None -> + match mi.OfType() with + | Some _ -> () // TODO: Constructors must be public etc. + | None -> + match mi.OfType() with + | Some _ -> () // TODO: Fields must be public, literals must have a value etc. + | None -> errorR (Error(FSComp.SR.etUnsupportedMemberKind (memberName, fullName), m)) + +let ValidateProvidedTypeDefinition (m, st: Tainted, expectedPath: string[], expectedName: string) = // Validate the Name, Namespace and FullName properties let name = CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.Name), "Name") - let _namespaceName = TryTypeMember<_, string | null>(st, name, "Namespace", m, FSComp.SR.invalidNamespaceForProvidedType(), fun st -> st.Namespace) |> unmarshal - let _fullname = TryTypeMemberNonNull(st, name, "FullName", m, FSComp.SR.invalidFullNameForProvidedType(), fun st -> st.FullName) |> unmarshal + + let _namespaceName = + TryTypeMember<_, string | null>(st, name, "Namespace", m, FSComp.SR.invalidNamespaceForProvidedType (), fun st -> st.Namespace) + |> unmarshal + + let _fullname = + TryTypeMemberNonNull(st, name, "FullName", m, FSComp.SR.invalidFullNameForProvidedType (), fun st -> st.FullName) + |> unmarshal + ValidateExpectedName m expectedPath expectedName st ValidateAttributesOfProvidedType(m, st) @@ -1191,168 +1544,247 @@ let ValidateProvidedTypeDefinition(m, st: Tainted, expectedPath: s // This excludes, for example, types with '.' in them which would not be resolvable during name resolution. match expectedName.IndexOfAny(PrettyNaming.IllegalCharactersInTypeAndNamespaceNames) with | -1 -> () - | n -> errorR(Error(FSComp.SR.etIllegalCharactersInTypeName(string expectedName[n], expectedName), m)) + | n -> errorR (Error(FSComp.SR.etIllegalCharactersInTypeName (string expectedName[n], expectedName), m)) - let staticParameters = st.PApplyWithProvider((fun (st, provider) -> st.GetStaticParameters provider), range=m) - if staticParameters.PUntaint((fun a -> (nonNull a).Length), m) = 0 then - ValidateProvidedTypeAfterStaticInstantiation(m, st, expectedPath, expectedName) + let staticParameters = + st.PApplyWithProvider((fun (st, provider) -> st.GetStaticParameters provider), range = m) + if staticParameters.PUntaint((fun a -> (nonNull a).Length), m) = 0 then + ValidateProvidedTypeAfterStaticInstantiation(m, st, expectedPath, expectedName) -/// Resolve a (non-nested) provided type given a full namespace name and a type name. +/// Resolve a (non-nested) provided type given a full namespace name and a type name. /// May throw an exception which will be turned into an error message by one of the 'Try' function below. /// If resolution is successful the type is then validated. let ResolveProvidedType (resolver: Tainted, m, moduleOrNamespace: string[], typeName) : Tainted = let displayName = String.Join(".", moduleOrNamespace) // Try to find the type in the given provided namespace - let rec tryNamespace (providedNamespace: Tainted) = + let rec tryNamespace (providedNamespace: Tainted) = // Get the provided namespace name - let providedNamespaceName = providedNamespace.PUntaint((fun providedNamespace -> providedNamespace.NamespaceName), range=m) + let providedNamespaceName = + providedNamespace.PUntaint((fun providedNamespace -> providedNamespace.NamespaceName), range = m) // Check if the provided namespace name is an exact match of the required namespace name if displayName = providedNamespaceName then - let resolvedType = providedNamespace.PApply((fun providedNamespace -> ProvidedType.Create ProvidedTypeContext.Empty (providedNamespace.ResolveTypeName typeName)), range=m) + let resolvedType = + providedNamespace.PApply( + (fun providedNamespace -> ProvidedType.Create ProvidedTypeContext.Empty (providedNamespace.ResolveTypeName typeName)), + range = m + ) + match resolvedType with | Tainted.Null -> None - | Tainted.NonNull result -> + | Tainted.NonNull result -> ValidateProvidedTypeDefinition(m, result, moduleOrNamespace, typeName) Some result else // Note: This eagerly explores all provided namespaces even if there is no match of even a prefix in the - // namespace names. - let providedNamespaces = providedNamespace.PApplyArray((fun providedNamespace -> providedNamespace.GetNestedNamespaces()), "GetNestedNamespaces", range=m) + // namespace names. + let providedNamespaces = + providedNamespace.PApplyArray( + (fun providedNamespace -> providedNamespace.GetNestedNamespaces()), + "GetNestedNamespaces", + range = m + ) + tryNamespaces providedNamespaces - and tryNamespaces (providedNamespaces: Tainted[]) = + and tryNamespaces (providedNamespaces: Tainted[]) = providedNamespaces |> Array.tryPick tryNamespace - let providedNamespaces = resolver.PApplyArray((fun resolver -> resolver.GetNamespaces()), "GetNamespaces", range=m) - match tryNamespaces providedNamespaces with + let providedNamespaces = + resolver.PApplyArray((fun resolver -> resolver.GetNamespaces()), "GetNamespaces", range = m) + + match tryNamespaces providedNamespaces with | None -> resolver.PApply((fun _ -> null), m) | Some res -> res - + /// Try to resolve a type against the given host with the given resolution environment. -let TryResolveProvidedType(resolver: Tainted, m, moduleOrNamespace, typeName) = - try +let TryResolveProvidedType (resolver: Tainted, m, moduleOrNamespace, typeName) = + try match ResolveProvidedType(resolver, m, moduleOrNamespace, typeName) with | Tainted.Null -> None | Tainted.NonNull ty -> Some ty - with RecoverableException e -> + with RecoverableException e -> errorRecovery e m None -let ILPathToProvidedType (st: Tainted, m) = - let nameContrib (st: Tainted) = +let ILPathToProvidedType (st: Tainted, m) = + let nameContrib (st: Tainted) = let typeName = st.PUntaint((fun st -> st.Name), m) - match st.PApply((fun st -> st.DeclaringType), m) with - | Tainted.Null -> - match st.PUntaint((fun st -> st.Namespace), m) with + + match st.PApply((fun st -> st.DeclaringType), m) with + | Tainted.Null -> + match st.PUntaint((fun st -> st.Namespace), m) with | Null -> typeName | NonNull ns -> ns + "." + typeName | _ -> typeName - let rec encContrib (st: Tainted) = - match st.PApply((fun st ->st.DeclaringType), m) with + let rec encContrib (st: Tainted) = + match st.PApply((fun st -> st.DeclaringType), m) with | Tainted.Null -> [] | Tainted.NonNull enc -> encContrib enc @ [ nameContrib enc ] encContrib st, nameContrib st -let ComputeMangledNameForApplyStaticParameters(nm, staticArgs, staticParams: Tainted, m) = - let defaultArgValues = - staticParams.PApply((fun ps -> ps |> Array.map (fun sp -> sp.Name, (if sp.IsOptional then Some (string sp.RawDefaultValue) else None ))), range=m) +let ComputeMangledNameForApplyStaticParameters (nm, staticArgs, staticParams: Tainted, m) = + let defaultArgValues = + staticParams.PApply( + (fun ps -> + ps + |> Array.map (fun sp -> + sp.Name, + (if sp.IsOptional then + Some(string sp.RawDefaultValue) + else + None))), + range = m + ) let defaultArgValues = defaultArgValues.PUntaint(id, m) PrettyNaming.ComputeMangledNameWithoutDefaultArgValues(nm, staticArgs, defaultArgValues) /// Apply the given provided method to the given static arguments (the arguments are assumed to have been sorted into application order) -let TryApplyProvidedMethod(methBeforeArgs: Tainted, staticArgs: objnull[], m: range) = - if staticArgs.Length = 0 then +let TryApplyProvidedMethod (methBeforeArgs: Tainted, staticArgs: objnull[], m: range) = + if staticArgs.Length = 0 then Some methBeforeArgs else - let mangledName = + let mangledName = let nm = methBeforeArgs.PUntaint((fun x -> x.Name), m) - let staticParams = - methBeforeArgs.PApplyWithProvider((fun (mb, resolver) -> mb.GetStaticParametersForMethod resolver |> nonNull), range=m) - let mangledName = ComputeMangledNameForApplyStaticParameters(nm, staticArgs, staticParams, m) + + let staticParams = + methBeforeArgs.PApplyWithProvider((fun (mb, resolver) -> mb.GetStaticParametersForMethod resolver |> nonNull), range = m) + + let mangledName = + ComputeMangledNameForApplyStaticParameters(nm, staticArgs, staticParams, m) + mangledName - match methBeforeArgs.PApplyWithProvider((fun (mb, provider) -> mb.ApplyStaticArgumentsForMethod(provider, mangledName, staticArgs)), range=m) with + + match + methBeforeArgs.PApplyWithProvider( + (fun (mb, provider) -> mb.ApplyStaticArgumentsForMethod(provider, mangledName, staticArgs)), + range = m + ) + with | Tainted.Null -> None - | Tainted.NonNull methWithArguments -> + | Tainted.NonNull methWithArguments -> let actualName = methWithArguments.PUntaint((fun x -> x.Name), m) - if actualName <> mangledName then - error(Error(FSComp.SR.etProvidedAppliedMethodHadWrongName(methWithArguments.TypeProviderDesignation, mangledName, actualName), m)) - Some methWithArguments + if actualName <> mangledName then + error ( + Error( + FSComp.SR.etProvidedAppliedMethodHadWrongName (methWithArguments.TypeProviderDesignation, mangledName, actualName), + m + ) + ) + + Some methWithArguments /// Apply the given provided type to the given static arguments (the arguments are assumed to have been sorted into application order -let TryApplyProvidedType(typeBeforeArguments: Tainted, optGeneratedTypePath: string list option, staticArgs: objnull[], m: range) = - if staticArgs.Length = 0 then - Some (typeBeforeArguments, (fun () -> ())) - else - - let fullTypePathAfterArguments = +let TryApplyProvidedType + (typeBeforeArguments: Tainted, optGeneratedTypePath: string list option, staticArgs: objnull[], m: range) + = + if staticArgs.Length = 0 then + Some(typeBeforeArguments, (fun () -> ())) + else + + let fullTypePathAfterArguments = // If there is a generated type name, then use that - match optGeneratedTypePath with + match optGeneratedTypePath with | Some path -> path - | None -> + | None -> // Otherwise, use the full path of the erased type, including mangled arguments let nm = typeBeforeArguments.PUntaint((fun x -> x.Name), m) - let enc, _ = ILPathToProvidedType (typeBeforeArguments, m) - let staticParams = typeBeforeArguments.PApplyWithProvider((fun (st, resolver) -> st.GetStaticParameters resolver |> nonNull), range=m) - let mangledName = ComputeMangledNameForApplyStaticParameters(nm, staticArgs, staticParams, m) + let enc, _ = ILPathToProvidedType(typeBeforeArguments, m) + + let staticParams = + typeBeforeArguments.PApplyWithProvider((fun (st, resolver) -> st.GetStaticParameters resolver |> nonNull), range = m) + + let mangledName = + ComputeMangledNameForApplyStaticParameters(nm, staticArgs, staticParams, m) + enc @ [ mangledName ] - match typeBeforeArguments.PApplyWithProvider((fun (typeBeforeArguments, provider) -> typeBeforeArguments.ApplyStaticArguments(provider, Array.ofList fullTypePathAfterArguments, staticArgs)), range=m) with + match + typeBeforeArguments.PApplyWithProvider( + (fun (typeBeforeArguments, provider) -> + typeBeforeArguments.ApplyStaticArguments(provider, Array.ofList fullTypePathAfterArguments, staticArgs)), + range = m + ) + with | Tainted.Null -> None - | Tainted.NonNull typeWithArguments -> + | Tainted.NonNull typeWithArguments -> let actualName = typeWithArguments.PUntaint((fun x -> x.Name), m) - let checkTypeName() = - let expectedTypeNameAfterArguments = fullTypePathAfterArguments[fullTypePathAfterArguments.Length-1] - if actualName <> expectedTypeNameAfterArguments then - error(Error(FSComp.SR.etProvidedAppliedTypeHadWrongName(typeWithArguments.TypeProviderDesignation, expectedTypeNameAfterArguments, actualName), m)) - Some (typeWithArguments, checkTypeName) + + let checkTypeName () = + let expectedTypeNameAfterArguments = + fullTypePathAfterArguments[fullTypePathAfterArguments.Length - 1] + + if actualName <> expectedTypeNameAfterArguments then + error ( + Error( + FSComp.SR.etProvidedAppliedTypeHadWrongName ( + typeWithArguments.TypeProviderDesignation, + expectedTypeNameAfterArguments, + actualName + ), + m + ) + ) + + Some(typeWithArguments, checkTypeName) /// Given a mangled name reference to a non-nested provided type, resolve it. /// If necessary, demangle its static arguments before applying them. -let TryLinkProvidedType(resolver: Tainted, moduleOrNamespace: string[], typeLogicalName: string, range: range) = - +let TryLinkProvidedType (resolver: Tainted, moduleOrNamespace: string[], typeLogicalName: string, range: range) = + // Demangle the static parameters - let typeName, argNamesAndValues = - try - PrettyNaming.DemangleProvidedTypeName typeLogicalName - with PrettyNaming.InvalidMangledStaticArg piece -> - error(Error(FSComp.SR.etProvidedTypeReferenceInvalidText piece, range0)) + let typeName, argNamesAndValues = + try + PrettyNaming.DemangleProvidedTypeName typeLogicalName + with PrettyNaming.InvalidMangledStaticArg piece -> + error (Error(FSComp.SR.etProvidedTypeReferenceInvalidText piece, range0)) let argSpecsTable = dict argNamesAndValues - let typeBeforeArguments = ResolveProvidedType(resolver, range0, moduleOrNamespace, typeName) - match typeBeforeArguments with + let typeBeforeArguments = + ResolveProvidedType(resolver, range0, moduleOrNamespace, typeName) + + match typeBeforeArguments with | Tainted.Null -> None - | Tainted.NonNull typeBeforeArguments -> - // Take the static arguments (as strings, taken from the text in the reference we're relinking), + | Tainted.NonNull typeBeforeArguments -> + // Take the static arguments (as strings, taken from the text in the reference we're relinking), // and convert them to objects of the appropriate type, based on the expected kind. let staticParameters = - typeBeforeArguments.PApplyWithProvider((fun (typeBeforeArguments, resolver) -> - typeBeforeArguments.GetStaticParameters resolver),range=range0) + typeBeforeArguments.PApplyWithProvider( + (fun (typeBeforeArguments, resolver) -> typeBeforeArguments.GetStaticParameters resolver), + range = range0 + ) let staticParameters = staticParameters.PApplyArray(id, "", range) - - let staticArgs = - staticParameters |> Array.map (fun sp -> - let typeBeforeArgumentsName = typeBeforeArguments.PUntaint ((fun st -> st.Name), range) - let spName = sp.PUntaint ((fun sp -> sp.Name), range) + + let staticArgs = + staticParameters + |> Array.map (fun sp -> + let typeBeforeArgumentsName = + typeBeforeArguments.PUntaint((fun st -> st.Name), range) + + let spName = sp.PUntaint((fun sp -> sp.Name), range) + match argSpecsTable.TryGetValue spName with | true, arg -> /// Find the name of the representation type for the static parameter - let spReprTypeName = - sp.PUntaint((fun sp -> - let pt = sp.ParameterType - let uet = if pt.IsEnum then pt.GetEnumUnderlyingType() else pt - !!uet.FullName), range) - - match spReprTypeName with + let spReprTypeName = + sp.PUntaint( + (fun sp -> + let pt = sp.ParameterType + let uet = if pt.IsEnum then pt.GetEnumUnderlyingType() else pt + !!uet.FullName), + range + ) + + match spReprTypeName with | "System.SByte" -> box (sbyte arg) | "System.Int16" -> box (int16 arg) | "System.Int32" -> box (int32 arg) @@ -1367,52 +1799,68 @@ let TryLinkProvidedType(resolver: Tainted, moduleOrNamespace: str | "System.Char" -> box (char arg) | "System.Boolean" -> box (arg = "True") | "System.String" -> box (string arg) - | s -> error(Error(FSComp.SR.etUnknownStaticArgumentKind(s, typeLogicalName), range0)) + | s -> error (Error(FSComp.SR.etUnknownStaticArgumentKind (s, typeLogicalName), range0)) | _ -> - if sp.PUntaint ((fun sp -> sp.IsOptional), range) then + if sp.PUntaint((fun sp -> sp.IsOptional), range) then match sp.PUntaint((fun sp -> sp.RawDefaultValue), range) with - | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, typeBeforeArgumentsName, typeBeforeArgumentsName, spName), range0)) + | null -> + error ( + Error( + FSComp.SR.etStaticParameterRequiresAValue ( + spName, + typeBeforeArgumentsName, + typeBeforeArgumentsName, + spName + ), + range0 + ) + ) | v -> v else - error(Error(FSComp.SR.etProvidedTypeReferenceMissingArgument spName, range0))) - + error (Error(FSComp.SR.etProvidedTypeReferenceMissingArgument spName, range0))) - match TryApplyProvidedType(typeBeforeArguments, None, staticArgs, range0) with - | Some (typeWithArguments, checkTypeName) -> - checkTypeName() + match TryApplyProvidedType(typeBeforeArguments, None, staticArgs, range0) with + | Some(typeWithArguments, checkTypeName) -> + checkTypeName () Some typeWithArguments | None -> None /// Get the parts of a .NET namespace. Special rules: null means global, empty is not allowed. -let GetPartsOfNamespaceRecover(namespaceName: string MaybeNull) = - match namespaceName with - | Null -> [] - | NonNull namespaceName -> - if namespaceName.Length = 0 then [""] - else splitNamespace namespaceName +let GetPartsOfNamespaceRecover (namespaceName: string MaybeNull) = + match namespaceName with + | Null -> [] + | NonNull namespaceName -> + if namespaceName.Length = 0 then + [ "" ] + else + splitNamespace namespaceName /// Get the parts of a .NET namespace. Special rules: null means global, empty is not allowed. -let GetProvidedNamespaceAsPath (m, resolver: Tainted, namespaceName:string MaybeNull) = - match namespaceName with - | Null -> [] - | NonNull namespaceName -> +let GetProvidedNamespaceAsPath (m, resolver: Tainted, namespaceName: string MaybeNull) = + match namespaceName with + | Null -> [] + | NonNull namespaceName -> if namespaceName.Length = 0 then - errorR(Error(FSComp.SR.etEmptyNamespaceNotAllowed(DisplayNameOfTypeProvider(resolver.TypeProvider, m)), m)) + errorR (Error(FSComp.SR.etEmptyNamespaceNotAllowed (DisplayNameOfTypeProvider(resolver.TypeProvider, m)), m)) + GetPartsOfNamespaceRecover namespaceName -/// Get the parts of the name that encloses the .NET type including nested types. -let GetFSharpPathToProvidedType (st: Tainted, range) = +/// Get the parts of the name that encloses the .NET type including nested types. +let GetFSharpPathToProvidedType (st: Tainted, range) = // Can't use st.Fullname because it may be like IEnumerable // We want [System;Collections;Generic] - let namespaceParts = GetPartsOfNamespaceRecover(st.PUntaint((fun st -> st.Namespace), range)) - let rec walkUpNestedClasses(st: Tainted, soFar) = + let namespaceParts = + GetPartsOfNamespaceRecover(st.PUntaint((fun st -> st.Namespace), range)) + + let rec walkUpNestedClasses (st: Tainted, soFar) = match st with | Tainted.Null -> soFar - | Tainted.NonNull st -> walkUpNestedClasses(st.PApply((fun st ->st.DeclaringType), range), soFar) @ [st.PUntaint((fun st -> st.Name), range)] - - walkUpNestedClasses(st.PApply((fun st ->st.DeclaringType), range), namespaceParts) + | Tainted.NonNull st -> + walkUpNestedClasses (st.PApply((fun st -> st.DeclaringType), range), soFar) + @ [ st.PUntaint((fun st -> st.Name), range) ] + walkUpNestedClasses (st.PApply((fun st -> st.DeclaringType), range), namespaceParts) /// Get the ILAssemblyRef for a provided assembly. Do not take into account /// any type relocations or static linking for generated types. @@ -1422,29 +1870,33 @@ let GetOriginalILAssemblyRefOfProvidedAssembly (assembly: Tainted, range) = - - let aref = GetOriginalILAssemblyRefOfProvidedAssembly (st.PApply((fun st -> nonNull st.Assembly), range), range) // NULLNESS TODO: why is explicit instantiation needed here +let GetOriginalILTypeRefOfProvidedType (st: Tainted, range) = + + let aref = + GetOriginalILAssemblyRefOfProvidedAssembly(st.PApply((fun st -> nonNull st.Assembly), range), range) // NULLNESS TODO: why is explicit instantiation needed here + let scoperef = ILScopeRef.Assembly aref - let enc, nm = ILPathToProvidedType (st, range) + let enc, nm = ILPathToProvidedType(st, range) let tref = ILTypeRef.Create(scoperef, enc, nm) tref /// Get the ILTypeRef for the provided type (including for nested types). Take into account /// any type relocations or static linking for generated types. -let GetILTypeRefOfProvidedType (st: Tainted, range) = - match st.PUntaint((fun st -> st.TryGetILTypeRef()), range) with +let GetILTypeRefOfProvidedType (st: Tainted, range) = + match st.PUntaint((fun st -> st.TryGetILTypeRef()), range) with | Some ilTypeRef -> ilTypeRef - | None -> GetOriginalILTypeRefOfProvidedType (st, range) + | None -> GetOriginalILTypeRefOfProvidedType(st, range) type ProviderGeneratedType = ProviderGeneratedType of ilOrigTyRef: ILTypeRef * ilRenamedTyRef: ILTypeRef * ProviderGeneratedType list /// The table of information recording remappings from type names in the provided assembly to type /// names in the statically linked, embedded assembly, plus what types are nested in side what types. -type ProvidedAssemblyStaticLinkingMap = - { ILTypeMap: Dictionary } - static member CreateNew() = - { ILTypeMap = Dictionary() } +type ProvidedAssemblyStaticLinkingMap = + { + ILTypeMap: Dictionary + } + + static member CreateNew() = { ILTypeMap = Dictionary() } /// Check if this is a direct reference to a non-embedded generated type. This is not permitted at any name resolution. /// We check by seeing if the type is absent from the remapping context. diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 47815bed680..d952c822489 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - + /// Defines the typed abstract syntax intermediate representation used throughout the F# compiler. -module internal rec FSharp.Compiler.TypedTree +module internal rec FSharp.Compiler.TypedTree open System open System.Collections.Generic @@ -14,8 +14,8 @@ open Internal.Utilities.Library open Internal.Utilities.Library.Extras open Internal.Utilities.Rational -open FSharp.Compiler -open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler +open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types open FSharp.Compiler.CompilerGlobalState open FSharp.Compiler.DiagnosticsLogger @@ -35,7 +35,8 @@ open FSharp.Core.CompilerServices [] module WellKnownNames = /// Special name for the defensive copy of a struct, we use it in situations like when we get an address of a field in ax-assembly scenario. - let [] CopyOfStruct = "copyOfStruct" + [] + let CopyOfStruct = "copyOfStruct" type Stamp = int64 @@ -44,7 +45,7 @@ type StampMap<'T> = Map [] type ValInline = - /// Indicates the value is inlined but the .NET IL code for the function still exists, e.g. to satisfy interfaces on objects, but that it is also always inlined + /// Indicates the value is inlined but the .NET IL code for the function still exists, e.g. to satisfy interfaces on objects, but that it is also always inlined | Always /// Indicates the value may optionally be inlined by the optimizer @@ -54,209 +55,230 @@ type ValInline = | Never /// Returns true if the implementation of a value should be inlined - member x.ShouldInline = - match x with - | ValInline.Always -> true - | ValInline.Optional | ValInline.Never -> false + member x.ShouldInline = + match x with + | ValInline.Always -> true + | ValInline.Optional + | ValInline.Never -> false -/// A flag associated with values that indicates whether the recursive scope of the value is currently being processed, and +/// A flag associated with values that indicates whether the recursive scope of the value is currently being processed, and /// if the value has been generalized or not as yet. type ValRecursiveScopeInfo = - /// Set while the value is within its recursive scope. The flag indicates if the value has been eagerly generalized and accepts generic-recursive calls + /// Set while the value is within its recursive scope. The flag indicates if the value has been eagerly generalized and accepts generic-recursive calls | ValInRecScope of bool - /// The normal value for this flag when the value is not within its recursive scope + /// The normal value for this flag when the value is not within its recursive scope | ValNotInRecScope -type ValMutability = - | Immutable - | Mutable +type ValMutability = + | Immutable + | Mutable /// Indicates if a type parameter is needed at runtime and may not be eliminated [] -type TyparDynamicReq = +type TyparDynamicReq = /// Indicates the type parameter is not needed at runtime and may be eliminated - | No + | No /// Indicates the type parameter is needed at runtime and may not be eliminated | Yes -type ValBaseOrThisInfo = +type ValBaseOrThisInfo = - /// Indicates a ref-cell holding 'this' or the implicit 'this' used throughout an + /// Indicates a ref-cell holding 'this' or the implicit 'this' used throughout an /// implicit constructor to access and set values - | CtorThisVal + | CtorThisVal /// Indicates the value called 'base' available for calling base class members - | BaseVal + | BaseVal /// Indicates a normal value - | NormalVal + | NormalVal /// Indicates the 'this' value specified in a member e.g. 'x' in 'member x.M() = 1' - | MemberThisVal + | MemberThisVal /// Flags on values [] -type ValFlags(flags: int64) = - - new (recValInfo, baseOrThis, isCompGen, inlineInfo, isMutable, isModuleOrMemberBinding, isExtensionMember, isIncrClassSpecialMember, isTyFunc, allowTypeInst, isGeneratedEventVal) = - let flags = - (match baseOrThis with - | BaseVal -> 0b00000000000000000000L - | CtorThisVal -> 0b00000000000000000010L - | NormalVal -> 0b00000000000000000100L - | MemberThisVal -> 0b00000000000000000110L) ||| - (if isCompGen then 0b00000000000000001000L - else 0b000000000000000000000L) ||| - (match inlineInfo with - | ValInline.Always -> 0b00000000000000010000L - | ValInline.Optional -> 0b00000000000000100000L - | ValInline.Never -> 0b00000000000000110000L) ||| - (match isMutable with - | Immutable -> 0b00000000000000000000L - | Mutable -> 0b00000000000001000000L) ||| - - (match isModuleOrMemberBinding with - | false -> 0b00000000000000000000L - | true -> 0b00000000000010000000L) ||| - (match isExtensionMember with - | false -> 0b00000000000000000000L - | true -> 0b00000000000100000000L) ||| - (match isIncrClassSpecialMember with - | false -> 0b00000000000000000000L - | true -> 0b00000000001000000000L) ||| - (match isTyFunc with - | false -> 0b00000000000000000000L - | true -> 0b00000000010000000000L) ||| - - (match recValInfo with - | ValNotInRecScope -> 0b00000000000000000000L - | ValInRecScope true -> 0b00000000100000000000L - | ValInRecScope false -> 0b00000001000000000000L) ||| - - (match allowTypeInst with - | false -> 0b00000000000000000000L - | true -> 0b00000100000000000000L) ||| - - (match isGeneratedEventVal with - | false -> 0b00000000000000000000L - | true -> 0b00100000000000000000L) +type ValFlags(flags: int64) = + + new + ( + recValInfo, + baseOrThis, + isCompGen, + inlineInfo, + isMutable, + isModuleOrMemberBinding, + isExtensionMember, + isIncrClassSpecialMember, + isTyFunc, + allowTypeInst, + isGeneratedEventVal + ) = + let flags = + (match baseOrThis with + | BaseVal -> 0b00000000000000000000L + | CtorThisVal -> 0b00000000000000000010L + | NormalVal -> 0b00000000000000000100L + | MemberThisVal -> 0b00000000000000000110L) + ||| (if isCompGen then + 0b00000000000000001000L + else + 0b000000000000000000000L) + ||| (match inlineInfo with + | ValInline.Always -> 0b00000000000000010000L + | ValInline.Optional -> 0b00000000000000100000L + | ValInline.Never -> 0b00000000000000110000L) + ||| (match isMutable with + | Immutable -> 0b00000000000000000000L + | Mutable -> 0b00000000000001000000L) + ||| + + (match isModuleOrMemberBinding with + | false -> 0b00000000000000000000L + | true -> 0b00000000000010000000L) + ||| (match isExtensionMember with + | false -> 0b00000000000000000000L + | true -> 0b00000000000100000000L) + ||| (match isIncrClassSpecialMember with + | false -> 0b00000000000000000000L + | true -> 0b00000000001000000000L) + ||| (match isTyFunc with + | false -> 0b00000000000000000000L + | true -> 0b00000000010000000000L) + ||| + + (match recValInfo with + | ValNotInRecScope -> 0b00000000000000000000L + | ValInRecScope true -> 0b00000000100000000000L + | ValInRecScope false -> 0b00000001000000000000L) + ||| + + (match allowTypeInst with + | false -> 0b00000000000000000000L + | true -> 0b00000100000000000000L) + ||| + + (match isGeneratedEventVal with + | false -> 0b00000000000000000000L + | true -> 0b00100000000000000000L) ValFlags flags - member x.BaseOrThisInfo = - match (flags &&& 0b00000000000000000110L) with - | 0b00000000000000000000L -> BaseVal - | 0b00000000000000000010L -> CtorThisVal - | 0b00000000000000000100L -> NormalVal - | 0b00000000000000000110L -> MemberThisVal - | _ -> failwith "unreachable" - - - - member x.IsCompilerGenerated = (flags &&& 0b00000000000000001000L) <> 0x0L - - member x.WithIsCompilerGenerated isCompGen = - let flags = (flags &&& ~~~0b00000000000000001000L) ||| - (match isCompGen with - | false -> 0b00000000000000000000L - | true -> 0b00000000000000001000L) - ValFlags flags - - member x.InlineInfo = - match (flags &&& 0b00000000000000110000L) with - | 0b00000000000000000000L - | 0b00000000000000010000L -> ValInline.Always - | 0b00000000000000100000L -> ValInline.Optional - | 0b00000000000000110000L -> ValInline.Never - | _ -> failwith "unreachable" - - member x.MutabilityInfo = - match (flags &&& 0b00000000000001000000L) with - | 0b00000000000000000000L -> Immutable - | 0b00000000000001000000L -> Mutable - | _ -> failwith "unreachable" + member x.BaseOrThisInfo = + match (flags &&& 0b00000000000000000110L) with + | 0b00000000000000000000L -> BaseVal + | 0b00000000000000000010L -> CtorThisVal + | 0b00000000000000000100L -> NormalVal + | 0b00000000000000000110L -> MemberThisVal + | _ -> failwith "unreachable" + member x.IsCompilerGenerated = (flags &&& 0b00000000000000001000L) <> 0x0L - member x.IsMemberOrModuleBinding = - match (flags &&& 0b00000000000010000000L) with - | 0b00000000000000000000L -> false - | 0b00000000000010000000L -> true - | _ -> failwith "unreachable" + member x.WithIsCompilerGenerated isCompGen = + let flags = + (flags &&& ~~~0b00000000000000001000L) + ||| (match isCompGen with + | false -> 0b00000000000000000000L + | true -> 0b00000000000000001000L) + ValFlags flags - member x.WithIsMemberOrModuleBinding = ValFlags(flags ||| 0b00000000000010000000L) - - - member x.IsExtensionMember = (flags &&& 0b00000000000100000000L) <> 0L - - member x.IsIncrClassSpecialMember = (flags &&& 0b00000000001000000000L) <> 0L - - member x.IsTypeFunction = (flags &&& 0b00000000010000000000L) <> 0L - - member x.RecursiveValInfo = match (flags &&& 0b00000001100000000000L) with - | 0b00000000000000000000L -> ValNotInRecScope - | 0b00000000100000000000L -> ValInRecScope true - | 0b00000001000000000000L -> ValInRecScope false - | _ -> failwith "unreachable" + member x.InlineInfo = + match (flags &&& 0b00000000000000110000L) with + | 0b00000000000000000000L + | 0b00000000000000010000L -> ValInline.Always + | 0b00000000000000100000L -> ValInline.Optional + | 0b00000000000000110000L -> ValInline.Never + | _ -> failwith "unreachable" + + member x.MutabilityInfo = + match (flags &&& 0b00000000000001000000L) with + | 0b00000000000000000000L -> Immutable + | 0b00000000000001000000L -> Mutable + | _ -> failwith "unreachable" + + member x.IsMemberOrModuleBinding = + match (flags &&& 0b00000000000010000000L) with + | 0b00000000000000000000L -> false + | 0b00000000000010000000L -> true + | _ -> failwith "unreachable" + + member x.WithIsMemberOrModuleBinding = ValFlags(flags ||| 0b00000000000010000000L) + + member x.IsExtensionMember = (flags &&& 0b00000000000100000000L) <> 0L + + member x.IsIncrClassSpecialMember = (flags &&& 0b00000000001000000000L) <> 0L + + member x.IsTypeFunction = (flags &&& 0b00000000010000000000L) <> 0L + + member x.RecursiveValInfo = + match (flags &&& 0b00000001100000000000L) with + | 0b00000000000000000000L -> ValNotInRecScope + | 0b00000000100000000000L -> ValInRecScope true + | 0b00000001000000000000L -> ValInRecScope false + | _ -> failwith "unreachable" + + member x.WithRecursiveValInfo recValInfo = + let flags = + (flags &&& ~~~0b00000001100000000000L) + ||| (match recValInfo with + | ValNotInRecScope -> 0b00000000000000000000L + | ValInRecScope true -> 0b00000000100000000000L + | ValInRecScope false -> 0b00000001000000000000L) - member x.WithRecursiveValInfo recValInfo = - let flags = - (flags &&& ~~~0b00000001100000000000L) ||| - (match recValInfo with - | ValNotInRecScope -> 0b00000000000000000000L - | ValInRecScope true -> 0b00000000100000000000L - | ValInRecScope false -> 0b00000001000000000000L) - ValFlags flags + ValFlags flags - member x.MakesNoCriticalTailcalls = (flags &&& 0b00000010000000000000L) <> 0L + member x.MakesNoCriticalTailcalls = (flags &&& 0b00000010000000000000L) <> 0L - member x.WithMakesNoCriticalTailcalls = ValFlags(flags ||| 0b00000010000000000000L) + member x.WithMakesNoCriticalTailcalls = ValFlags(flags ||| 0b00000010000000000000L) - member x.PermitsExplicitTypeInstantiation = (flags &&& 0b00000100000000000000L) <> 0L + member x.PermitsExplicitTypeInstantiation = (flags &&& 0b00000100000000000000L) <> 0L - member x.HasBeenReferenced = (flags &&& 0b00001000000000000000L) <> 0L + member x.HasBeenReferenced = (flags &&& 0b00001000000000000000L) <> 0L - member x.WithHasBeenReferenced = ValFlags(flags ||| 0b00001000000000000000L) + member x.WithHasBeenReferenced = ValFlags(flags ||| 0b00001000000000000000L) - member x.IsCompiledAsStaticPropertyWithoutField = (flags &&& 0b00010000000000000000L) <> 0L + member x.IsCompiledAsStaticPropertyWithoutField = + (flags &&& 0b00010000000000000000L) <> 0L - member x.WithIsCompiledAsStaticPropertyWithoutField = ValFlags(flags ||| 0b00010000000000000000L) + member x.WithIsCompiledAsStaticPropertyWithoutField = + ValFlags(flags ||| 0b00010000000000000000L) - member x.IsGeneratedEventVal = (flags &&& 0b00100000000000000000L) <> 0L + member x.IsGeneratedEventVal = (flags &&& 0b00100000000000000000L) <> 0L - member x.IsFixed = (flags &&& 0b01000000000000000000L) <> 0L + member x.IsFixed = (flags &&& 0b01000000000000000000L) <> 0L - member x.WithIsFixed = ValFlags(flags ||| 0b01000000000000000000L) + member x.WithIsFixed = ValFlags(flags ||| 0b01000000000000000000L) - member x.IgnoresByrefScope = (flags &&& 0b10000000000000000000L) <> 0L + member x.IgnoresByrefScope = (flags &&& 0b10000000000000000000L) <> 0L - member x.WithIgnoresByrefScope = ValFlags(flags ||| 0b10000000000000000000L) + member x.WithIgnoresByrefScope = ValFlags(flags ||| 0b10000000000000000000L) - member x.InlineIfLambda = (flags &&& 0b100000000000000000000L) <> 0L + member x.InlineIfLambda = (flags &&& 0b100000000000000000000L) <> 0L - member x.WithInlineIfLambda = ValFlags(flags ||| 0b100000000000000000000L) + member x.WithInlineIfLambda = ValFlags(flags ||| 0b100000000000000000000L) - member x.IsImplied = (flags &&& 0b1000000000000000000000L) <> 0L + member x.IsImplied = (flags &&& 0b1000000000000000000000L) <> 0L - member x.WithIsImplied = ValFlags(flags ||| 0b1000000000000000000000L) + member x.WithIsImplied = ValFlags(flags ||| 0b1000000000000000000000L) /// Get the flags as included in the F# binary metadata - member x.PickledBits = + member x.PickledBits = // Clear the RecursiveValInfo, only used during inference and irrelevant across assembly boundaries // Clear the IsCompiledAsStaticPropertyWithoutField, only used to determine whether to use a true field for a value, and to eliminate the optimization info for observable bindings // Clear the HasBeenReferenced, only used to report "unreferenced variable" warnings and to help collect 'it' values in FSI.EXE // Clear the IsGeneratedEventVal, since there's no use in propagating specialname information for generated add/remove event vals - (flags &&& ~~~0b010011001100000000000L) + (flags &&& ~~~0b010011001100000000000L) /// Represents the kind of a type parameter [] -type TyparKind = +type TyparKind = - | Type + | Type | Measure @@ -274,18 +296,18 @@ type TyparKind = | TyparKind.Measure -> "measure" /// Indicates if the type variable can be solved or given new constraints. The status of a type variable -/// evolves towards being either rigid or solved. +/// evolves towards being either rigid or solved. [] -type TyparRigidity = +type TyparRigidity = /// Indicates the type parameter can't be solved - | Rigid + | Rigid /// Indicates the type parameter can't be solved, but the variable is not set to "rigid" until after inference is complete - | WillBeRigid + | WillBeRigid /// Indicates we give a warning if the type parameter is ever solved - | WarnIfNotRigid + | WarnIfNotRigid /// Indicates the type parameter is an inference variable may be solved | Flexible @@ -294,227 +316,255 @@ type TyparRigidity = /// For units-of-measure, we give a warning if this gets solved to '1' | Anon - member x.ErrorIfUnified = match x with TyparRigidity.Rigid -> true | _ -> false - - member x.WarnIfUnified = match x with TyparRigidity.WillBeRigid | TyparRigidity.WarnIfNotRigid -> true | _ -> false + member x.ErrorIfUnified = + match x with + | TyparRigidity.Rigid -> true + | _ -> false - member x.WarnIfMissingConstraint = match x with TyparRigidity.WillBeRigid -> true | _ -> false + member x.WarnIfUnified = + match x with + | TyparRigidity.WillBeRigid + | TyparRigidity.WarnIfNotRigid -> true + | _ -> false + member x.WarnIfMissingConstraint = + match x with + | TyparRigidity.WillBeRigid -> true + | _ -> false -/// Encode typar flags into a bit field +/// Encode typar flags into a bit field [] type TyparFlags(flags: int32) = - new (kind: TyparKind, rigidity: TyparRigidity, isFromError: bool, isCompGen: bool, staticReq: TyparStaticReq, dynamicReq: TyparDynamicReq, equalityDependsOn: bool, comparisonDependsOn: bool, supportsNullFlex: bool) = - TyparFlags((if isFromError then 0b00000000000000010 else 0) ||| - (if isCompGen then 0b00000000000000100 else 0) ||| - (match staticReq with - | TyparStaticReq.None -> 0b00000000000000000 - | TyparStaticReq.HeadType -> 0b00000000000001000) ||| - (match rigidity with - | TyparRigidity.Rigid -> 0b00000000000000000 - | TyparRigidity.WillBeRigid -> 0b00000000000100000 - | TyparRigidity.WarnIfNotRigid -> 0b00000000001000000 - | TyparRigidity.Flexible -> 0b00000000001100000 - | TyparRigidity.Anon -> 0b00000000010000000) ||| - (match kind with - | TyparKind.Type -> 0b00000000000000000 - | TyparKind.Measure -> 0b00000000100000000) ||| - (if comparisonDependsOn then - 0b00000001000000000 else 0) ||| - (match dynamicReq with - | TyparDynamicReq.No -> 0b00000000000000000 - | TyparDynamicReq.Yes -> 0b00000010000000000) ||| - (if equalityDependsOn then - 0b00000100000000000 else 0) ||| - // 0b00001000100000000 is being checked by x.Kind, but never set in this version of the code - // 0b00010000000000000 is taken by compat flex - (if supportsNullFlex then - 0b00100000000000000 else 0)) + new + ( + kind: TyparKind, + rigidity: TyparRigidity, + isFromError: bool, + isCompGen: bool, + staticReq: TyparStaticReq, + dynamicReq: TyparDynamicReq, + equalityDependsOn: bool, + comparisonDependsOn: bool, + supportsNullFlex: bool + ) = + TyparFlags( + (if isFromError then 0b00000000000000010 else 0) + ||| (if isCompGen then 0b00000000000000100 else 0) + ||| (match staticReq with + | TyparStaticReq.None -> 0b00000000000000000 + | TyparStaticReq.HeadType -> 0b00000000000001000) + ||| (match rigidity with + | TyparRigidity.Rigid -> 0b00000000000000000 + | TyparRigidity.WillBeRigid -> 0b00000000000100000 + | TyparRigidity.WarnIfNotRigid -> 0b00000000001000000 + | TyparRigidity.Flexible -> 0b00000000001100000 + | TyparRigidity.Anon -> 0b00000000010000000) + ||| (match kind with + | TyparKind.Type -> 0b00000000000000000 + | TyparKind.Measure -> 0b00000000100000000) + ||| (if comparisonDependsOn then 0b00000001000000000 else 0) + ||| (match dynamicReq with + | TyparDynamicReq.No -> 0b00000000000000000 + | TyparDynamicReq.Yes -> 0b00000010000000000) + ||| (if equalityDependsOn then 0b00000100000000000 else 0) + ||| + // 0b00001000100000000 is being checked by x.Kind, but never set in this version of the code + // 0b00010000000000000 is taken by compat flex + (if supportsNullFlex then 0b00100000000000000 else 0) + ) /// Indicates if the type inference variable was generated after an error when type checking expressions or patterns - member x.IsFromError = (flags &&& 0b00000000000000010) <> 0x0 + member x.IsFromError = (flags &&& 0b00000000000000010) <> 0x0 - /// Indicates if the type variable is compiler generated, i.e. is an implicit type inference variable + /// Indicates if the type variable is compiler generated, i.e. is an implicit type inference variable member x.IsCompilerGenerated = (flags &&& 0b00000000000000100) <> 0x0 /// Indicates if the type variable has a static "head type" requirement, i.e. ^a variables used in FSharp.Core and member constraints. - member x.StaticReq = - match (flags &&& 0b00000000000001000) with - | 0b00000000000000000 -> TyparStaticReq.None - | 0b00000000000001000 -> TyparStaticReq.HeadType - | _ -> failwith "unreachable" + member x.StaticReq = + match (flags &&& 0b00000000000001000) with + | 0b00000000000000000 -> TyparStaticReq.None + | 0b00000000000001000 -> TyparStaticReq.HeadType + | _ -> failwith "unreachable" /// Indicates if the type variable can be solved or given new constraints. The status of a type variable - /// generally always evolves towards being either rigid or solved. - member x.Rigidity = - match (flags &&& 0b00000000011100000) with - | 0b00000000000000000 -> TyparRigidity.Rigid - | 0b00000000000100000 -> TyparRigidity.WillBeRigid - | 0b00000000001000000 -> TyparRigidity.WarnIfNotRigid - | 0b00000000001100000 -> TyparRigidity.Flexible - | 0b00000000010000000 -> TyparRigidity.Anon - | _ -> failwith "unreachable" + /// generally always evolves towards being either rigid or solved. + member x.Rigidity = + match (flags &&& 0b00000000011100000) with + | 0b00000000000000000 -> TyparRigidity.Rigid + | 0b00000000000100000 -> TyparRigidity.WillBeRigid + | 0b00000000001000000 -> TyparRigidity.WarnIfNotRigid + | 0b00000000001100000 -> TyparRigidity.Flexible + | 0b00000000010000000 -> TyparRigidity.Anon + | _ -> failwith "unreachable" /// Indicates whether a type variable can be instantiated by types or units-of-measure. - member x.Kind = - match (flags &&& 0b00001000100000000) with - | 0b00000000000000000 -> TyparKind.Type - | 0b00000000100000000 -> TyparKind.Measure - | _ -> failwith "unreachable" - + member x.Kind = + match (flags &&& 0b00001000100000000) with + | 0b00000000000000000 -> TyparKind.Type + | 0b00000000100000000 -> TyparKind.Measure + | _ -> failwith "unreachable" /// Indicates that whether or not a generic type definition satisfies the comparison constraint is dependent on whether this type variable satisfies the comparison constraint. - member x.ComparisonConditionalOn = - (flags &&& 0b00000001000000000) <> 0x0 + member x.ComparisonConditionalOn = (flags &&& 0b00000001000000000) <> 0x0 /// Indicates if a type parameter is needed at runtime and may not be eliminated - member x.DynamicReq = - match (flags &&& 0b00000010000000000) with - | 0b00000000000000000 -> TyparDynamicReq.No - | 0b00000010000000000 -> TyparDynamicReq.Yes - | _ -> failwith "unreachable" + member x.DynamicReq = + match (flags &&& 0b00000010000000000) with + | 0b00000000000000000 -> TyparDynamicReq.No + | 0b00000010000000000 -> TyparDynamicReq.Yes + | _ -> failwith "unreachable" /// Indicates that whether or not a generic type definition satisfies the equality constraint is dependent on whether this type variable satisfies the equality constraint. - member x.EqualityConditionalOn = - (flags &&& 0b00000100000000000) <> 0x0 + member x.EqualityConditionalOn = (flags &&& 0b00000100000000000) <> 0x0 /// Indicates that whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) - member x.IsCompatFlex = - (flags &&& 0b00010000000000000) <> 0x0 + member x.IsCompatFlex = (flags &&& 0b00010000000000000) <> 0x0 - member x.WithCompatFlex b = - if b then - TyparFlags(flags ||| 0b00010000000000000) - else - TyparFlags(flags &&& ~~~0b00010000000000000) + member x.WithCompatFlex b = + if b then + TyparFlags(flags ||| 0b00010000000000000) + else + TyparFlags(flags &&& ~~~0b00010000000000000) /// Indicates that whether this type parameter is flexible for 'supports null' constraint, e.g. in the case of assignment to a mutable value - member x.IsSupportsNullFlex = - (flags &&& 0b00100000000000000) <> 0x0 + member x.IsSupportsNullFlex = (flags &&& 0b00100000000000000) <> 0x0 - member x.WithSupportsNullFlex b = - if b then - TyparFlags(flags ||| 0b00100000000000000) - else - TyparFlags(flags &&& ~~~0b00100000000000000) - - - - member x.WithStaticReq staticReq = - TyparFlags(x.Kind, x.Rigidity, x.IsFromError, x.IsCompilerGenerated, staticReq, x.DynamicReq, x.EqualityConditionalOn, x.ComparisonConditionalOn, x.IsSupportsNullFlex) + member x.WithSupportsNullFlex b = + if b then + TyparFlags(flags ||| 0b00100000000000000) + else + TyparFlags(flags &&& ~~~0b00100000000000000) + + member x.WithStaticReq staticReq = + TyparFlags( + x.Kind, + x.Rigidity, + x.IsFromError, + x.IsCompilerGenerated, + staticReq, + x.DynamicReq, + x.EqualityConditionalOn, + x.ComparisonConditionalOn, + x.IsSupportsNullFlex + ) /// Get the flags as included in the F# binary metadata. We pickle this as int64 to allow for future expansion - member x.PickledBits = flags + member x.PickledBits = flags /// Encode entity flags into a bit field. We leave lots of space to allow for future expansion. [] type EntityFlags(flags: int64) = - new (usesPrefixDisplay, isModuleOrNamespace, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordOrUnionType) = - EntityFlags((if isModuleOrNamespace then 0b000000000000001L else 0L) ||| - (if usesPrefixDisplay then 0b000000000000010L else 0L) ||| - (if preEstablishedHasDefaultCtor then 0b000000000000100L else 0L) ||| - (if hasSelfReferentialCtor then 0b000000000001000L else 0L) ||| - (if isStructRecordOrUnionType then 0b000000000100000L else 0L)) + new(usesPrefixDisplay, isModuleOrNamespace, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordOrUnionType) = + EntityFlags( + (if isModuleOrNamespace then 0b000000000000001L else 0L) + ||| (if usesPrefixDisplay then 0b000000000000010L else 0L) + ||| (if preEstablishedHasDefaultCtor then + 0b000000000000100L + else + 0L) + ||| (if hasSelfReferentialCtor then 0b000000000001000L else 0L) + ||| (if isStructRecordOrUnionType then 0b000000000100000L else 0L) + ) /// Indicates the Entity is actually a module or namespace, not a type definition - member x.IsModuleOrNamespace = (flags &&& 0b000000000000001L) <> 0x0L + member x.IsModuleOrNamespace = (flags &&& 0b000000000000001L) <> 0x0L + + /// Indicates the type prefers the "tycon" syntax for display etc. + member x.IsPrefixDisplay = (flags &&& 0b000000000000010L) <> 0x0L - /// Indicates the type prefers the "tycon" syntax for display etc. - member x.IsPrefixDisplay = (flags &&& 0b000000000000010L) <> 0x0L - // This bit is not pickled, only used while establishing a type constructor. It is needed because the type constructor // is known to satisfy the default constructor constraint even before any of its members have been established. - member x.PreEstablishedHasDefaultConstructor = (flags &&& 0b000000000000100L) <> 0x0L + member x.PreEstablishedHasDefaultConstructor = (flags &&& 0b000000000000100L) <> 0x0L // This bit represents an F# specific condition where a type has at least one constructor that may access // the 'this' pointer prior to successful initialization of the partial contents of the object. In this // case sub-classes must protect themselves against early access to their contents. - member x.HasSelfReferentialConstructor = (flags &&& 0b000000000001000L) <> 0x0L + member x.HasSelfReferentialConstructor = (flags &&& 0b000000000001000L) <> 0x0L /// This bit is reserved for us in the pickle format, see pickle.fs, it's being listed here to stop it ever being used for anything else - static member ReservedBitForPickleFormatTyconReprFlag = 0b000000000010000L + static member ReservedBitForPickleFormatTyconReprFlag = 0b000000000010000L /// This bit represents a F# record that is a value type, or a struct record. - member x.IsStructRecordOrUnionType = (flags &&& 0b000000000100000L) <> 0x0L + member x.IsStructRecordOrUnionType = (flags &&& 0b000000000100000L) <> 0x0L /// These two bits represents the on-demand analysis about whether the entity has the IsByRefLike attribute - member x.TryIsByRefLike = (flags &&& 0b000000011000000L) - |> function - | 0b000000011000000L -> ValueSome true - | 0b000000010000000L -> ValueSome false - | _ -> ValueNone + member x.TryIsByRefLike = + (flags &&& 0b000000011000000L) + |> function + | 0b000000011000000L -> ValueSome true + | 0b000000010000000L -> ValueSome false + | _ -> ValueNone /// Adjust the on-demand analysis about whether the entity has the IsByRefLike attribute - member x.WithIsByRefLike flag = - let flags = - (flags &&& ~~~0b000000011000000L) ||| - (match flag with - | true -> 0b000000011000000L - | false -> 0b000000010000000L) - EntityFlags flags + member x.WithIsByRefLike flag = + let flags = + (flags &&& ~~~0b000000011000000L) + ||| (match flag with + | true -> 0b000000011000000L + | false -> 0b000000010000000L) + + EntityFlags flags /// These two bits represents the on-demand analysis about whether the entity has the IsReadOnly attribute - member x.TryIsReadOnly = (flags &&& 0b000001100000000L) - |> function - | 0b000001100000000L -> ValueSome true - | 0b000001000000000L -> ValueSome false - | _ -> ValueNone + member x.TryIsReadOnly = + (flags &&& 0b000001100000000L) + |> function + | 0b000001100000000L -> ValueSome true + | 0b000001000000000L -> ValueSome false + | _ -> ValueNone /// Adjust the on-demand analysis about whether the entity has the IsReadOnly attribute - member x.WithIsReadOnly flag = - let flags = - (flags &&& ~~~0b000001100000000L) ||| - (match flag with - | true -> 0b000001100000000L - | false -> 0b000001000000000L) - EntityFlags flags + member x.WithIsReadOnly flag = + let flags = + (flags &&& ~~~0b000001100000000L) + ||| (match flag with + | true -> 0b000001100000000L + | false -> 0b000001000000000L) + + EntityFlags flags /// These two bits represents the on-demand analysis about whether the entity is assumed to be a readonly struct - member x.TryIsAssumedReadOnly = (flags &&& 0b000110000000000L) - |> function - | 0b000110000000000L -> ValueSome true - | 0b000100000000000L -> ValueSome false - | _ -> ValueNone + member x.TryIsAssumedReadOnly = + (flags &&& 0b000110000000000L) + |> function + | 0b000110000000000L -> ValueSome true + | 0b000100000000000L -> ValueSome false + | _ -> ValueNone /// Adjust the on-demand analysis about whether the entity is assumed to be a readonly struct - member x.WithIsAssumedReadOnly flag = - let flags = - (flags &&& ~~~0b000110000000000L) ||| - (match flag with - | true -> 0b000110000000000L - | false -> 0b000100000000000L) - EntityFlags flags - - /// Get the flags as included in the F# binary metadata - member x.PickledBits = (flags &&& ~~~0b000111111000100L) + member x.WithIsAssumedReadOnly flag = + let flags = + (flags &&& ~~~0b000110000000000L) + ||| (match flag with + | true -> 0b000110000000000L + | false -> 0b000100000000000L) + EntityFlags flags + /// Get the flags as included in the F# binary metadata + member x.PickledBits = (flags &&& ~~~0b000111111000100L) -exception UndefinedName of - depth: int * - error: (string -> string) * - id: Ident * - suggestions: Suggestions +exception UndefinedName of depth: int * error: (string -> string) * id: Ident * suggestions: Suggestions exception InternalUndefinedItemRef of (string * string * string -> int * string) * string * string * string -[] -type ModuleOrNamespaceKind = +[] +type ModuleOrNamespaceKind = - /// Indicates that a module is compiled to a class with the "Module" suffix added. - | FSharpModuleWithSuffix + /// Indicates that a module is compiled to a class with the "Module" suffix added. + | FSharpModuleWithSuffix - /// Indicates that a module is compiled to a class with the same name as the original module - | ModuleOrType + /// Indicates that a module is compiled to a class with the same name as the original module + | ModuleOrType - /// Indicates that a 'module' is really a namespace + /// Indicates that a 'module' is really a namespace | Namespace of /// Indicates that the sourcecode had a namespace. - /// If false, this namespace was implicitly constructed during type checking. + /// If false, this namespace was implicitly constructed during type checking. isExplicit: bool - + override this.Equals other = match other with | :? ModuleOrNamespaceKind as kind -> @@ -525,7 +575,7 @@ type ModuleOrNamespaceKind = | _ -> false | _ -> false - override this.GetHashCode () = + override this.GetHashCode() = match this with | FSharpModuleWithSuffix -> 0 | ModuleOrType -> 1 @@ -533,12 +583,13 @@ type ModuleOrNamespaceKind = /// A public path records where a construct lives within the global namespace /// of a CCU. -type PublicPath = - | PubPath of string[] - member x.EnclosingPath = - let (PubPath pp) = x +type PublicPath = + | PubPath of string[] + + member x.EnclosingPath = + let (PubPath pp) = x assert (pp.Length >= 1) - pp[0..pp.Length-2] + pp[0 .. pp.Length - 2] /// Represents the specified visibility of the accessibility -- used to ensure IL visibility [] @@ -558,21 +609,23 @@ type CompilationPath = member x.MangledPath = List.map fst x.AccessPath - member x.NestedPublicPath (id: Ident) = PubPath(Array.append (Array.ofList x.MangledPath) [| id.idText |]) + member x.NestedPublicPath(id: Ident) = + PubPath(Array.append (Array.ofList x.MangledPath) [| id.idText |]) - member x.ParentCompPath = + member x.ParentCompPath = let a, _ = List.frontAndBack x.AccessPath CompPath(x.ILScopeRef, x.SyntaxAccess, a) member x.NestedCompPath n moduleKind = - CompPath(x.ILScopeRef, x.SyntaxAccess, x.AccessPath@[(n, moduleKind)]) + CompPath(x.ILScopeRef, x.SyntaxAccess, x.AccessPath @ [ (n, moduleKind) ]) - member x.DemangledPath = - x.AccessPath |> List.map (fun (nm, k) -> CompilationPath.DemangleEntityName nm k) + member x.DemangledPath = + x.AccessPath + |> List.map (fun (nm, k) -> CompilationPath.DemangleEntityName nm k) /// String 'Module' off an F# module name, if FSharpModuleWithSuffix is used - static member DemangleEntityName nm k = - match k with + static member DemangleEntityName nm k = + match k with | FSharpModuleWithSuffix -> String.dropSuffix nm FSharpModuleSuffix | _ -> nm @@ -581,44 +634,44 @@ type CompilationPath = [] type EntityOptionalData = { - /// The name of the type, possibly with `n mangling - // MUTABILITY; used only when establishing tycons. - mutable entity_compiled_name: string option - - // MUTABILITY: the signature is adjusted when it is checked - /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is - /// the signature range for an item in an implementation - mutable entity_other_range: (range * bool) option - - // MUTABILITY; used only when establishing tycons. - mutable entity_kind: TyparKind - - /// The declared documentation for the type or module - // MUTABILITY: only for unpickle linkage - mutable entity_xmldoc: XmlDoc - - /// the signature xml doc for an item in an implementation file. - mutable entity_other_xmldoc : XmlDoc option - - /// The XML document signature for this entity - mutable entity_xmldocsig: string - - /// If non-None, indicates the type is an abbreviation for another type. - // - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_tycon_abbrev: TType option - - /// The declared accessibility of the representation, not taking signatures into account - mutable entity_tycon_repr_accessibility: Accessibility - - /// Indicates how visible is the entity is. - // MUTABILITY: only for unpickle linkage - mutable entity_accessibility: Accessibility - - /// Field used when the 'tycon' is really an exception definition - // - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_exn_info: ExceptionInfo + /// The name of the type, possibly with `n mangling + // MUTABILITY; used only when establishing tycons. + mutable entity_compiled_name: string option + + // MUTABILITY: the signature is adjusted when it is checked + /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is + /// the signature range for an item in an implementation + mutable entity_other_range: (range * bool) option + + // MUTABILITY; used only when establishing tycons. + mutable entity_kind: TyparKind + + /// The declared documentation for the type or module + // MUTABILITY: only for unpickle linkage + mutable entity_xmldoc: XmlDoc + + /// the signature xml doc for an item in an implementation file. + mutable entity_other_xmldoc: XmlDoc option + + /// The XML document signature for this entity + mutable entity_xmldocsig: string + + /// If non-None, indicates the type is an abbreviation for another type. + // + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_tycon_abbrev: TType option + + /// The declared accessibility of the representation, not taking signatures into account + mutable entity_tycon_repr_accessibility: Accessibility + + /// Indicates how visible is the entity is. + // MUTABILITY: only for unpickle linkage + mutable entity_accessibility: Accessibility + + /// Field used when the 'tycon' is really an exception definition + // + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_exn_info: ExceptionInfo } [] @@ -627,189 +680,216 @@ type EntityOptionalData = override x.ToString() = "EntityOptionalData(...)" /// Represents a type definition, exception definition, module definition or namespace definition. -[] -type Entity = +[] +type Entity = { - /// The declared type parameters of the type - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_typars: LazyWithContext - - mutable entity_flags: EntityFlags - - /// The unique stamp of the "tycon blob". Note the same tycon in signature and implementation get different stamps - // MUTABILITY: only for unpickle linkage - mutable entity_stamp: Stamp - - /// The name of the type, possibly with `n mangling - // MUTABILITY: only for unpickle linkage - mutable entity_logical_name: string - - /// The declaration location for the type constructor - mutable entity_range: range - - /// The declared attributes for the type - // MUTABILITY; used during creation and remapping of tycons - // MUTABILITY; used when propagating signature attributes into the implementation. - mutable entity_attribs: Attribs - - /// The declared representation of the type, i.e. record, union, class etc. - // - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_tycon_repr: TyconRepresentation - - /// The methods and properties of the type - // - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_tycon_tcaug: TyconAugmentation - - /// This field is used when the 'tycon' is really a module definition. It holds statically nested type definitions and nested modules - // - // MUTABILITY: only used during creation and remapping of tycons and - // when compiling fslib to fixup compiler forward references to internal items - mutable entity_modul_type: MaybeLazy - - /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 - // REVIEW: it looks like entity_cpath subsumes this - // MUTABILITY: only for unpickle linkage - mutable entity_pubpath: PublicPath option - - /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 - // MUTABILITY: only for unpickle linkage - mutable entity_cpath: CompilationPath option - - /// Used during codegen to hold the ILX representation indicating how to access the type - // MUTABILITY: only for unpickle linkage and caching - mutable entity_il_repr_cache: CompiledTypeRepr cache - - mutable entity_opt_data: EntityOptionalData option + /// The declared type parameters of the type + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_typars: LazyWithContext + + mutable entity_flags: EntityFlags + + /// The unique stamp of the "tycon blob". Note the same tycon in signature and implementation get different stamps + // MUTABILITY: only for unpickle linkage + mutable entity_stamp: Stamp + + /// The name of the type, possibly with `n mangling + // MUTABILITY: only for unpickle linkage + mutable entity_logical_name: string + + /// The declaration location for the type constructor + mutable entity_range: range + + /// The declared attributes for the type + // MUTABILITY; used during creation and remapping of tycons + // MUTABILITY; used when propagating signature attributes into the implementation. + mutable entity_attribs: Attribs + + /// The declared representation of the type, i.e. record, union, class etc. + // + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_tycon_repr: TyconRepresentation + + /// The methods and properties of the type + // + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_tycon_tcaug: TyconAugmentation + + /// This field is used when the 'tycon' is really a module definition. It holds statically nested type definitions and nested modules + // + // MUTABILITY: only used during creation and remapping of tycons and + // when compiling fslib to fixup compiler forward references to internal items + mutable entity_modul_type: MaybeLazy + + /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 + // REVIEW: it looks like entity_cpath subsumes this + // MUTABILITY: only for unpickle linkage + mutable entity_pubpath: PublicPath option + + /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 + // MUTABILITY: only for unpickle linkage + mutable entity_cpath: CompilationPath option + + /// Used during codegen to hold the ILX representation indicating how to access the type + // MUTABILITY: only for unpickle linkage and caching + mutable entity_il_repr_cache: CompiledTypeRepr cache + + mutable entity_opt_data: EntityOptionalData option } - static member NewEmptyEntityOptData() = - { entity_compiled_name = None - entity_other_range = None - entity_kind = TyparKind.Type - entity_xmldoc = XmlDoc.Empty - entity_other_xmldoc = None - entity_xmldocsig = "" - entity_tycon_abbrev = None - entity_tycon_repr_accessibility = TAccess [] - entity_accessibility = TAccess [] - entity_exn_info = TExnNone } - - /// The name of the namespace, module or type, possibly with mangling, e.g. List`1, List or FailureException + static member NewEmptyEntityOptData() = + { + entity_compiled_name = None + entity_other_range = None + entity_kind = TyparKind.Type + entity_xmldoc = XmlDoc.Empty + entity_other_xmldoc = None + entity_xmldocsig = "" + entity_tycon_abbrev = None + entity_tycon_repr_accessibility = TAccess [] + entity_accessibility = TAccess [] + entity_exn_info = TExnNone + } + + /// The name of the namespace, module or type, possibly with mangling, e.g. List`1, List or FailureException member x.LogicalName = x.entity_logical_name - /// The compiled name of the namespace, module or type, e.g. FSharpList`1, ListModule or FailureException - member x.CompiledName = - match x.entity_opt_data with + /// The compiled name of the namespace, module or type, e.g. FSharpList`1, ListModule or FailureException + member x.CompiledName = + match x.entity_opt_data with | Some { entity_compiled_name = Some s } -> s - | _ -> x.LogicalName + | _ -> x.LogicalName member x.EntityCompiledName = - match x.entity_opt_data with + match x.entity_opt_data with | Some optData -> optData.entity_compiled_name - | _ -> None + | _ -> None member x.SetCompiledName name = match x.entity_opt_data with | Some optData -> optData.entity_compiled_name <- name - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_compiled_name = name } + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_compiled_name = name + } /// The display name of the namespace, module or type, e.g. List instead of List`1, and no static parameters. /// For modules the Module suffix is removed if FSharpModuleWithSuffix is used. /// /// No backticks are added for entities with non-identifier names - member x.DisplayNameCore = x.GetDisplayName(coreName=true) + member x.DisplayNameCore = x.GetDisplayName(coreName = true) /// The display name of the namespace, module or type, e.g. List instead of List`1, and no static parameters /// For modules the Module suffix is removed if FSharpModuleWithSuffix is used. /// /// Backticks are added implicitly for entities with non-identifier names - member x.DisplayName = x.GetDisplayName(coreName=false) + member x.DisplayName = x.GetDisplayName(coreName = false) /// The display name of the namespace, module or type with <_, _, _> added for generic types, plus static parameters if any /// For modules the Module suffix is removed if FSharpModuleWithSuffix is used. /// /// Backticks are added implicitly for entities with non-identifier names member x.DisplayNameWithStaticParametersAndUnderscoreTypars = - x.GetDisplayName(coreName=false, withStaticParameters=true, withUnderscoreTypars=true) + x.GetDisplayName(coreName = false, withStaticParameters = true, withUnderscoreTypars = true) /// The display name of the namespace, module or type, e.g. List instead of List`1, including static parameters if any /// For modules the Module suffix is removed if FSharpModuleWithSuffix is used. /// /// Backticks are added implicitly for entities with non-identifier names member x.DisplayNameWithStaticParameters = - x.GetDisplayName(coreName=false, withStaticParameters=true, withUnderscoreTypars=false) + x.GetDisplayName(coreName = false, withStaticParameters = true, withUnderscoreTypars = false) #if !NO_TYPEPROVIDERS - member x.IsStaticInstantiationTycon = - x.IsProvidedErasedTycon && - let _nm, args = DemangleProvidedTypeName x.LogicalName - args.Length > 0 + member x.IsStaticInstantiationTycon = + x.IsProvidedErasedTycon + && let _nm, args = DemangleProvidedTypeName x.LogicalName in + args.Length > 0 #endif member x.GetDisplayName(coreName, ?withStaticParameters, ?withUnderscoreTypars) = let withStaticParameters = defaultArg withStaticParameters false let withUnderscoreTypars = defaultArg withUnderscoreTypars false let nm = x.LogicalName - if x.IsModuleOrNamespace then x.DemangledModuleOrNamespaceName + + if x.IsModuleOrNamespace then + x.DemangledModuleOrNamespaceName #if !NO_TYPEPROVIDERS - elif x.IsProvidedErasedTycon then + elif x.IsProvidedErasedTycon then let nm, args = DemangleProvidedTypeName nm - if withStaticParameters && args.Length > 0 then + + if withStaticParameters && args.Length > 0 then nm + "<" + String.concat "," (Array.map snd args) + ">" else nm #endif else ignore withStaticParameters - match x.TyparsNoRange with + + match x.TyparsNoRange with | [] -> nm - | tps -> + | tps -> let nm = DemangleGenericTypeName nm let isArray = nm.StartsWithOrdinal("[") && nm.EndsWithOrdinal("]") - let nm = if coreName || isArray then nm else ConvertLogicalNameToDisplayName nm + + let nm = + if coreName || isArray then + nm + else + ConvertLogicalNameToDisplayName nm + if withUnderscoreTypars then - let typarNames = tps |> List.map (fun _ -> "_") + let typarNames = tps |> List.map (fun _ -> "_") nm + "<" + String.concat "," typarNames + ">" else nm /// The code location where the module, namespace or type is defined. - member x.Range = -#if !NO_TYPEPROVIDERS + member x.Range = +#if !NO_TYPEPROVIDERS match x.TypeReprInfo with | TProvidedTypeRepr info -> match Construct.ComputeDefinitionLocationOfProvidedItem info.ProvidedType with | Some range -> range | None -> x.entity_range - | _ -> + | _ -> #endif x.entity_range /// The range in the implementation, adjusted for an item in a signature - member x.DefinitionRange = - match x.entity_opt_data with - | Some { entity_other_range = Some (r, true) } -> r + member x.DefinitionRange = + match x.entity_opt_data with + | Some { entity_other_range = Some(r, true) } -> r | _ -> x.Range - member x.SigRange = - match x.entity_opt_data with - | Some { entity_other_range = Some (r, false) } -> r + member x.SigRange = + match x.entity_opt_data with + | Some { entity_other_range = Some(r, false) } -> r | _ -> x.Range - member x.SetOtherRange m = - match x.entity_opt_data with + member x.SetOtherRange m = + match x.entity_opt_data with | Some optData -> optData.entity_other_range <- Some m - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_other_range = Some m } - + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_other_range = Some m + } + member x.SetOtherXmlDoc xmlDoc = match x.entity_opt_data with | Some optData -> optData.entity_other_xmldoc <- Some xmlDoc - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_other_xmldoc = Some xmlDoc } - - /// A unique stamp for this module, namespace or type definition within the context of this compilation. - /// Note that because of signatures, there are situations where in a single compilation the "same" + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_other_xmldoc = Some xmlDoc + } + + /// A unique stamp for this module, namespace or type definition within the context of this compilation. + /// Note that because of signatures, there are situations where in a single compilation the "same" /// module, namespace or type may have two distinct Entity objects that have distinct stamps. member x.Stamp = x.entity_stamp @@ -819,15 +899,18 @@ type Entity = /// The XML documentation of the entity, if any. If the entity is backed by provided metadata /// then this _does_ include this documentation. If the entity is backed by Abstract IL metadata - /// or comes from another F# assembly then it does not (because the documentation will get read from + /// or comes from another F# assembly then it does not (because the documentation will get read from /// an XML file). - member x.XmlDoc = + member x.XmlDoc = #if !NO_TYPEPROVIDERS match x.TypeReprInfo with | TProvidedTypeRepr info -> - let lines = info.ProvidedType.PUntaintNoFailure(fun st -> (st :> IProvidedCustomAttributeProvider).GetXmlDocAttributes(info.ProvidedType.TypeProvider.PUntaintNoFailure id)) - XmlDoc (lines, x.DefinitionRange) - | _ -> + let lines = + info.ProvidedType.PUntaintNoFailure(fun st -> + (st :> IProvidedCustomAttributeProvider).GetXmlDocAttributes(info.ProvidedType.TypeProvider.PUntaintNoFailure id)) + + XmlDoc(lines, x.DefinitionRange) + | _ -> #endif match x.entity_opt_data with | Some optData -> @@ -841,15 +924,20 @@ type Entity = /// The XML documentation sig-string of the entity, if any, to use to lookup an .xml doc file. This also acts /// as a cache for this sig-string computation. - member x.XmlDocSig - with get() = + member x.XmlDocSig + with get () = match x.entity_opt_data with | Some optData -> optData.entity_xmldocsig | _ -> "" and set v = match x.entity_opt_data with | Some optData -> optData.entity_xmldocsig <- v - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_xmldocsig = v } + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_xmldocsig = v + } /// The logical contents of the entity when it is a module or namespace fragment. member x.ModuleOrNamespaceType = x.entity_modul_type.Force() @@ -866,15 +954,20 @@ type Entity = member x.SetTypeOrMeasureKind kind = match x.entity_opt_data with | Some optData -> optData.entity_kind <- kind - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_kind = kind } + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_kind = kind + } /// The identifier at the point of declaration of the type definition. - member x.Id = ident(x.LogicalName, x.Range) + member x.Id = ident (x.LogicalName, x.Range) /// The information about the r.h.s. of a type definition, if any. For example, the r.h.s. of a union or record type. member x.TypeReprInfo = x.entity_tycon_repr - /// The information about the r.h.s. of an F# exception definition, if any. + /// The information about the r.h.s. of an F# exception definition, if any. member x.ExceptionInfo = match x.entity_opt_data with | Some optData -> optData.entity_exn_info @@ -883,17 +976,25 @@ type Entity = member x.SetExceptionInfo exn_info = match x.entity_opt_data with | Some optData -> optData.entity_exn_info <- exn_info - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_exn_info = exn_info } + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_exn_info = exn_info + } /// Indicates if the entity represents an F# exception declaration. - member x.IsFSharpException = match x.ExceptionInfo with TExnNone -> false | _ -> true + member x.IsFSharpException = + match x.ExceptionInfo with + | TExnNone -> false + | _ -> true /// Demangle the module name, if FSharpModuleWithSuffix is used - member x.DemangledModuleOrNamespaceName = - CompilationPath.DemangleEntityName x.LogicalName x.ModuleOrNamespaceType.ModuleOrNamespaceKind - + member x.DemangledModuleOrNamespaceName = + CompilationPath.DemangleEntityName x.LogicalName x.ModuleOrNamespaceType.ModuleOrNamespaceKind + /// Get the type parameters for an entity that is a type declaration, otherwise return the empty list. - /// + /// /// Lazy because it may read metadata, must provide a context "range" in case error occurs reading metadata. member x.Typars m = x.entity_typars.Force m @@ -901,15 +1002,20 @@ type Entity = member x.TyparsNoRange: Typars = x.Typars x.Range /// Get the type abbreviated by this type definition, if it is an F# type abbreviation definition - member x.TypeAbbrev = + member x.TypeAbbrev = match x.entity_opt_data with | Some optData -> optData.entity_tycon_abbrev | _ -> None - member x.SetTypeAbbrev tycon_abbrev = + member x.SetTypeAbbrev tycon_abbrev = match x.entity_opt_data with | Some optData -> optData.entity_tycon_abbrev <- tycon_abbrev - | _ -> x.entity_opt_data <- Some { Entity.NewEmptyEntityOptData() with entity_tycon_abbrev = tycon_abbrev } + | _ -> + x.entity_opt_data <- + Some + { Entity.NewEmptyEntityOptData() with + entity_tycon_abbrev = tycon_abbrev + } /// Indicates if this entity is an F# type abbreviation definition member x.IsTypeAbbrev = x.TypeAbbrev.IsSome @@ -932,75 +1038,88 @@ type Entity = | Some optData -> optData.entity_accessibility | _ -> TAccess [] - /// Indicates the type prefers the "tycon" syntax for display etc. + /// Indicates the type prefers the "tycon" syntax for display etc. member x.IsPrefixDisplay = x.entity_flags.IsPrefixDisplay /// Indicates the Entity is actually a module or namespace, not a type definition member x.IsModuleOrNamespace = x.entity_flags.IsModuleOrNamespace /// Indicates if the entity is a namespace - member x.IsNamespace = x.IsModuleOrNamespace && (match x.ModuleOrNamespaceType.ModuleOrNamespaceKind with Namespace _ -> true | _ -> false) - + member x.IsNamespace = + x.IsModuleOrNamespace + && (match x.ModuleOrNamespaceType.ModuleOrNamespaceKind with + | Namespace _ -> true + | _ -> false) + /// Indicates if the entity has an implicit namespace - member x.IsImplicitNamespace = (match x.ModuleOrNamespaceType.ModuleOrNamespaceKind with Namespace false -> true | _ -> false) + member x.IsImplicitNamespace = + (match x.ModuleOrNamespaceType.ModuleOrNamespaceKind with + | Namespace false -> true + | _ -> false) /// Indicates if the entity is an F# module definition - member x.IsModule = x.IsModuleOrNamespace && (match x.ModuleOrNamespaceType.ModuleOrNamespaceKind with Namespace _ -> false | _ -> true) + member x.IsModule = + x.IsModuleOrNamespace + && (match x.ModuleOrNamespaceType.ModuleOrNamespaceKind with + | Namespace _ -> false + | _ -> true) #if !NO_TYPEPROVIDERS /// Indicates if the entity is a provided type or namespace definition - member x.IsProvided = - match x.TypeReprInfo with + member x.IsProvided = + match x.TypeReprInfo with | TProvidedTypeRepr _ -> true | TProvidedNamespaceRepr _ -> true | _ -> false /// Indicates if the entity is a provided namespace fragment - member x.IsProvidedNamespace = - match x.TypeReprInfo with + member x.IsProvidedNamespace = + match x.TypeReprInfo with | TProvidedNamespaceRepr _ -> true | _ -> false /// Indicates if the entity is an erased provided type definition - member x.IsProvidedErasedTycon = - match x.TypeReprInfo with + member x.IsProvidedErasedTycon = + match x.TypeReprInfo with | TProvidedTypeRepr info -> info.IsErased | _ -> false /// Indicates if the entity is a generated provided type definition, i.e. not erased. - member x.IsProvidedGeneratedTycon = - match x.TypeReprInfo with + member x.IsProvidedGeneratedTycon = + match x.TypeReprInfo with | TProvidedTypeRepr info -> info.IsGenerated | _ -> false #endif /// Indicates if the entity is erased, either a measure definition, or an erased provided type definition - member x.IsErased = - x.IsMeasureableReprTycon + member x.IsErased = + x.IsMeasureableReprTycon #if !NO_TYPEPROVIDERS || x.IsProvidedErasedTycon #endif /// Get a blob of data indicating how this type is nested inside other namespaces, modules and types. - member x.CompilationPathOpt = x.entity_cpath + member x.CompilationPathOpt = x.entity_cpath /// Get a blob of data indicating how this type is nested inside other namespaces, modules and types. - member x.CompilationPath = - match x.CompilationPathOpt with - | Some cpath -> cpath - | None -> error(Error(FSComp.SR.tastTypeOrModuleNotConcrete(x.LogicalName), x.Range)) - + member x.CompilationPath = + match x.CompilationPathOpt with + | Some cpath -> cpath + | None -> error (Error(FSComp.SR.tastTypeOrModuleNotConcrete (x.LogicalName), x.Range)) + /// Get a table of fields for all the F#-defined record, struct and class fields in this type definition, including /// static fields, 'val' declarations and hidden fields from the compilation of implicit class constructions. - member x.AllFieldTable = - match x.TypeReprInfo with - | TFSharpTyconRepr {fsobjmodel_rfields=x} -> x - | _ -> - match x.ExceptionInfo with - | TExnFresh x -> x - | _ -> - { FieldsByIndex = [| |] - FieldsByName = NameMap.empty } + member x.AllFieldTable = + match x.TypeReprInfo with + | TFSharpTyconRepr { fsobjmodel_rfields = x } -> x + | _ -> + match x.ExceptionInfo with + | TExnFresh x -> x + | _ -> + { + FieldsByIndex = [||] + FieldsByName = NameMap.empty + } /// Get an array of fields for all the F#-defined record, struct and class fields in this type definition, including /// static fields, 'val' declarations and hidden fields from the compilation of implicit class constructions. @@ -1013,15 +1132,19 @@ type Entity = /// Get a list of all instance fields for F#-defined record, struct and class fields in this type definition. /// including hidden fields from the compilation of implicit class constructions. // NOTE: This method doesn't perform particularly well, and is over-used, but doesn't seem to appear on performance traces - member x.AllInstanceFieldsAsList = x.AllFieldsAsList |> List.filter (fun f -> not f.IsStatic) + member x.AllInstanceFieldsAsList = + x.AllFieldsAsList |> List.filter (fun f -> not f.IsStatic) /// Get a list of all fields for F#-defined record, struct and class fields in this type definition, /// including static fields, but excluding compiler-generate fields. - member x.TrueFieldsAsList = x.AllFieldsAsList |> List.filter (fun f -> not f.IsCompilerGenerated) + member x.TrueFieldsAsList = + x.AllFieldsAsList |> List.filter (fun f -> not f.IsCompilerGenerated) /// Get a list of all instance fields for F#-defined record, struct and class fields in this type definition, /// excluding compiler-generate fields. - member x.TrueInstanceFieldsAsList = x.AllFieldsAsList |> List.filter (fun f -> not f.IsStatic && not f.IsCompilerGenerated) + member x.TrueInstanceFieldsAsList = + x.AllFieldsAsList + |> List.filter (fun f -> not f.IsStatic && not f.IsCompilerGenerated) /// Get a field by index in definition order member x.GetFieldByIndex n = x.AllFieldTable.FieldByIndex n @@ -1031,130 +1154,149 @@ type Entity = /// Indicate if this is a type whose r.h.s. is known to be a union type definition. member x.IsUnionTycon = - match x.TypeReprInfo with - | TFSharpTyconRepr {fsobjmodel_kind=TFSharpUnion} -> true + match x.TypeReprInfo with + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } -> true | _ -> false /// Get the union cases and other union-type information for a type, if any - member x.UnionTypeInfo = - match x.TypeReprInfo with - | TFSharpTyconRepr {fsobjmodel_kind=TFSharpUnion; fsobjmodel_cases=x} -> ValueSome x + member x.UnionTypeInfo = + match x.TypeReprInfo with + | TFSharpTyconRepr { + fsobjmodel_kind = TFSharpUnion + fsobjmodel_cases = x + } -> ValueSome x | _ -> ValueNone /// Get the union cases for a type, if any - member x.UnionCasesArray = - match x.UnionTypeInfo with - | ValueSome x -> x.CasesTable.CasesByIndex - | ValueNone -> [| |] + member x.UnionCasesArray = + match x.UnionTypeInfo with + | ValueSome x -> x.CasesTable.CasesByIndex + | ValueNone -> [||] /// Get the union cases for a type, if any, as a list member x.UnionCasesAsList = x.UnionCasesArray |> Array.toList /// Get a union case of a type by name member x.GetUnionCaseByName n = - match x.UnionTypeInfo with + match x.UnionTypeInfo with | ValueSome x -> NameMap.tryFind n x.CasesTable.CasesByName | ValueNone -> None - /// Create a new entity with empty, unlinked data. Only used during unpickling of F# metadata. - static member NewUnlinked() : Entity = - { entity_typars = Unchecked.defaultof<_> - entity_flags = Unchecked.defaultof<_> - entity_stamp = Unchecked.defaultof<_> - entity_logical_name = Unchecked.defaultof<_> - entity_range = Unchecked.defaultof<_> - entity_attribs = Unchecked.defaultof<_> - entity_tycon_repr= Unchecked.defaultof<_> - entity_tycon_tcaug= Unchecked.defaultof<_> - entity_modul_type= Unchecked.defaultof<_> - entity_pubpath = Unchecked.defaultof<_> - entity_cpath = Unchecked.defaultof<_> - entity_il_repr_cache = Unchecked.defaultof<_> - entity_opt_data = Unchecked.defaultof<_>} + static member NewUnlinked() : Entity = + { + entity_typars = Unchecked.defaultof<_> + entity_flags = Unchecked.defaultof<_> + entity_stamp = Unchecked.defaultof<_> + entity_logical_name = Unchecked.defaultof<_> + entity_range = Unchecked.defaultof<_> + entity_attribs = Unchecked.defaultof<_> + entity_tycon_repr = Unchecked.defaultof<_> + entity_tycon_tcaug = Unchecked.defaultof<_> + entity_modul_type = Unchecked.defaultof<_> + entity_pubpath = Unchecked.defaultof<_> + entity_cpath = Unchecked.defaultof<_> + entity_il_repr_cache = Unchecked.defaultof<_> + entity_opt_data = Unchecked.defaultof<_> + } /// Create a new entity with the given backing data. Only used during unpickling of F# metadata. static member New _reason (data: Entity) : Entity = data /// Link an entity based on empty, unlinked data to the given data. Only used during unpickling of F# metadata. - member x.Link (tg: EntityData) = - x.entity_typars <- tg.entity_typars - x.entity_flags <- tg.entity_flags - x.entity_stamp <- tg.entity_stamp - x.entity_logical_name <- tg.entity_logical_name - x.entity_range <- tg.entity_range - x.entity_attribs <- tg.entity_attribs + member x.Link(tg: EntityData) = + x.entity_typars <- tg.entity_typars + x.entity_flags <- tg.entity_flags + x.entity_stamp <- tg.entity_stamp + x.entity_logical_name <- tg.entity_logical_name + x.entity_range <- tg.entity_range + x.entity_attribs <- tg.entity_attribs x.entity_tycon_repr <- tg.entity_tycon_repr x.entity_tycon_tcaug <- tg.entity_tycon_tcaug x.entity_modul_type <- tg.entity_modul_type - x.entity_pubpath <- tg.entity_pubpath - x.entity_cpath <- tg.entity_cpath - x.entity_il_repr_cache <- tg.entity_il_repr_cache + x.entity_pubpath <- tg.entity_pubpath + x.entity_cpath <- tg.entity_cpath + x.entity_il_repr_cache <- tg.entity_il_repr_cache + match tg.entity_opt_data with | Some tg -> - x.entity_opt_data <- - Some { entity_compiled_name = tg.entity_compiled_name - entity_other_range = tg.entity_other_range - entity_kind = tg.entity_kind - entity_xmldoc = tg.entity_xmldoc - entity_xmldocsig = tg.entity_xmldocsig - entity_other_xmldoc = tg.entity_other_xmldoc - entity_tycon_abbrev = tg.entity_tycon_abbrev - entity_tycon_repr_accessibility = tg.entity_tycon_repr_accessibility - entity_accessibility = tg.entity_accessibility - entity_exn_info = tg.entity_exn_info } + x.entity_opt_data <- + Some + { + entity_compiled_name = tg.entity_compiled_name + entity_other_range = tg.entity_other_range + entity_kind = tg.entity_kind + entity_xmldoc = tg.entity_xmldoc + entity_xmldocsig = tg.entity_xmldocsig + entity_other_xmldoc = tg.entity_other_xmldoc + entity_tycon_abbrev = tg.entity_tycon_abbrev + entity_tycon_repr_accessibility = tg.entity_tycon_repr_accessibility + entity_accessibility = tg.entity_accessibility + entity_exn_info = tg.entity_exn_info + } | None -> () - /// Indicates if the entity is linked to backing data. Only used during unpickling of F# metadata. - member x.IsLinked = match box x.entity_attribs with null -> false | _ -> true + member x.IsLinked = + match box x.entity_attribs with + | null -> false + | _ -> true /// Get the blob of information associated with an F# object-model type definition, i.e. class, interface, struct etc. - member x.FSharpTyconRepresentationData = - match x.TypeReprInfo with - | TFSharpTyconRepr x -> x - | _ -> failwith "not an F# object model type definition" + member x.FSharpTyconRepresentationData = + match x.TypeReprInfo with + | TFSharpTyconRepr x -> x + | _ -> failwith "not an F# object model type definition" /// Indicate if this is a type definition backed by Abstract IL metadata. - member x.IsILTycon = match x.TypeReprInfo with | TILObjectRepr _ -> true | _ -> false + member x.IsILTycon = + match x.TypeReprInfo with + | TILObjectRepr _ -> true + | _ -> false - /// Get the Abstract IL scope, nesting and metadata for this + /// Get the Abstract IL scope, nesting and metadata for this /// type definition, assuming it is backed by Abstract IL metadata. - member x.ILTyconInfo = match x.TypeReprInfo with | TILObjectRepr data -> data | _ -> failwith "not a .NET type definition" + member x.ILTyconInfo = + match x.TypeReprInfo with + | TILObjectRepr data -> data + | _ -> failwith "not a .NET type definition" /// Get the Abstract IL metadata for this type definition, assuming it is backed by Abstract IL metadata. member x.ILTyconRawMetadata = let (TILObjectReprData(_, _, td)) = x.ILTyconInfo in td /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition. member x.IsRecordTycon = - match x.TypeReprInfo with - | TFSharpTyconRepr {fsobjmodel_kind=TFSharpRecord} -> true + match x.TypeReprInfo with + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpRecord } -> true | _ -> false /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition that is a value type. member x.IsStructRecordOrUnionTycon = - match x.TypeReprInfo with - | TFSharpTyconRepr { fsobjmodel_kind=TFSharpRecord } -> x.entity_flags.IsStructRecordOrUnionType - | TFSharpTyconRepr { fsobjmodel_kind=TFSharpUnion } -> x.entity_flags.IsStructRecordOrUnionType + match x.TypeReprInfo with + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpRecord } -> x.entity_flags.IsStructRecordOrUnionType + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } -> x.entity_flags.IsStructRecordOrUnionType | _ -> false /// The on-demand analysis about whether the entity has the IsByRefLike attribute member x.TryIsByRefLike = x.entity_flags.TryIsByRefLike /// Set the on-demand analysis about whether the entity has the IsByRefLike attribute - member x.SetIsByRefLike b = x.entity_flags <- x.entity_flags.WithIsByRefLike b + member x.SetIsByRefLike b = + x.entity_flags <- x.entity_flags.WithIsByRefLike b /// These two bits represents the on-demand analysis about whether the entity has the IsReadOnly attribute member x.TryIsReadOnly = x.entity_flags.TryIsReadOnly /// Set the on-demand analysis about whether the entity has the IsReadOnly attribute - member x.SetIsReadOnly b = x.entity_flags <- x.entity_flags.WithIsReadOnly b + member x.SetIsReadOnly b = + x.entity_flags <- x.entity_flags.WithIsReadOnly b /// These two bits represents the on-demand analysis about whether the entity is assumed to be a readonly struct member x.TryIsAssumedReadOnly = x.entity_flags.TryIsAssumedReadOnly /// Set the on-demand analysis about whether the entity is assumed to be a readonly struct - member x.SetIsAssumedReadOnly b = x.entity_flags <- x.entity_flags.WithIsAssumedReadOnly b + member x.SetIsAssumedReadOnly b = + x.entity_flags <- x.entity_flags.WithIsAssumedReadOnly b /// Indicates if this is an F# type definition known to be an F# class, interface, struct, /// delegate or enum. This isn't generally a particularly useful thing to know, @@ -1172,38 +1314,63 @@ type Entity = | TFSharpEnum -> true | _ -> false - /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses + /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses /// an assembly-code representation for the type, e.g. the primitive array type constructor. - member x.IsAsmReprTycon = match x.TypeReprInfo with | TAsmRepr _ -> true | _ -> false + member x.IsAsmReprTycon = + match x.TypeReprInfo with + | TAsmRepr _ -> true + | _ -> false /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll like 'float<_>' which /// defines a measure type with a relation to an existing non-measure type as a representation. - member x.IsMeasureableReprTycon = match x.TypeReprInfo with | TMeasureableRepr _ -> true | _ -> false + member x.IsMeasureableReprTycon = + match x.TypeReprInfo with + | TMeasureableRepr _ -> true + | _ -> false /// Indicates if this is an F# type definition whose r.h.s. definition is unknown (i.e. a traditional ML 'abstract' type in a signature, /// which in F# is called a 'unknown representation' type). - member x.IsHiddenReprTycon = match x.TypeAbbrev, x.TypeReprInfo with | None, TNoRepr -> true | _ -> false - - /// Indicates if this is an F#-defined interface type definition - member x.IsFSharpInterfaceTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpInterface -> true | _ -> false - - /// Indicates if this is an F#-defined delegate type definition - member x.IsFSharpDelegateTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpDelegate _ -> true | _ -> false - - /// Indicates if this is an F#-defined enum type definition - member x.IsFSharpEnumTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpEnum -> true | _ -> false - - /// Indicates if this is an F#-defined class type definition - member x.IsFSharpClassTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpClass -> true | _ -> false + member x.IsHiddenReprTycon = + match x.TypeAbbrev, x.TypeReprInfo with + | None, TNoRepr -> true + | _ -> false - /// Indicates if this is a .NET-defined enum type definition + /// Indicates if this is an F#-defined interface type definition + member x.IsFSharpInterfaceTycon = + x.IsFSharpObjectModelTycon + && match x.FSharpTyconRepresentationData.fsobjmodel_kind with + | TFSharpInterface -> true + | _ -> false + + /// Indicates if this is an F#-defined delegate type definition + member x.IsFSharpDelegateTycon = + x.IsFSharpObjectModelTycon + && match x.FSharpTyconRepresentationData.fsobjmodel_kind with + | TFSharpDelegate _ -> true + | _ -> false + + /// Indicates if this is an F#-defined enum type definition + member x.IsFSharpEnumTycon = + x.IsFSharpObjectModelTycon + && match x.FSharpTyconRepresentationData.fsobjmodel_kind with + | TFSharpEnum -> true + | _ -> false + + /// Indicates if this is an F#-defined class type definition + member x.IsFSharpClassTycon = + x.IsFSharpObjectModelTycon + && match x.FSharpTyconRepresentationData.fsobjmodel_kind with + | TFSharpClass -> true + | _ -> false + + /// Indicates if this is a .NET-defined enum type definition member x.IsILEnumTycon = x.IsILTycon && x.ILTyconRawMetadata.IsEnum - /// Indicates if this is an enum type definition - member x.IsEnumTycon = + /// Indicates if this is an enum type definition + member x.IsEnumTycon = #if !NO_TYPEPROVIDERS - match x.TypeReprInfo with - | TProvidedTypeRepr info -> info.IsEnum + match x.TypeReprInfo with + | TProvidedTypeRepr info -> info.IsEnum | TProvidedNamespaceRepr _ -> false | _ -> #endif @@ -1214,29 +1381,30 @@ type Entity = match x.TypeReprInfo with | TFSharpTyconRepr info -> match info.fsobjmodel_kind with - | TFSharpRecord | TFSharpUnion -> x.IsStructRecordOrUnionTycon - | TFSharpClass | TFSharpInterface | TFSharpDelegate _ -> false - | TFSharpStruct | TFSharpEnum -> true + | TFSharpRecord + | TFSharpUnion -> x.IsStructRecordOrUnionTycon + | TFSharpClass + | TFSharpInterface + | TFSharpDelegate _ -> false + | TFSharpStruct + | TFSharpEnum -> true | _ -> false /// Indicates if this is a .NET-defined struct or enum type definition, i.e. a value type definition - member x.IsILStructOrEnumTycon = - x.IsILTycon && - x.ILTyconRawMetadata.IsStructOrEnum + member x.IsILStructOrEnumTycon = x.IsILTycon && x.ILTyconRawMetadata.IsStructOrEnum /// Indicates if this is a struct or enum type definition, i.e. a value type definition, including struct records and unions - member x.IsStructOrEnumTycon = + member x.IsStructOrEnumTycon = #if !NO_TYPEPROVIDERS - match x.TypeReprInfo with - | TProvidedTypeRepr info -> info.IsStructOrEnum + match x.TypeReprInfo with + | TProvidedTypeRepr info -> info.IsStructOrEnum | TProvidedNamespaceRepr _ -> false | _ -> #endif x.IsILStructOrEnumTycon || x.IsFSharpStructOrEnumTycon /// Gets the immediate interface definitions of an F# type definition. Further interfaces may be supported through class and interface inheritance. - member x.ImmediateInterfacesOfFSharpTycon = - x.TypeContents.tcaug_interfaces + member x.ImmediateInterfacesOfFSharpTycon = x.TypeContents.tcaug_interfaces /// Gets the immediate interface types of an F# type definition. Further interfaces may be supported through class and interface inheritance. member x.ImmediateInterfaceTypesOfFSharpTycon = @@ -1245,17 +1413,17 @@ type Entity = /// Gets the immediate members of an F# type definition, excluding compiler-generated ones. /// Note: result is alphabetically sorted, then for each name the results are in declaration order member x.MembersOfFSharpTyconSorted = - x.TypeContents.tcaug_adhoc - |> NameMultiMap.rangeReversingEachBucket + x.TypeContents.tcaug_adhoc + |> NameMultiMap.rangeReversingEachBucket |> List.filter (fun vref -> not vref.IsCompilerGenerated) /// Gets all immediate members of an F# type definition keyed by name, including compiler-generated ones. /// Note: result is a indexed table, and for each name the results are in reverse declaration order - member x.MembersOfFSharpTyconByName = - x.TypeContents.tcaug_adhoc + member x.MembersOfFSharpTyconByName = x.TypeContents.tcaug_adhoc /// Gets any implicit hash/equals (with comparer argument) methods added to an F# record, union or struct type definition. - member x.GeneratedHashAndEqualsWithComparerValues = x.TypeContents.tcaug_hash_and_equals_withc + member x.GeneratedHashAndEqualsWithComparerValues = + x.TypeContents.tcaug_hash_and_equals_withc /// Gets any implicit CompareTo (with comparer argument) methods added to an F# record, union or struct type definition. member x.GeneratedCompareToWithComparerValues = x.TypeContents.tcaug_compare_withc @@ -1267,95 +1435,116 @@ type Entity = member x.GeneratedHashAndEqualsValues = x.TypeContents.tcaug_equals /// Gets all implicit hash/equals/compare methods added to an F# record, union or struct type definition. - member x.AllGeneratedInterfaceImplsAndOverrides = - [ match x.GeneratedCompareToValues with - | None -> () - | Some (vref1, vref2) -> yield vref1; yield vref2 - match x.GeneratedCompareToWithComparerValues with - | None -> () - | Some v -> yield v - match x.GeneratedHashAndEqualsValues with - | None -> () - | Some (vref1, vref2) -> yield vref1; yield vref2 - match x.GeneratedHashAndEqualsWithComparerValues with - | None -> () - // vref4 is compiled as a sealed instance member, not an interface impl or an override. - | Some (vref1, vref2, vref3, _) -> yield vref1; yield vref2; yield vref3 ] - + member x.AllGeneratedInterfaceImplsAndOverrides = + [ + match x.GeneratedCompareToValues with + | None -> () + | Some(vref1, vref2) -> + yield vref1 + yield vref2 + match x.GeneratedCompareToWithComparerValues with + | None -> () + | Some v -> yield v + match x.GeneratedHashAndEqualsValues with + | None -> () + | Some(vref1, vref2) -> + yield vref1 + yield vref2 + match x.GeneratedHashAndEqualsWithComparerValues with + | None -> () + // vref4 is compiled as a sealed instance member, not an interface impl or an override. + | Some(vref1, vref2, vref3, _) -> + yield vref1 + yield vref2 + yield vref3 + ] /// Gets the data indicating the compiled representation of a type or module in terms of Abstract IL data structures. member x.CompiledRepresentation = #if !NO_TYPEPROVIDERS - match x.TypeReprInfo with + match x.TypeReprInfo with // We should never be computing this property for erased types - | TProvidedTypeRepr info when info.IsErased -> - failwith "No compiled representation for provided erased type" - + | TProvidedTypeRepr info when info.IsErased -> failwith "No compiled representation for provided erased type" + // Generated types that are not relocated just point straight to the generated backing assembly, computed from "st". // These are used when running F# Interactive, which does not use static linking of provider-generated assemblies, // and also for types with relocation suppressed. - | TProvidedTypeRepr info when info.IsGenerated && info.IsSuppressRelocate -> + | TProvidedTypeRepr info when info.IsGenerated && info.IsSuppressRelocate -> let st = info.ProvidedType - let tref = GetILTypeRefOfProvidedType (st, x.Range) + let tref = GetILTypeRefOfProvidedType(st, x.Range) let boxity = if x.IsStructOrEnumTycon then AsValue else AsObject CompiledTypeRepr.ILAsmNamed(tref, boxity, None) | TProvidedNamespaceRepr _ -> failwith "No compiled representation for provided namespace" | _ -> #endif - let ilTypeRefForCompilationPath (CompPath(sref, _, p)) item = - let rec top racc p = - match p with - | [] -> ILTypeRef.Create(sref, [], textOfPath (List.rev (item :: racc))) - | (h, isType) :: t -> - match isType with - | FSharpModuleWithSuffix | ModuleOrType -> - let outerTypeName = (textOfPath (List.rev (h :: racc))) - ILTypeRef.Create(sref, (outerTypeName :: List.map fst t), item) - | _ -> - top (h :: racc) t - top [] p - - - cached x.CompiledReprCache (fun () -> - match x.ExceptionInfo with - | TExnAbbrevRepr ecref2 -> ecref2.CompiledRepresentation - | TExnAsmRepr tref -> CompiledTypeRepr.ILAsmNamed(tref, AsObject, Some (mkILTy AsObject (mkILTySpec (tref, [])))) - | _ -> - match x.TypeReprInfo with + let ilTypeRefForCompilationPath (CompPath(sref, _, p)) item = + let rec top racc p = + match p with + | [] -> ILTypeRef.Create(sref, [], textOfPath (List.rev (item :: racc))) + | (h, isType) :: t -> + match isType with + | FSharpModuleWithSuffix + | ModuleOrType -> + let outerTypeName = (textOfPath (List.rev (h :: racc))) + ILTypeRef.Create(sref, (outerTypeName :: List.map fst t), item) + | _ -> top (h :: racc) t + + top [] p + + cached x.CompiledReprCache (fun () -> + match x.ExceptionInfo with + | TExnAbbrevRepr ecref2 -> ecref2.CompiledRepresentation + | TExnAsmRepr tref -> CompiledTypeRepr.ILAsmNamed(tref, AsObject, Some(mkILTy AsObject (mkILTySpec (tref, [])))) + | _ -> + match x.TypeReprInfo with | TAsmRepr ty -> CompiledTypeRepr.ILAsmOpen ty - | _ -> + | _ -> let boxity = if x.IsStructOrEnumTycon then AsValue else AsObject - let ilTypeRef = - match x.TypeReprInfo with - | TILObjectRepr (TILObjectReprData(ilScopeRef, ilEnclosingTypeDefs, ilTypeDef)) -> mkRefForNestedILTypeDef ilScopeRef (ilEnclosingTypeDefs, ilTypeDef) + + let ilTypeRef = + match x.TypeReprInfo with + | TILObjectRepr(TILObjectReprData(ilScopeRef, ilEnclosingTypeDefs, ilTypeDef)) -> + mkRefForNestedILTypeDef ilScopeRef (ilEnclosingTypeDefs, ilTypeDef) | _ -> ilTypeRefForCompilationPath x.CompilationPath x.CompiledName // Pre-allocate a ILType for monomorphic types, to reduce memory usage from Abstract IL nodes - let ilTypeOpt = - match x.TyparsNoRange with - | [] -> Some (mkILTy boxity (mkILTySpec (ilTypeRef, []))) + let ilTypeOpt = + match x.TyparsNoRange with + | [] -> Some(mkILTy boxity (mkILTySpec (ilTypeRef, []))) | _ -> None - CompiledTypeRepr.ILAsmNamed (ilTypeRef, boxity, ilTypeOpt)) + + CompiledTypeRepr.ILAsmNamed(ilTypeRef, boxity, ilTypeOpt)) /// Gets the data indicating the compiled representation of a named type or module in terms of Abstract IL data structures. member x.CompiledRepresentationForNamedType = - match x.CompiledRepresentation with + match x.CompiledRepresentation with | CompiledTypeRepr.ILAsmNamed(tref, _, _) -> tref - | CompiledTypeRepr.ILAsmOpen _ -> invalidOp (FSComp.SR.tastTypeHasAssemblyCodeRepresentation(x.DisplayNameWithStaticParametersAndUnderscoreTypars)) - + | CompiledTypeRepr.ILAsmOpen _ -> + invalidOp (FSComp.SR.tastTypeHasAssemblyCodeRepresentation (x.DisplayNameWithStaticParametersAndUnderscoreTypars)) /// Indicates if we have pre-determined that a type definition has a default constructor. - member x.PreEstablishedHasDefaultConstructor = x.entity_flags.PreEstablishedHasDefaultConstructor + member x.PreEstablishedHasDefaultConstructor = + x.entity_flags.PreEstablishedHasDefaultConstructor /// Indicates if we have pre-determined that a type definition has a self-referential constructor using 'as x' member x.HasSelfReferentialConstructor = x.entity_flags.HasSelfReferentialConstructor - + member x.HasSignatureFile = x.SigRange <> x.DefinitionRange /// Set the custom attributes on an F# type definition. member x.SetAttribs attribs = x.entity_attribs <- attribs /// Sets the structness of a record or union type definition - member x.SetIsStructRecordOrUnion b = let flags = x.entity_flags in x.entity_flags <- EntityFlags(flags.IsPrefixDisplay, flags.IsModuleOrNamespace, flags.PreEstablishedHasDefaultConstructor, flags.HasSelfReferentialConstructor, b) + member x.SetIsStructRecordOrUnion b = + let flags = x.entity_flags in + + x.entity_flags <- + EntityFlags( + flags.IsPrefixDisplay, + flags.IsModuleOrNamespace, + flags.PreEstablishedHasDefaultConstructor, + flags.HasSelfReferentialConstructor, + b + ) [] member x.DebugText = x.ToString() @@ -1365,28 +1554,25 @@ type Entity = type EntityData = Entity /// Represents the parent entity of a type definition, if any -type ParentRef = +type ParentRef = | Parent of parent: EntityRef | ParentNone - + /// Specifies the compiled representations of type and exception definitions. Basically -/// just an ILTypeRef. Computed and cached by later phases. Stored in -/// type and exception definitions. Not pickled. Store an optional ILType object for +/// just an ILTypeRef. Computed and cached by later phases. Stored in +/// type and exception definitions. Not pickled. Store an optional ILType object for /// non-generic types. [] -type CompiledTypeRepr = +type CompiledTypeRepr = /// An AbstractIL type representation that is just the name of a type. /// /// CompiledTypeRepr.ILAsmNamed (ilTypeRef, ilBoxity, ilTypeOpt) - /// + /// /// The ilTypeOpt is present for non-generic types. It is an ILType corresponding to the first two elements of the case. This /// prevents reallocation of the ILType each time we need to generate it. For generic types, it is None. - | ILAsmNamed of - ilTypeRef: ILTypeRef * - ilBoxity: ILBoxity * - ilTypeOpt: ILType option - + | ILAsmNamed of ilTypeRef: ILTypeRef * ilBoxity: ILBoxity * ilTypeOpt: ILType option + /// An AbstractIL type representation that may include type variables // This case is only used for types defined in the F# library by their translation to ILASM types, e.g. // type ``[]``<'T> = (# "!0[]" #) @@ -1395,7 +1581,7 @@ type CompiledTypeRepr = // type byref<'T> = (# "!0&" #) // type nativeptr<'T when 'T: unmanaged> = (# "native int" #) // type ilsigptr<'T> = (# "!0*" #) - | ILAsmOpen of ilType: ILType + | ILAsmOpen of ilType: ILType [] member x.DebugText = x.ToString() @@ -1403,51 +1589,51 @@ type CompiledTypeRepr = override x.ToString() = "CompiledTypeRepr(...)" [] -type TyconAugmentation = +type TyconAugmentation = { - /// This is the value implementing the auto-generated comparison - /// semantics if any. It is not present if the type defines its own implementation - /// of IComparable or if the type doesn't implement IComparable implicitly. - mutable tcaug_compare: (ValRef * ValRef) option - - /// This is the value implementing the auto-generated comparison - /// semantics if any. It is not present if the type defines its own implementation - /// of IStructuralComparable or if the type doesn't implement IComparable implicitly. - mutable tcaug_compare_withc: ValRef option - - /// This is the value implementing the auto-generated equality - /// semantics if any. It is not present if the type defines its own implementation - /// of Object.Equals or if the type doesn't override Object.Equals implicitly. - mutable tcaug_equals: (ValRef * ValRef) option - - /// This is the value implementing the auto-generated equality - /// semantics if any. It is not present if the type defines its own implementation - /// of IStructuralEquatable or if the type doesn't override Object.Equals implicitly. - mutable tcaug_hash_and_equals_withc: (ValRef * ValRef * ValRef * ValRef option) option - - /// True if the type defined an Object.GetHashCode method. In this - /// case we give a warning if we auto-generate a hash method since the semantics may not match up - mutable tcaug_hasObjectGetHashCode: bool - - /// Properties, methods etc. in declaration order. The boolean flag for each indicates if the - /// member is known to be an explicit interface implementation. This must be computed and - /// saved prior to remapping assembly information. - tcaug_adhoc_list: ResizeArray - - /// Properties, methods etc. as lookup table - mutable tcaug_adhoc: NameMultiMap - - /// Interface implementations - boolean indicates compiler-generated - mutable tcaug_interfaces: (TType * bool * range) list - - /// Super type, if any - mutable tcaug_super: TType option - - /// Set to true at the end of the scope where proper augmentations are allowed - mutable tcaug_closed: bool - - /// Set to true if the type is determined to be abstract - mutable tcaug_abstract: bool + /// This is the value implementing the auto-generated comparison + /// semantics if any. It is not present if the type defines its own implementation + /// of IComparable or if the type doesn't implement IComparable implicitly. + mutable tcaug_compare: (ValRef * ValRef) option + + /// This is the value implementing the auto-generated comparison + /// semantics if any. It is not present if the type defines its own implementation + /// of IStructuralComparable or if the type doesn't implement IComparable implicitly. + mutable tcaug_compare_withc: ValRef option + + /// This is the value implementing the auto-generated equality + /// semantics if any. It is not present if the type defines its own implementation + /// of Object.Equals or if the type doesn't override Object.Equals implicitly. + mutable tcaug_equals: (ValRef * ValRef) option + + /// This is the value implementing the auto-generated equality + /// semantics if any. It is not present if the type defines its own implementation + /// of IStructuralEquatable or if the type doesn't override Object.Equals implicitly. + mutable tcaug_hash_and_equals_withc: (ValRef * ValRef * ValRef * ValRef option) option + + /// True if the type defined an Object.GetHashCode method. In this + /// case we give a warning if we auto-generate a hash method since the semantics may not match up + mutable tcaug_hasObjectGetHashCode: bool + + /// Properties, methods etc. in declaration order. The boolean flag for each indicates if the + /// member is known to be an explicit interface implementation. This must be computed and + /// saved prior to remapping assembly information. + tcaug_adhoc_list: ResizeArray + + /// Properties, methods etc. as lookup table + mutable tcaug_adhoc: NameMultiMap + + /// Interface implementations - boolean indicates compiler-generated + mutable tcaug_interfaces: (TType * bool * range) list + + /// Super type, if any + mutable tcaug_super: TType option + + /// Set to true at the end of the scope where proper augmentations are allowed + mutable tcaug_closed: bool + + /// Set to true if the type is determined to be abstract + mutable tcaug_abstract: bool } member tcaug.SetCompare x = tcaug.tcaug_compare <- Some x @@ -1456,22 +1642,25 @@ type TyconAugmentation = member tcaug.SetEquals x = tcaug.tcaug_equals <- Some x - member tcaug.SetHashAndEqualsWith x = tcaug.tcaug_hash_and_equals_withc <- Some x + member tcaug.SetHashAndEqualsWith x = + tcaug.tcaug_hash_and_equals_withc <- Some x member tcaug.SetHasObjectGetHashCode b = tcaug.tcaug_hasObjectGetHashCode <- b static member Create() = - { tcaug_compare=None - tcaug_compare_withc=None - tcaug_equals=None - tcaug_hash_and_equals_withc=None - tcaug_hasObjectGetHashCode=false - tcaug_adhoc=NameMultiMap.empty - tcaug_adhoc_list=ResizeArray<_>() - tcaug_super=None - tcaug_interfaces=[] - tcaug_closed=false - tcaug_abstract=false } + { + tcaug_compare = None + tcaug_compare_withc = None + tcaug_equals = None + tcaug_hash_and_equals_withc = None + tcaug_hasObjectGetHashCode = false + tcaug_adhoc = NameMultiMap.empty + tcaug_adhoc_list = ResizeArray<_>() + tcaug_super = None + tcaug_interfaces = [] + tcaug_closed = false + tcaug_abstract = false + } [] member x.DebugText = x.ToString() @@ -1480,15 +1669,15 @@ type TyconAugmentation = /// The information for the contents of a type. Also used for a provided namespace. [] -type TyconRepresentation = +type TyconRepresentation = - /// Indicates the type is a class, struct, enum, delegate or interface + /// Indicates the type is a class, struct, enum, delegate or interface | TFSharpTyconRepr of FSharpTyconData /// Indicates the type is a type from a .NET assembly without F# metadata. | TILObjectRepr of TILObjectReprData - /// Indicates the type is implemented as IL assembly code using the given closed Abstract IL type + /// Indicates the type is implemented as IL assembly code using the given closed Abstract IL type | TAsmRepr of ILType /// Indicates the type is parameterized on a measure (e.g. float<_>) but erases to some other type (e.g. float) @@ -1497,21 +1686,21 @@ type TyconRepresentation = #if !NO_TYPEPROVIDERS /// TProvidedTypeRepr /// - /// Indicates the representation information for a provided type. + /// Indicates the representation information for a provided type. | TProvidedTypeRepr of TProvidedTypeInfo - /// Indicates the representation information for a provided namespace. + /// Indicates the representation information for a provided namespace. // // Note, the list could probably be a list of IProvidedNamespace rather than ITypeProvider | TProvidedNamespaceRepr of ResolutionEnvironment * Tainted list #endif - /// The 'NoRepr' value here has four meanings: + /// The 'NoRepr' value here has four meanings: /// (1) it indicates 'not yet known' during the first 2 phases of establishing type definitions /// (2) it indicates 'no representation', i.e. 'type X' in signatures /// (3) it is the setting used for exception definitions (!) /// (4) it is the setting used for modules and namespaces. - /// + /// /// It would be better to separate the "not yet known" and other cases out. /// The information for exception definitions should be folded into here. | TNoRepr @@ -1519,76 +1708,77 @@ type TyconRepresentation = //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x [] -type TILObjectReprData = - | TILObjectReprData of scope: ILScopeRef * nesting: ILTypeDef list * definition: ILTypeDef +type TILObjectReprData = + | TILObjectReprData of scope: ILScopeRef * nesting: ILTypeDef list * definition: ILTypeDef [] member x.DebugText = x.ToString() override x.ToString() = "TILObjectReprData(...)" - #if !NO_TYPEPROVIDERS /// The information kept about a provided type [] -type TProvidedTypeInfo = - { - /// The parameters given to the provider that provided to this type. - ResolutionEnvironment: TypeProviders.ResolutionEnvironment +type TProvidedTypeInfo = + { + /// The parameters given to the provider that provided to this type. + ResolutionEnvironment: TypeProviders.ResolutionEnvironment - /// The underlying System.Type (wrapped as a ProvidedType to make sure we don't call random things on - /// System.Type, and wrapped as Tainted to make sure we track which provider this came from, for reporting - /// error messages) - ProvidedType: Tainted + /// The underlying System.Type (wrapped as a ProvidedType to make sure we don't call random things on + /// System.Type, and wrapped as Tainted to make sure we track which provider this came from, for reporting + /// error messages) + ProvidedType: Tainted - /// The base type of the type. We use it to compute the compiled representation of the type for erased types. - /// Reading is delayed, since it does an import on the underlying type - LazyBaseType: LazyWithContext + /// The base type of the type. We use it to compute the compiled representation of the type for erased types. + /// Reading is delayed, since it does an import on the underlying type + LazyBaseType: LazyWithContext - /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. - IsClass: bool + /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. + IsClass: bool - /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. - IsSealed: bool + /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. + IsSealed: bool - /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. - IsAbstract: bool + /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. + IsAbstract: bool - /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. - IsInterface: bool + /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. + IsInterface: bool - /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. - IsStructOrEnum: bool + /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. + IsStructOrEnum: bool - /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. - IsEnum: bool + /// A flag read eagerly from the provided type and used to compute basic properties of the type definition. + IsEnum: bool - /// A type read from the provided type and used to compute basic properties of the type definition. - /// Reading is delayed, since it does an import on the underlying type - UnderlyingTypeOfEnum: unit -> TType + /// A type read from the provided type and used to compute basic properties of the type definition. + /// Reading is delayed, since it does an import on the underlying type + UnderlyingTypeOfEnum: unit -> TType - /// A flag read from the provided type and used to compute basic properties of the type definition. - /// Reading is delayed, since it looks at the .BaseType - IsDelegate: unit -> bool + /// A flag read from the provided type and used to compute basic properties of the type definition. + /// Reading is delayed, since it looks at the .BaseType + IsDelegate: unit -> bool - /// Indicates the type is erased - IsErased: bool + /// Indicates the type is erased + IsErased: bool - /// Indicates the type is generated, but type-relocation is suppressed - IsSuppressRelocate: bool + /// Indicates the type is generated, but type-relocation is suppressed + IsSuppressRelocate: bool } /// Indicates if the provided type is generated, i.e. not erased member info.IsGenerated = not info.IsErased /// Gets the base type of an erased provided type - member info.BaseTypeForErased (m, objTy) = - if info.IsErased then info.LazyBaseType.Force (m, objTy) - else failwith "expect erased type" + member info.BaseTypeForErased(m, objTy) = + if info.IsErased then + info.LazyBaseType.Force(m, objTy) + else + failwith "expect erased type" [] member x.DebugText = x.ToString() @@ -1597,7 +1787,7 @@ type TProvidedTypeInfo = #endif -type FSharpTyconKind = +type FSharpTyconKind = /// Indicates the type is an F#-declared record | TFSharpRecord @@ -1605,35 +1795,35 @@ type FSharpTyconKind = | TFSharpUnion /// Indicates the type is an F#-declared class (also used for units-of-measure) - | TFSharpClass + | TFSharpClass - /// Indicates the type is an F#-declared interface - | TFSharpInterface + /// Indicates the type is an F#-declared interface + | TFSharpInterface - /// Indicates the type is an F#-declared struct - | TFSharpStruct + /// Indicates the type is an F#-declared struct + | TFSharpStruct - /// Indicates the type is an F#-declared delegate with the given Invoke signature - | TFSharpDelegate of slotSig: SlotSig + /// Indicates the type is an F#-declared delegate with the given Invoke signature + | TFSharpDelegate of slotSig: SlotSig - /// Indicates the type is an F#-declared enumeration + /// Indicates the type is an F#-declared enumeration | TFSharpEnum - + /// Represents member values and class fields relating to the F# object model [] -type FSharpTyconData = - { - /// Indicates the cases of a union type - fsobjmodel_cases: TyconUnionData +type FSharpTyconData = + { + /// Indicates the cases of a union type + fsobjmodel_cases: TyconUnionData - /// Indicates whether the type declaration is an F# class, interface, enum, delegate or struct - fsobjmodel_kind: FSharpTyconKind + /// Indicates whether the type declaration is an F# class, interface, enum, delegate or struct + fsobjmodel_kind: FSharpTyconKind - /// The declared abstract slots of the class, interface or struct - fsobjmodel_vslots: ValRef list + /// The declared abstract slots of the class, interface or struct + fsobjmodel_vslots: ValRef list - /// The fields of the class, struct or enum - fsobjmodel_rfields: TyconRecdFields + /// The fields of the class, struct or enum + fsobjmodel_rfields: TyconRecdFields } [] @@ -1643,19 +1833,21 @@ type FSharpTyconData = /// Represents record fields in an F# type definition [] -type TyconRecdFields = - { - /// The fields of the record, in declaration order. - FieldsByIndex: RecdField[] - - /// The fields of the record, indexed by name. - FieldsByName: NameMap +type TyconRecdFields = + { + /// The fields of the record, in declaration order. + FieldsByIndex: RecdField[] + + /// The fields of the record, indexed by name. + FieldsByName: NameMap } /// Get a field by index - member x.FieldByIndex n = - if n >= 0 && n < x.FieldsByIndex.Length then x.FieldsByIndex[n] - else failwith "FieldByIndex" + member x.FieldByIndex n = + if n >= 0 && n < x.FieldsByIndex.Length then + x.FieldsByIndex[n] + else + failwith "FieldByIndex" /// Get a field by name member x.FieldByName nm = x.FieldsByName.TryFind nm @@ -1664,10 +1856,13 @@ type TyconRecdFields = member x.AllFieldsAsList = x.FieldsByIndex |> Array.toList /// Get all non-compiler-generated fields as a list - member x.TrueFieldsAsList = x.AllFieldsAsList |> List.filter (fun f -> not f.IsCompilerGenerated) + member x.TrueFieldsAsList = + x.AllFieldsAsList |> List.filter (fun f -> not f.IsCompilerGenerated) /// Get all non-compiler-generated instance fields as a list - member x.TrueInstanceFieldsAsList = x.AllFieldsAsList |> List.filter (fun f -> not f.IsStatic && not f.IsCompilerGenerated) + member x.TrueInstanceFieldsAsList = + x.AllFieldsAsList + |> List.filter (fun f -> not f.IsStatic && not f.IsCompilerGenerated) [] member x.DebugText = x.ToString() @@ -1676,19 +1871,21 @@ type TyconRecdFields = /// Represents union cases in an F# type definition [] -type TyconUnionCases = - { - /// The cases of the discriminated union, in declaration order. - CasesByIndex: UnionCase[] +type TyconUnionCases = + { + /// The cases of the discriminated union, in declaration order. + CasesByIndex: UnionCase[] - /// The cases of the discriminated union, indexed by name. - CasesByName: NameMap + /// The cases of the discriminated union, indexed by name. + CasesByName: NameMap } /// Get a union case by index - member x.GetUnionCaseByIndex n = - if n >= 0 && n < x.CasesByIndex.Length then x.CasesByIndex[n] - else invalidArg "n" "GetUnionCaseByIndex" + member x.GetUnionCaseByIndex n = + if n >= 0 && n < x.CasesByIndex.Length then + x.CasesByIndex[n] + else + invalidArg "n" "GetUnionCaseByIndex" /// Get the union cases as a list member x.UnionCasesAsList = x.CasesByIndex |> Array.toList @@ -1703,11 +1900,11 @@ type TyconUnionCases = type TyconUnionData = { - /// The cases contained in the discriminated union. - CasesTable: TyconUnionCases + /// The cases contained in the discriminated union. + CasesTable: TyconUnionCases - /// The ILX data structure representing the discriminated union. - CompiledRepresentation: IlxUnionRef cache + /// The ILX data structure representing the discriminated union. + CompiledRepresentation: IlxUnionRef cache } /// Get the union cases as a list @@ -1721,63 +1918,62 @@ type TyconUnionData = /// Represents a union case in an F# type definition [] type UnionCase = - { - /// Data carried by the case. - FieldTable: TyconRecdFields + { + /// Data carried by the case. + FieldTable: TyconRecdFields + + /// Return type constructed by the case. Normally exactly the type of the enclosing type, sometimes an abbreviation of it + ReturnType: TType - /// Return type constructed by the case. Normally exactly the type of the enclosing type, sometimes an abbreviation of it - ReturnType: TType + /// Documentation for the case + OwnXmlDoc: XmlDoc - /// Documentation for the case - OwnXmlDoc: XmlDoc - - /// Documentation for the case from signature file - mutable OtherXmlDoc: XmlDoc + /// Documentation for the case from signature file + mutable OtherXmlDoc: XmlDoc - /// XML documentation signature for the case - mutable XmlDocSig: string + /// XML documentation signature for the case + mutable XmlDocSig: string - /// Name/range of the case - Id: Ident + /// Name/range of the case + Id: Ident - /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is - /// the signature range for an item in an implementation - // MUTABILITY: used when propagating signature attributes into the implementation. - mutable OtherRangeOpt: (range * bool) option + /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is + /// the signature range for an item in an implementation + // MUTABILITY: used when propagating signature attributes into the implementation. + mutable OtherRangeOpt: (range * bool) option - /// Indicates the declared visibility of the union constructor, not taking signatures into account - Accessibility: Accessibility + /// Indicates the declared visibility of the union constructor, not taking signatures into account + Accessibility: Accessibility - /// Attributes, attached to the generated static method to make instances of the case - // MUTABILITY: used when propagating signature attributes into the implementation. - mutable Attribs: Attribs + /// Attributes, attached to the generated static method to make instances of the case + // MUTABILITY: used when propagating signature attributes into the implementation. + mutable Attribs: Attribs } - - /// Documentation for the case + + /// Documentation for the case member uc.XmlDoc: XmlDoc = if not uc.OwnXmlDoc.IsEmpty then uc.OwnXmlDoc else uc.OtherXmlDoc - + /// Get the declaration location of the union case member uc.Range = uc.Id.idRange /// Get the definition location of the union case - member uc.DefinitionRange = - match uc.OtherRangeOpt with - | Some (m, true) -> m - | _ -> uc.Range + member uc.DefinitionRange = + match uc.OtherRangeOpt with + | Some(m, true) -> m + | _ -> uc.Range /// Get the signature location of the union case - member uc.SigRange = - match uc.OtherRangeOpt with - | Some (m, false) -> m - | _ -> uc.Range + member uc.SigRange = + match uc.OtherRangeOpt with + | Some(m, false) -> m + | _ -> uc.Range + + member x.SetOtherXmlDoc xmlDoc = x.OtherXmlDoc <- xmlDoc - member x.SetOtherXmlDoc xmlDoc = - x.OtherXmlDoc <- xmlDoc - /// Get the logical name of the union case member uc.LogicalName = uc.Id.idText @@ -1800,12 +1996,13 @@ type UnionCase = /// This is because this is how ILX union code gen expects to see them. member uc.CompiledName = let idText = uc.Id.idText + if idText = opNameCons then "Cons" elif idText = opNameNil then "Empty" else idText /// Get the full array of fields of the union case - member uc.RecdFieldsArray = uc.FieldTable.FieldsByIndex + member uc.RecdFieldsArray = uc.FieldTable.FieldsByIndex /// Get the full list of fields of the union case member uc.RecdFields = uc.FieldTable.FieldsByIndex |> Array.toList @@ -1829,103 +2026,104 @@ type UnionCase = [] type RecdField = { - /// Is the field declared mutable in F#? - rfield_mutable: bool + /// Is the field declared mutable in F#? + rfield_mutable: bool + + /// Documentation for the field + rfield_xmldoc: XmlDoc - /// Documentation for the field - rfield_xmldoc: XmlDoc - - /// Documentation for the field from signature file - mutable rfield_otherxmldoc: XmlDoc + /// Documentation for the field from signature file + mutable rfield_otherxmldoc: XmlDoc - /// XML Documentation signature for the field - mutable rfield_xmldocsig: string + /// XML Documentation signature for the field + mutable rfield_xmldocsig: string - /// The type of the field, w.r.t. the generic parameters of the enclosing type constructor - rfield_type: TType + /// The type of the field, w.r.t. the generic parameters of the enclosing type constructor + rfield_type: TType - /// Indicates a static field - rfield_static: bool + /// Indicates a static field + rfield_static: bool - /// Indicates a volatile field - rfield_volatile: bool + /// Indicates a volatile field + rfield_volatile: bool - /// Indicates a compiler generated field, not visible to Intellisense or name resolution - rfield_secret: bool + /// Indicates a compiler generated field, not visible to Intellisense or name resolution + rfield_secret: bool - /// The default initialization info, for static literals - rfield_const: Const option + /// The default initialization info, for static literals + rfield_const: Const option - /// Indicates the declared visibility of the field, not taking signatures into account - rfield_access: Accessibility + /// Indicates the declared visibility of the field, not taking signatures into account + rfield_access: Accessibility - /// Attributes attached to generated property - // MUTABILITY: used when propagating signature attributes into the implementation. - mutable rfield_pattribs: Attribs + /// Attributes attached to generated property + // MUTABILITY: used when propagating signature attributes into the implementation. + mutable rfield_pattribs: Attribs - /// Attributes attached to generated field - // MUTABILITY: used when propagating signature attributes into the implementation. - mutable rfield_fattribs: Attribs + /// Attributes attached to generated field + // MUTABILITY: used when propagating signature attributes into the implementation. + mutable rfield_fattribs: Attribs - /// Name/declaration-location of the field - rfield_id: Ident + /// Name/declaration-location of the field + rfield_id: Ident - rfield_name_generated: bool + rfield_name_generated: bool - /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is - /// the signature range for an item in an implementation - // MUTABILITY: used when propagating signature attributes into the implementation. - mutable rfield_other_range: (range * bool) option } + /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is + /// the signature range for an item in an implementation + // MUTABILITY: used when propagating signature attributes into the implementation. + mutable rfield_other_range: (range * bool) option + } - /// Indicates the declared visibility of the field, not taking signatures into account + /// Indicates the declared visibility of the field, not taking signatures into account member v.Accessibility = v.rfield_access - /// Attributes attached to generated property + /// Attributes attached to generated property member v.PropertyAttribs = v.rfield_pattribs - /// Attributes attached to generated field + /// Attributes attached to generated field member v.FieldAttribs = v.rfield_fattribs - /// Get the declaration location of the field + /// Get the declaration location of the field member v.Range = v.rfield_id.idRange - /// Get the definition location of the field - member v.DefinitionRange = - match v.rfield_other_range with - | Some (m, true) -> m - | _ -> v.Range + /// Get the definition location of the field + member v.DefinitionRange = + match v.rfield_other_range with + | Some(m, true) -> m + | _ -> v.Range - /// Get the signature location of the field - member v.SigRange = - match v.rfield_other_range with - | Some (m, false) -> m - | _ -> v.Range + /// Get the signature location of the field + member v.SigRange = + match v.rfield_other_range with + | Some(m, false) -> m + | _ -> v.Range - /// Name/declaration-location of the field + /// Name/declaration-location of the field member v.Id = v.rfield_id - /// Name of the field + /// Name of the field member v.LogicalName = v.rfield_id.idText /// Name of the field. For fields this is the same as the logical name. member v.DisplayNameCore = v.LogicalName - /// Name of the field + /// Name of the field member v.DisplayName = v.DisplayNameCore |> ConvertLogicalNameToDisplayName - /// Indicates a compiler generated field, not visible to Intellisense or name resolution + /// Indicates a compiler generated field, not visible to Intellisense or name resolution member v.IsCompilerGenerated = v.rfield_secret - /// Is the field declared mutable in F#? + /// Is the field declared mutable in F#? member v.IsMutable = v.rfield_mutable - /// Indicates a static field + /// Indicates a static field member v.IsStatic = v.rfield_static - /// Indicates a volatile field + /// Indicates a volatile field member v.IsVolatile = v.rfield_volatile - /// The type of the field, w.r.t. the generic parameters of the enclosing type constructor + /// The type of the field, w.r.t. the generic parameters of the enclosing type constructor member v.FormalType = v.rfield_type /// XML Documentation signature for the field @@ -1934,27 +2132,26 @@ type RecdField = v.rfield_xmldoc else v.rfield_otherxmldoc - - member v.SetOtherXmlDoc (xmlDoc: XmlDoc) = - v.rfield_otherxmldoc <- xmlDoc + + member v.SetOtherXmlDoc(xmlDoc: XmlDoc) = v.rfield_otherxmldoc <- xmlDoc /// Get or set the XML documentation signature for the field member v.XmlDocSig - with get() = v.rfield_xmldocsig + with get () = v.rfield_xmldocsig and set x = v.rfield_xmldocsig <- x - /// The default initialization info, for static literals - member v.LiteralValue = - match v.rfield_const with + /// The default initialization info, for static literals + member v.LiteralValue = + match v.rfield_const with | None -> None | Some Const.Zero -> None | Some k -> Some k /// Indicates if the field is zero-initialized - member v.IsZeroInit = - match v.rfield_const with - | None -> false - | Some Const.Zero -> true + member v.IsZeroInit = + match v.rfield_const with + | None -> false + | Some Const.Zero -> true | _ -> false [] @@ -1966,31 +2163,31 @@ type RecdField = [] type ExceptionInfo = - /// Indicates that an exception is an abbreviation for the given exception - | TExnAbbrevRepr of TyconRef + /// Indicates that an exception is an abbreviation for the given exception + | TExnAbbrevRepr of TyconRef - /// Indicates that an exception is shorthand for the given .NET exception type + /// Indicates that an exception is shorthand for the given .NET exception type | TExnAsmRepr of ILTypeRef - /// Indicates that an exception carries the given record of values + /// Indicates that an exception carries the given record of values | TExnFresh of TyconRecdFields - /// Indicates that an exception is abstract, i.e. is in a signature file, and we do not know the representation + /// Indicates that an exception is abstract, i.e. is in a signature file, and we do not know the representation | TExnNone // %+A formatting is used, so this is not needed //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x /// Represents the contents of a module or namespace [] -type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, entities: QueueList) = +type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, entities: QueueList) = /// Mutation used during compilation of FSharp.Core.dll - let mutable entities = entities - + let mutable entities = entities + // Lookup tables keyed the way various clients expect them to be keyed. // We attach them here so we don't need to store lookup tables via any other technique. // @@ -2004,7 +2201,8 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en let mutable exconsByDemangledNameCache: NameMap option = None - let mutable tyconsByDemangledNameAndArityCache: LayeredMap option = None + let mutable tyconsByDemangledNameAndArityCache: LayeredMap option = + None let mutable tyconsByAccessNamesCache: LayeredMultiMap option = None @@ -2012,18 +2210,19 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en let mutable allEntitiesByMangledNameCache: NameMap option = None - let mutable allValsAndMembersByPartialLinkageKeyCache: MultiMap option = None + let mutable allValsAndMembersByPartialLinkageKeyCache: MultiMap option = + None let mutable allValsByLogicalNameCache: NameMap option = None - - /// Namespace or module-compiled-as-type? - member _.ModuleOrNamespaceKind = kind - - /// Values, including members in F# types in this module-or-namespace-fragment. + + /// Namespace or module-compiled-as-type? + member _.ModuleOrNamespaceKind = kind + + /// Values, including members in F# types in this module-or-namespace-fragment. member _.AllValsAndMembers = vals - /// Type, mapping mangled name to Tycon, e.g. - //// "Dictionary`2" --> Tycon + /// Type, mapping mangled name to Tycon, e.g. + //// "Dictionary`2" --> Tycon //// "ListModule" --> Tycon with module info //// "FooException" --> Tycon with exception info member _.AllEntities = entities @@ -2031,134 +2230,147 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en /// Mutation used during compilation of FSharp.Core.dll member _.AddModuleOrNamespaceByMutation(modul: ModuleOrNamespace) = entities <- QueueList.appendOne entities modul - modulesByDemangledNameCache <- None - allEntitiesByMangledNameCache <- None + modulesByDemangledNameCache <- None + allEntitiesByMangledNameCache <- None #if !NO_TYPEPROVIDERS /// Mutation used in hosting scenarios to hold the hosted types in this module or namespace - member mtyp.AddProvidedTypeEntity(entity: Entity) = + member mtyp.AddProvidedTypeEntity(entity: Entity) = entities <- QueueList.appendOne entities entity - tyconsByMangledNameCache <- None + tyconsByMangledNameCache <- None tyconsByDemangledNameAndArityCache <- None tyconsByAccessNamesCache <- None - allEntitiesByMangledNameCache <- None -#endif - + allEntitiesByMangledNameCache <- None +#endif + /// Return a new module or namespace type with an entity added. - member _.AddEntity(tycon: Tycon) = + member _.AddEntity(tycon: Tycon) = ModuleOrNamespaceType(kind, vals, entities.AppendOne tycon) - + /// Return a new module or namespace type with a value added. - member _.AddVal(vspec: Val) = + member _.AddVal(vspec: Val) = ModuleOrNamespaceType(kind, vals.AppendOne vspec, entities) - + /// Get a table of the active patterns defined in this module. member _.ActivePatternElemRefLookupTable = activePatternElemRefCache - - /// Get a list of types defined within this module, namespace or type. - member _.TypeDefinitions = entities |> Seq.filter (fun x -> not x.IsFSharpException && not x.IsModuleOrNamespace) |> Seq.toList - /// Get a list of F# exception definitions defined within this module, namespace or type. - member _.ExceptionDefinitions = entities |> Seq.filter (fun x -> x.IsFSharpException) |> Seq.toList + /// Get a list of types defined within this module, namespace or type. + member _.TypeDefinitions = + entities + |> Seq.filter (fun x -> not x.IsFSharpException && not x.IsModuleOrNamespace) + |> Seq.toList - /// Get a list of module and namespace definitions defined within this module, namespace or type. - member _.ModuleAndNamespaceDefinitions = entities |> Seq.filter (fun x -> x.IsModuleOrNamespace) |> Seq.toList + /// Get a list of F# exception definitions defined within this module, namespace or type. + member _.ExceptionDefinitions = + entities |> Seq.filter (fun x -> x.IsFSharpException) |> Seq.toList - /// Get a list of type and exception definitions defined within this module, namespace or type. - member _.TypeAndExceptionDefinitions = entities |> Seq.filter (fun x -> not x.IsModuleOrNamespace) |> Seq.toList + /// Get a list of module and namespace definitions defined within this module, namespace or type. + member _.ModuleAndNamespaceDefinitions = + entities |> Seq.filter (fun x -> x.IsModuleOrNamespace) |> Seq.toList - /// Get a table of types defined within this module, namespace or type. The - /// table is indexed by both name and generic arity. This means that for generic - /// types "List`1", the entry (List, 1) will be present. - member mtyp.TypesByDemangledNameAndArity = - cacheOptByref &tyconsByDemangledNameAndArityCache (fun () -> - LayeredMap.Empty.AddMany( mtyp.TypeAndExceptionDefinitions |> List.map (fun (tc: Tycon) -> Construct.KeyTyconByDecodedName tc.LogicalName tc) |> List.toArray)) + /// Get a list of type and exception definitions defined within this module, namespace or type. + member _.TypeAndExceptionDefinitions = + entities |> Seq.filter (fun x -> not x.IsModuleOrNamespace) |> Seq.toList - /// Get a table of types defined within this module, namespace or type. The + /// Get a table of types defined within this module, namespace or type. The + /// table is indexed by both name and generic arity. This means that for generic + /// types "List`1", the entry (List, 1) will be present. + member mtyp.TypesByDemangledNameAndArity = + cacheOptByref &tyconsByDemangledNameAndArityCache (fun () -> + LayeredMap.Empty.AddMany( + mtyp.TypeAndExceptionDefinitions + |> List.map (fun (tc: Tycon) -> Construct.KeyTyconByDecodedName tc.LogicalName tc) + |> List.toArray + )) + + /// Get a table of types defined within this module, namespace or type. The /// table is indexed by both name and, for generic types, also by mangled name. - member mtyp.TypesByAccessNames = - cacheOptByref &tyconsByAccessNamesCache (fun () -> - LayeredMultiMap.Empty.AddMany (mtyp.TypeAndExceptionDefinitions |> List.toArray |> Array.collect (fun (tc: Tycon) -> Construct.KeyTyconByAccessNames tc.LogicalName tc))) + member mtyp.TypesByAccessNames = + cacheOptByref &tyconsByAccessNamesCache (fun () -> + LayeredMultiMap.Empty.AddMany( + mtyp.TypeAndExceptionDefinitions + |> List.toArray + |> Array.collect (fun (tc: Tycon) -> Construct.KeyTyconByAccessNames tc.LogicalName tc) + )) // REVIEW: we can remove this lookup and use AllEntitiesByMangledName instead? - member mtyp.TypesByMangledName = - let addTyconByMangledName (x: Tycon) tab = NameMap.add x.LogicalName x tab - cacheOptByref &tyconsByMangledNameCache (fun () -> - List.foldBack addTyconByMangledName mtyp.TypeAndExceptionDefinitions Map.empty) + member mtyp.TypesByMangledName = + let addTyconByMangledName (x: Tycon) tab = NameMap.add x.LogicalName x tab + cacheOptByref &tyconsByMangledNameCache (fun () -> List.foldBack addTyconByMangledName mtyp.TypeAndExceptionDefinitions Map.empty) /// Get a table of entities indexed by both logical and compiled names - member _.AllEntitiesByCompiledAndLogicalMangledNames: NameMap = - let addEntityByMangledName (x: Entity) tab = + member _.AllEntitiesByCompiledAndLogicalMangledNames: NameMap = + let addEntityByMangledName (x: Entity) tab = let name1 = x.LogicalName let name2 = x.CompiledName - let tab = NameMap.add name1 x tab - if name1 = name2 then tab - else NameMap.add name2 x tab - - cacheOptByref &allEntitiesByMangledNameCache (fun () -> - QueueList.foldBack addEntityByMangledName entities Map.empty) + let tab = NameMap.add name1 x tab + if name1 = name2 then tab else NameMap.add name2 x tab + + cacheOptByref &allEntitiesByMangledNameCache (fun () -> QueueList.foldBack addEntityByMangledName entities Map.empty) /// Get a table of entities indexed by both logical name - member _.AllEntitiesByLogicalMangledName: NameMap = - let addEntityByMangledName (x: Entity) tab = NameMap.add x.LogicalName x tab + member _.AllEntitiesByLogicalMangledName: NameMap = + let addEntityByMangledName (x: Entity) tab = NameMap.add x.LogicalName x tab QueueList.foldBack addEntityByMangledName entities Map.empty /// Get a table of values and members indexed by partial linkage key, which includes name, the mangled name of the parent type (if any), /// and the method argument count (if any). - member _.AllValsAndMembersByPartialLinkageKey = - let addValByMangledName (x: Val) tab = - if x.IsCompiledAsTopLevel then - let key = x.GetLinkagePartialKey() - MultiMap.add key x tab - else - tab - cacheOptByref &allValsAndMembersByPartialLinkageKeyCache (fun () -> - QueueList.foldBack addValByMangledName vals MultiMap.empty) + member _.AllValsAndMembersByPartialLinkageKey = + let addValByMangledName (x: Val) tab = + if x.IsCompiledAsTopLevel then + let key = x.GetLinkagePartialKey() + MultiMap.add key x tab + else + tab + + cacheOptByref &allValsAndMembersByPartialLinkageKeyCache (fun () -> QueueList.foldBack addValByMangledName vals MultiMap.empty) /// Try to find the member with the given linkage key in the given module. - member mtyp.TryLinkVal(ccu: CcuThunk, key: ValLinkageFullKey) = + member mtyp.TryLinkVal(ccu: CcuThunk, key: ValLinkageFullKey) = mtyp.AllValsAndMembersByPartialLinkageKey - |> MultiMap.find key.PartialKey - |> List.tryFind (fun v -> match key.TypeForLinkage with - | None -> true - | Some keyTy -> ccu.MemberSignatureEquality(keyTy, v.Type)) - |> ValueOption.ofOption + |> MultiMap.find key.PartialKey + |> List.tryFind (fun v -> + match key.TypeForLinkage with + | None -> true + | Some keyTy -> ccu.MemberSignatureEquality(keyTy, v.Type)) + |> ValueOption.ofOption /// Get a table of values indexed by logical name - member _.AllValsByLogicalName = - let addValByName (x: Val) tab = - // Note: names may occur twice prior to raising errors about this in PostTypeCheckSemanticChecks - // Earlier ones take precedence since we report errors about the later ones - if not x.IsMember && not x.IsCompilerGenerated then - NameMap.add x.LogicalName x tab - else - tab - cacheOptByref &allValsByLogicalNameCache (fun () -> - QueueList.foldBack addValByName vals Map.empty) + member _.AllValsByLogicalName = + let addValByName (x: Val) tab = + // Note: names may occur twice prior to raising errors about this in PostTypeCheckSemanticChecks + // Earlier ones take precedence since we report errors about the later ones + if not x.IsMember && not x.IsCompilerGenerated then + NameMap.add x.LogicalName x tab + else + tab + + cacheOptByref &allValsByLogicalNameCache (fun () -> QueueList.foldBack addValByName vals Map.empty) /// Compute a table of values and members indexed by logical name. - member _.AllValsAndMembersByLogicalNameUncached = - let addValByName (x: Val) tab = - if not x.IsCompilerGenerated then - MultiMap.add x.LogicalName x tab + member _.AllValsAndMembersByLogicalNameUncached = + let addValByName (x: Val) tab = + if not x.IsCompilerGenerated then + MultiMap.add x.LogicalName x tab else tab + QueueList.foldBack addValByName vals MultiMap.empty /// Get a table of F# exception definitions indexed by demangled name, so 'FailureException' is indexed by 'Failure' - member mtyp.ExceptionDefinitionsByDemangledName = + member mtyp.ExceptionDefinitionsByDemangledName = let add (tycon: Tycon) acc = NameMap.add tycon.LogicalName tycon acc - cacheOptByref &exconsByDemangledNameCache (fun () -> - List.foldBack add mtyp.ExceptionDefinitions Map.empty) + cacheOptByref &exconsByDemangledNameCache (fun () -> List.foldBack add mtyp.ExceptionDefinitions Map.empty) /// Get a table of nested module and namespace fragments indexed by demangled name (so 'ListModule' becomes 'List') - member _.ModulesAndNamespacesByDemangledName = - let add (entity: Entity) acc = - if entity.IsModuleOrNamespace then + member _.ModulesAndNamespacesByDemangledName = + let add (entity: Entity) acc = + if entity.IsModuleOrNamespace then NameMap.add entity.DemangledModuleOrNamespaceName entity acc - else acc - cacheOptByref &modulesByDemangledNameCache (fun () -> - QueueList.foldBack add entities Map.empty) + else + acc + + cacheOptByref &modulesByDemangledNameCache (fun () -> QueueList.foldBack add entities Map.empty) [] member mtyp.DebugText = mtyp.ToString() @@ -2166,13 +2378,13 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en override _.ToString() = "ModuleOrNamespaceType(...)" /// Represents a module or namespace definition in the typed AST -type ModuleOrNamespace = Entity +type ModuleOrNamespace = Entity /// Represents a type or exception definition in the typed AST type Tycon = Entity -let getNameOfScopeRef sref = - match sref with +let getNameOfScopeRef sref = + match sref with | ILScopeRef.Local -> "" | ILScopeRef.Module mref -> mref.Name | ILScopeRef.Assembly aref -> aref.Name @@ -2186,32 +2398,44 @@ let private isInternalCompPath x = let private (|Public|Internal|Private|) (TAccess p) = match p with | [] -> Public - | _ when List.forall isInternalCompPath p -> Internal + | _ when List.forall isInternalCompPath p -> Internal | _ -> Private -let getSyntaxAccessForCompPath (TAccess a) = match a with | CompPath(_, sa, _) :: _ -> sa | _ -> TypedTree.SyntaxAccess.Unknown +let getSyntaxAccessForCompPath (TAccess a) = + match a with + | CompPath(_, sa, _) :: _ -> sa + | _ -> TypedTree.SyntaxAccess.Unknown let updateSyntaxAccessForCompPath access syntaxAccess = match access with - | CompPath(sc, sa, p) :: rest when sa <> syntaxAccess -> ([CompPath(sc, syntaxAccess, p)]@rest) + | CompPath(sc, sa, p) :: rest when sa <> syntaxAccess -> ([ CompPath(sc, syntaxAccess, p) ] @ rest) | _ -> access /// Represents the constraint on access for a construct [] type Accessibility = - /// Indicates the construct can only be accessed from any code in the given type constructor, module or assembly. [] indicates global scope. + /// Indicates the construct can only be accessed from any code in the given type constructor, module or assembly. [] indicates global scope. | TAccess of compilationPaths: CompilationPath list - member public x.IsPublic = match x with Public -> true | _ -> false + member public x.IsPublic = + match x with + | Public -> true + | _ -> false - member public x.IsInternal = match x with Internal -> true | _ -> false + member public x.IsInternal = + match x with + | Internal -> true + | _ -> false - member public x.IsPrivate = match x with Private -> true | _ -> false + member public x.IsPrivate = + match x with + | Private -> true + | _ -> false [] member x.DebugText = x.ToString() - member x.AsILMemberAccess () = + member x.AsILMemberAccess() = match getSyntaxAccessForCompPath x with | TypedTree.SyntaxAccess.Public -> ILMemberAccess.Public | TypedTree.SyntaxAccess.Internal -> ILMemberAccess.Assembly @@ -2221,47 +2445,50 @@ type Accessibility = elif x.IsInternal then ILMemberAccess.Assembly else ILMemberAccess.Private - member x.AsILTypeDefAccess () = - if x.IsPublic then ILTypeDefAccess.Public - else ILTypeDefAccess.Private + member x.AsILTypeDefAccess() = + if x.IsPublic then + ILTypeDefAccess.Public + else + ILTypeDefAccess.Private - member x.CompilationPaths = match x with | TAccess compilationPaths -> compilationPaths + member x.CompilationPaths = + match x with + | TAccess compilationPaths -> compilationPaths override x.ToString() = match x with - | TAccess (paths) -> - let mangledTextOfCompPath (CompPath(scoref, _, path)) = getNameOfScopeRef scoref + "/" + textOfPath (List.map fst path) + | TAccess(paths) -> + let mangledTextOfCompPath (CompPath(scoref, _, path)) = + getNameOfScopeRef scoref + "/" + textOfPath (List.map fst path) + let scopename = if x.IsPublic then "public" elif x.IsInternal then "internal" else "private" - let paths = String.concat ";" (List.map mangledTextOfCompPath paths) - if paths = "" then - scopename - else - $"{scopename} {paths}" + let paths = String.concat ";" (List.map mangledTextOfCompPath paths) + if paths = "" then scopename else $"{scopename} {paths}" /// Represents less-frequently-required data about a type parameter of type inference variable [] type TyparOptionalData = { - /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation - /// The storage for the IL name for the type parameter. - mutable typar_il_name: string option + /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation + /// The storage for the IL name for the type parameter. + mutable typar_il_name: string option - /// The documentation for the type parameter. Empty for inference variables. - /// MUTABILITY: for linking when unpickling - mutable typar_xmldoc: XmlDoc + /// The documentation for the type parameter. Empty for inference variables. + /// MUTABILITY: for linking when unpickling + mutable typar_xmldoc: XmlDoc - /// The inferred constraints for the type parameter or inference variable. - mutable typar_constraints: TyparConstraint list + /// The inferred constraints for the type parameter or inference variable. + mutable typar_constraints: TyparConstraint list - /// The declared attributes of the type parameter. Empty for type inference variables. - mutable typar_attribs: Attribs + /// The declared attributes of the type parameter. Empty for type inference variables. + mutable typar_attribs: Attribs - /// Set to true if the typar is contravariant, i.e. declared as in C# - mutable typar_is_contravariant: bool + /// Set to true if the typar is contravariant, i.e. declared as in C# + mutable typar_is_contravariant: bool } [] @@ -2273,30 +2500,30 @@ type TyparData = Typar /// A declared generic type/measure parameter, or a type/measure inference variable. [] -type Typar = +type Typar = { - /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation - /// The identifier for the type parameter - mutable typar_id: Ident - - /// The flag data for the type parameter - mutable typar_flags: TyparFlags - - /// The unique stamp of the type parameter - /// MUTABILITY: for linking when unpickling - mutable typar_stamp: Stamp - - /// An inferred equivalence for a type inference variable. - mutable typar_solution: TType option - - /// A cached TAST type used when this type variable is used as type. - mutable typar_astype: TType - - /// The optional data for the type parameter - mutable typar_opt_data: TyparOptionalData option + /// MUTABILITY: we set the names of generalized inference type parameters to make the look nice for IL code generation + /// The identifier for the type parameter + mutable typar_id: Ident + + /// The flag data for the type parameter + mutable typar_flags: TyparFlags + + /// The unique stamp of the type parameter + /// MUTABILITY: for linking when unpickling + mutable typar_stamp: Stamp + + /// An inferred equivalence for a type inference variable. + mutable typar_solution: TType option + + /// A cached TAST type used when this type variable is used as type. + mutable typar_astype: TType + + /// The optional data for the type parameter + mutable typar_opt_data: TyparOptionalData option } - /// The name of the type parameter + /// The name of the type parameter member x.Name = x.typar_id.idText /// The range of the identifier for the type parameter definition @@ -2312,16 +2539,16 @@ type Typar = member x.Solution = x.typar_solution /// The inferred constraints for the type inference variable, if any - member x.Constraints = + member x.Constraints = match x.typar_opt_data with | Some optData -> optData.typar_constraints | _ -> [] - /// Indicates if the type variable is compiler generated, i.e. is an implicit type inference variable + /// Indicates if the type variable is compiler generated, i.e. is an implicit type inference variable member x.IsCompilerGenerated = x.typar_flags.IsCompilerGenerated /// Indicates if the type variable can be solved or given new constraints. The status of a type variable - /// generally always evolves towards being either rigid or solved. + /// generally always evolves towards being either rigid or solved. member x.Rigidity = x.typar_flags.Rigidity /// Indicates if a type parameter is needed at runtime and may not be eliminated @@ -2343,30 +2570,49 @@ type Typar = member x.IsCompatFlex = x.typar_flags.IsCompatFlex /// Set whether this type parameter is a compat-flex type parameter (i.e. where "expr :> tp" only emits an optional warning) - member x.SetIsCompatFlex b = x.typar_flags <- x.typar_flags.WithCompatFlex b + member x.SetIsCompatFlex b = + x.typar_flags <- x.typar_flags.WithCompatFlex b - member x.SetSupportsNullFlex b = x.typar_flags <- x.typar_flags.WithSupportsNullFlex b + member x.SetSupportsNullFlex b = + x.typar_flags <- x.typar_flags.WithSupportsNullFlex b /// Indicates whether a type variable can be instantiated by types or units-of-measure. member x.Kind = x.typar_flags.Kind /// Indicates whether a type variable is erased in compiled .NET IL code, i.e. whether it is a unit-of-measure variable - member x.IsErased = match x.Kind with TyparKind.Type -> false | _ -> true + member x.IsErased = + match x.Kind with + | TyparKind.Type -> false + | _ -> true /// The declared attributes of the type parameter. Empty for type inference variables and parameters from .NET. - member x.Attribs = + member x.Attribs = match x.typar_opt_data with | Some optData -> optData.typar_attribs | _ -> [] /// Set the attributes on the type parameter - member x.SetAttribs attribs = + member x.SetAttribs attribs = match attribs, x.typar_opt_data with | [], None -> () - | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = []; typar_is_contravariant = false } when doc.IsEmpty -> - x.typar_opt_data <- None + | [], + Some { + typar_il_name = None + typar_xmldoc = doc + typar_constraints = [] + typar_is_contravariant = false + } when doc.IsEmpty -> x.typar_opt_data <- None | _, Some optData -> optData.typar_attribs <- attribs - | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false } + | _ -> + x.typar_opt_data <- + Some + { + typar_il_name = None + typar_xmldoc = XmlDoc.Empty + typar_constraints = [] + typar_attribs = attribs + typar_is_contravariant = false + } /// Get the XML documentation for the type parameter member x.XmlDoc = @@ -2384,71 +2630,113 @@ type Typar = member x.SetILName il_name = match x.typar_opt_data with | Some optData -> optData.typar_il_name <- il_name - | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = false } + | _ -> + x.typar_opt_data <- + Some + { + typar_il_name = il_name + typar_xmldoc = XmlDoc.Empty + typar_constraints = [] + typar_attribs = [] + typar_is_contravariant = false + } /// Indicates the display name of a type variable - member x.DisplayName = if x.Name = "?" then "?"+string x.Stamp else x.Name + member x.DisplayName = if x.Name = "?" then "?" + string x.Stamp else x.Name /// Adjusts the constraints associated with a type variable member x.SetConstraints cs = match cs, x.typar_opt_data with | [], None -> () - | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [];typar_is_contravariant = false } when doc.IsEmpty -> - x.typar_opt_data <- None + | [], + Some { + typar_il_name = None + typar_xmldoc = doc + typar_attribs = [] + typar_is_contravariant = false + } when doc.IsEmpty -> x.typar_opt_data <- None | _, Some optData -> optData.typar_constraints <- cs - | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = []; typar_is_contravariant = false } + | _ -> + x.typar_opt_data <- + Some + { + typar_il_name = None + typar_xmldoc = XmlDoc.Empty + typar_constraints = cs + typar_attribs = [] + typar_is_contravariant = false + } /// Marks the typar as being contravariant - member x.MarkAsContravariant() = + member x.MarkAsContravariant() = match x.typar_opt_data with | Some optData -> optData.typar_is_contravariant <- true | _ -> - x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = true } + x.typar_opt_data <- + Some + { + typar_il_name = None + typar_xmldoc = XmlDoc.Empty + typar_constraints = [] + typar_attribs = [] + typar_is_contravariant = true + } /// Creates a type variable that contains empty data, and is not yet linked. Only used during unpickling of F# metadata. - static member NewUnlinked() : Typar = - { typar_id = Unchecked.defaultof<_> - typar_flags = Unchecked.defaultof<_> - typar_stamp = -1L - typar_solution = Unchecked.defaultof<_> - typar_astype = Unchecked.defaultof<_> - typar_opt_data = Unchecked.defaultof<_> } + static member NewUnlinked() : Typar = + { + typar_id = Unchecked.defaultof<_> + typar_flags = Unchecked.defaultof<_> + typar_stamp = -1L + typar_solution = Unchecked.defaultof<_> + typar_astype = Unchecked.defaultof<_> + typar_opt_data = Unchecked.defaultof<_> + } /// Creates a type variable based on the given data. Only used during unpickling of F# metadata. - static member New (data: TyparData) : Typar = data + static member New(data: TyparData) : Typar = data /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. - member x.Link (tg: TyparData) = + member x.Link(tg: TyparData) = x.typar_id <- tg.typar_id x.typar_flags <- tg.typar_flags x.typar_stamp <- tg.typar_stamp x.typar_solution <- tg.typar_solution + match tg.typar_opt_data with - | Some tg -> - let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant } + | Some tg -> + let optData = + { + typar_il_name = tg.typar_il_name + typar_xmldoc = tg.typar_xmldoc + typar_constraints = tg.typar_constraints + typar_attribs = tg.typar_attribs + typar_is_contravariant = tg.typar_is_contravariant + } + x.typar_opt_data <- Some optData | None -> () /// Links a previously unlinked type variable to the given data. Only used during unpickling of F# metadata. - member x.AsType nullness = - match nullness with - | Nullness.Known NullnessInfo.AmbivalentToNull -> + member x.AsType nullness = + match nullness with + | Nullness.Known NullnessInfo.AmbivalentToNull -> let ty = x.typar_astype - match box ty with - | null -> - let ty2 = TType_var (x, Nullness.Known NullnessInfo.AmbivalentToNull) + + match box ty with + | null -> + let ty2 = TType_var(x, Nullness.Known NullnessInfo.AmbivalentToNull) x.typar_astype <- ty2 ty2 | _ -> ty - | _ -> - TType_var (x, nullness) + | _ -> TType_var(x, nullness) /// Indicates if a type variable has been linked. Only used during unpickling of F# metadata. member x.IsLinked = x.typar_stamp <> -1L /// Indicates if a type variable has been solved. - member x.IsSolved = - match x.Solution with + member x.IsSolved = + match x.Solution with | None -> false | _ -> true @@ -2458,12 +2746,36 @@ type Typar = /// Sets the rigidity of a type variable member x.SetRigidity b = let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, b, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn, flags.IsSupportsNullFlex) + + x.typar_flags <- + TyparFlags( + flags.Kind, + b, + flags.IsFromError, + flags.IsCompilerGenerated, + flags.StaticReq, + flags.DynamicReq, + flags.EqualityConditionalOn, + flags.ComparisonConditionalOn, + flags.IsSupportsNullFlex + ) /// Sets whether a type variable is compiler generated member x.SetCompilerGenerated b = let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, b, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, flags.ComparisonConditionalOn, flags.IsSupportsNullFlex) + + x.typar_flags <- + TyparFlags( + flags.Kind, + flags.Rigidity, + flags.IsFromError, + b, + flags.StaticReq, + flags.DynamicReq, + flags.EqualityConditionalOn, + flags.ComparisonConditionalOn, + flags.IsSupportsNullFlex + ) /// Sets whether a type variable has a static requirement member x.SetStaticReq b = @@ -2472,17 +2784,53 @@ type Typar = /// Sets whether a type variable is required at runtime member x.SetDynamicReq b = let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, b, flags.EqualityConditionalOn, flags.ComparisonConditionalOn, flags.IsSupportsNullFlex) - /// Sets whether the equality constraint of a type definition depends on this type variable + x.typar_flags <- + TyparFlags( + flags.Kind, + flags.Rigidity, + flags.IsFromError, + flags.IsCompilerGenerated, + flags.StaticReq, + b, + flags.EqualityConditionalOn, + flags.ComparisonConditionalOn, + flags.IsSupportsNullFlex + ) + + /// Sets whether the equality constraint of a type definition depends on this type variable member x.SetEqualityDependsOn b = let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, b, flags.ComparisonConditionalOn, flags.IsSupportsNullFlex) - /// Sets whether the comparison constraint of a type definition depends on this type variable + x.typar_flags <- + TyparFlags( + flags.Kind, + flags.Rigidity, + flags.IsFromError, + flags.IsCompilerGenerated, + flags.StaticReq, + flags.DynamicReq, + b, + flags.ComparisonConditionalOn, + flags.IsSupportsNullFlex + ) + + /// Sets whether the comparison constraint of a type definition depends on this type variable member x.SetComparisonDependsOn b = let flags = x.typar_flags - x.typar_flags <- TyparFlags(flags.Kind, flags.Rigidity, flags.IsFromError, flags.IsCompilerGenerated, flags.StaticReq, flags.DynamicReq, flags.EqualityConditionalOn, b, flags.IsSupportsNullFlex) + + x.typar_flags <- + TyparFlags( + flags.Kind, + flags.Rigidity, + flags.IsFromError, + flags.IsCompilerGenerated, + flags.StaticReq, + flags.DynamicReq, + flags.EqualityConditionalOn, + b, + flags.IsSupportsNullFlex + ) [] member x.DebugText = x.ToString() @@ -2491,65 +2839,65 @@ type Typar = /// Represents a constraint on a type parameter or type [] -type TyparConstraint = +type TyparConstraint = - /// A constraint that a type is a subtype of the given type + /// A constraint that a type is a subtype of the given type | CoercesTo of ty: TType * range: range - /// A constraint for a default value for an inference type variable should it be neither generalized nor solved - | DefaultsTo of priority: int * ty: TType * range: range - - /// A constraint that a type has a 'null' value - | SupportsNull of range: range - + /// A constraint for a default value for an inference type variable should it be neither generalized nor solved + | DefaultsTo of priority: int * ty: TType * range: range + + /// A constraint that a type has a 'null' value + | SupportsNull of range: range + /// A constraint that a type doesn't support nullness - | NotSupportsNull of range - - /// A constraint that a type has a member with the given signature + | NotSupportsNull of range + + /// A constraint that a type has a member with the given signature | MayResolveMember of constraintInfo: TraitConstraintInfo * range: range - - /// A constraint that a type is a non-Nullable value type - /// These are part of .NET's model of generic constraints, and in order to - /// generate verifiable code we must attach them to F# generalized type variables as well. - | IsNonNullableStruct of range: range - - /// A constraint that a type is a reference type - | IsReferenceType of range: range - - /// A constraint that a type is a simple choice between one of the given ground types. Only arises from 'printf' format strings. See format.fs - | SimpleChoice of tys: TTypes * range: range - - /// A constraint that a type has a parameterless constructor - | RequiresDefaultConstructor of range: range - - /// A constraint that a type is an enum with the given underlying - | IsEnum of ty: TType * range: range - + + /// A constraint that a type is a non-Nullable value type + /// These are part of .NET's model of generic constraints, and in order to + /// generate verifiable code we must attach them to F# generalized type variables as well. + | IsNonNullableStruct of range: range + + /// A constraint that a type is a reference type + | IsReferenceType of range: range + + /// A constraint that a type is a simple choice between one of the given ground types. Only arises from 'printf' format strings. See format.fs + | SimpleChoice of tys: TTypes * range: range + + /// A constraint that a type has a parameterless constructor + | RequiresDefaultConstructor of range: range + + /// A constraint that a type is an enum with the given underlying + | IsEnum of ty: TType * range: range + /// A constraint that a type implements IComparable, with special rules for some known structural container types - | SupportsComparison of range: range - + | SupportsComparison of range: range + /// A constraint that a type does not have the Equality(false) attribute, or is not a structural type with this attribute, with special rules for some known structural container types - | SupportsEquality of range: range - + | SupportsEquality of range: range + /// A constraint that a type is a delegate from the given tuple of args to the given return type - | IsDelegate of aty: TType * bty: TType * range: range - + | IsDelegate of aty: TType * bty: TType * range: range + /// A constraint that a type is .NET unmanaged type | IsUnmanaged of range: range - + /// An anti-constraint indicating that ref structs (e.g. Span<>) are allowed here - | AllowsRefStruct of range:range + | AllowsRefStruct of range: range // %+A formatting is used, so this is not needed //[] //member x.DebugText = x.ToString() - - override x.ToString() = sprintf "%+A" x - + + override x.ToString() = sprintf "%+A" x + [] -type TraitWitnessInfo = +type TraitWitnessInfo = | TraitWitnessInfo of tys: TTypes * memberName: string * memberFlags: SynMemberFlags * objAndArgTys: TTypes * returnTy: TType option - + /// Get the member name associated with the member constraint. member x.MemberName = (let (TraitWitnessInfo(_, b, _, _, _)) = x in b) @@ -2559,23 +2907,24 @@ type TraitWitnessInfo = [] member x.DebugText = x.ToString() - override x.ToString() = "TraitWitnessInfo(" + x.MemberName + ")" - -/// The specification of a member constraint that must be solved + override x.ToString() = + "TraitWitnessInfo(" + x.MemberName + ")" + +/// The specification of a member constraint that must be solved [] -type TraitConstraintInfo = +type TraitConstraintInfo = /// Indicates the signature of a member constraint. Contains a mutable solution cell /// to store the inferred solution of the constraint. And a mutable source cell to store /// the name of the type or member that defined the constraint. | TTrait of - tys: TTypes * - memberName: string * - memberFlags: SynMemberFlags * - objAndArgTys: TTypes * - returnTyOpt: TType option * - source: string option ref * - solution: TraitConstraintSln option ref + tys: TTypes * + memberName: string * + memberFlags: SynMemberFlags * + objAndArgTys: TTypes * + returnTyOpt: TType option * + source: string option ref * + solution: TraitConstraintSln option ref /// Get the types that may provide solutions for the traits member x.SupportTypes = (let (TTrait(tys = tys)) = x in tys) @@ -2586,37 +2935,41 @@ type TraitConstraintInfo = /// Get the member flags associated with the member constraint. member x.MemberFlags = (let (TTrait(memberFlags = flags)) = x in flags) - member x.CompiledObjectAndArgumentTypes = (let (TTrait(objAndArgTys = objAndArgTys)) = x in objAndArgTys) - + member x.CompiledObjectAndArgumentTypes = + (let (TTrait(objAndArgTys = objAndArgTys)) = x in objAndArgTys) + /// Get the optional return type recorded in the member constraint. member x.CompiledReturnType = (let (TTrait(returnTyOpt = retTy)) = x in retTy) - + /// Get or set the solution of the member constraint during inference - member x.Solution - with get() = (let (TTrait(solution = sln)) = x in sln.Value) + member x.Solution + with get () = (let (TTrait(solution = sln)) = x in sln.Value) and set v = (let (TTrait(solution = sln)) = x in sln.Value <- v) - member x.WithMemberKind(kind) = (let (TTrait(a, b, c, d, e, f, g)) = x in TTrait(a, b, { c with MemberKind=kind }, d, e, f, g)) + member x.WithMemberKind(kind) = + (let (TTrait(a, b, c, d, e, f, g)) = x in TTrait(a, b, { c with MemberKind = kind }, d, e, f, g)) - member x.WithSupportTypes(tys) = (let (TTrait(_, b, c, d, e, f, g)) = x in TTrait(tys, b, c, d, e, f, g)) + member x.WithSupportTypes(tys) = + (let (TTrait(_, b, c, d, e, f, g)) = x in TTrait(tys, b, c, d, e, f, g)) - member x.WithMemberName(name) = (let (TTrait(a, _, c, d, e, f, g)) = x in TTrait(a, name, c, d, e, f, g)) + member x.WithMemberName(name) = + (let (TTrait(a, _, c, d, e, f, g)) = x in TTrait(a, name, c, d, e, f, g)) [] member x.DebugText = x.ToString() override x.ToString() = "TTrait(" + x.MemberLogicalName + ")" - + /// Represents the solution of a member constraint during inference. [] -type TraitConstraintSln = +type TraitConstraintSln = /// FSMethSln(ty, vref, minst) /// /// Indicates a trait is solved by an F# method. /// ty -- the type and its instantiation /// vref -- the method that solves the trait constraint - /// minst -- the generic method instantiation + /// minst -- the generic method instantiation /// staticTyOpt -- the static type governing a static virtual call, if any | FSMethSln of ty: TType * vref: ValRef * minst: TypeInst * staticTyOpt: TType option @@ -2637,14 +2990,14 @@ type TraitConstraintSln = /// ty -- the type and its instantiation /// extOpt -- information about an extension member, if any /// ilMethodRef -- the method that solves the trait constraint - /// minst -- the generic method instantiation + /// minst -- the generic method instantiation /// staticTyOpt -- the static type governing a static virtual call, if any | ILMethSln of ty: TType * extOpt: ILTypeRef option * ilMethodRef: ILMethodRef * minst: TypeInst * staticTyOpt: TType option /// ClosedExprSln expr /// /// Indicates a trait is solved by an erased provided expression - | ClosedExprSln of expr: Expr + | ClosedExprSln of expr: Expr /// Indicates a trait is solved by a 'fake' instance of an operator, like '+' on integers | BuiltInSln @@ -2653,29 +3006,30 @@ type TraitConstraintSln = //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x /// The partial information used to index the methods of all those in a ModuleOrNamespace. [] -type ValLinkagePartialKey = - { - /// The name of the type with which the member is associated. None for non-member values. - MemberParentMangledName: string option +type ValLinkagePartialKey = + { + /// The name of the type with which the member is associated. None for non-member values. + MemberParentMangledName: string option - /// Indicates if the member is an override. - MemberIsOverride: bool + /// Indicates if the member is an override. + MemberIsOverride: bool - /// Indicates the logical name of the member. - LogicalName: string + /// Indicates the logical name of the member. + LogicalName: string - /// Indicates the total argument count of the member. - TotalArgCount: int - } + /// Indicates the total argument count of the member. + TotalArgCount: int + } [] member x.DebugText = x.ToString() - override x.ToString() = "ValLinkagePartialKey(" + x.LogicalName + ")" + override x.ToString() = + "ValLinkagePartialKey(" + x.LogicalName + ")" /// The full information used to identify a specific overloaded method /// amongst all those in a ModuleOrNamespace. @@ -2691,72 +3045,73 @@ type ValLinkageFullKey(partialKey: ValLinkagePartialKey, typeForLinkage: TType o [] member x.DebugText = x.ToString() - override x.ToString() = "ValLinkageFullKey(" + partialKey.LogicalName + ")" + override x.ToString() = + "ValLinkageFullKey(" + partialKey.LogicalName + ")" [] type ValOptionalData = { - /// MUTABILITY: for unpickle linkage - mutable val_compiled_name: string option - - /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is - /// the signature range for an item in an implementation - mutable val_other_range: (range * bool) option - - mutable val_const: Const option - - /// What is the original, unoptimized, closed-term definition, if any? - /// Used to implement [] - mutable val_defn: Expr option - - /// Records the "extra information" for a value compiled as a method (rather - /// than a closure or a local), including argument names, attributes etc. - // - // MUTABILITY CLEANUP: mutability of this field is used by - // -- adjustAllUsesOfRecValue - // -- TLR optimizations - // -- LinearizeTopMatch - // - // For example, we use mutability to replace the empty arity initially assumed with an arity garnered from the - // type-checked expression. - mutable val_repr_info: ValReprInfo option - - /// Records the "extra information" for display purposes for expression-level function definitions - /// that may be compiled as closures (that is are not necessarily compiled as top-level methods). - mutable val_repr_info_for_display: ValReprInfo option - - /// Records the "extra information" for parameters in implementation files if we've been able to correlate - /// them with lambda arguments. - mutable arg_repr_info_for_display: ArgReprInfo option - - /// How visible is this? - /// MUTABILITY: for unpickle linkage - mutable val_access: Accessibility - - /// XML documentation attached to a value. - /// MUTABILITY: for unpickle linkage - mutable val_xmldoc: XmlDoc - - /// the signature xml doc for an item in an implementation file. - mutable val_other_xmldoc : XmlDoc option - - /// Is the value actually an instance method/property/event that augments - /// a type, and if so what name does it take in the IL? - /// MUTABILITY: for unpickle linkage - mutable val_member_info: ValMemberInfo option - - // MUTABILITY CLEANUP: mutability of this field is used by - // -- LinearizeTopMatch - // - // The fresh temporary should just be created with the right parent - mutable val_declaring_entity: ParentRef - - /// XML documentation signature for the value - mutable val_xmldocsig: string - - /// Custom attributes attached to the value. These contain references to other values (i.e. constructors in types). Mutable to fixup - /// these value references after copying a collection of values. - mutable val_attribs: Attribs + /// MUTABILITY: for unpickle linkage + mutable val_compiled_name: string option + + /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is + /// the signature range for an item in an implementation + mutable val_other_range: (range * bool) option + + mutable val_const: Const option + + /// What is the original, unoptimized, closed-term definition, if any? + /// Used to implement [] + mutable val_defn: Expr option + + /// Records the "extra information" for a value compiled as a method (rather + /// than a closure or a local), including argument names, attributes etc. + // + // MUTABILITY CLEANUP: mutability of this field is used by + // -- adjustAllUsesOfRecValue + // -- TLR optimizations + // -- LinearizeTopMatch + // + // For example, we use mutability to replace the empty arity initially assumed with an arity garnered from the + // type-checked expression. + mutable val_repr_info: ValReprInfo option + + /// Records the "extra information" for display purposes for expression-level function definitions + /// that may be compiled as closures (that is are not necessarily compiled as top-level methods). + mutable val_repr_info_for_display: ValReprInfo option + + /// Records the "extra information" for parameters in implementation files if we've been able to correlate + /// them with lambda arguments. + mutable arg_repr_info_for_display: ArgReprInfo option + + /// How visible is this? + /// MUTABILITY: for unpickle linkage + mutable val_access: Accessibility + + /// XML documentation attached to a value. + /// MUTABILITY: for unpickle linkage + mutable val_xmldoc: XmlDoc + + /// the signature xml doc for an item in an implementation file. + mutable val_other_xmldoc: XmlDoc option + + /// Is the value actually an instance method/property/event that augments + /// a type, and if so what name does it take in the IL? + /// MUTABILITY: for unpickle linkage + mutable val_member_info: ValMemberInfo option + + // MUTABILITY CLEANUP: mutability of this field is used by + // -- LinearizeTopMatch + // + // The fresh temporary should just be created with the right parent + mutable val_declaring_entity: ParentRef + + /// XML documentation signature for the value + mutable val_xmldocsig: string + + /// Custom attributes attached to the value. These contain references to other values (i.e. constructors in types). Mutable to fixup + /// these value references after copying a collection of values. + mutable val_attribs: Attribs } [] @@ -2767,93 +3122,98 @@ type ValOptionalData = type ValData = Val [] -type Val = +type Val = { - /// Mutable for unpickle linkage - mutable val_logical_name: string + /// Mutable for unpickle linkage + mutable val_logical_name: string - /// Mutable for unpickle linkage - mutable val_range: range + /// Mutable for unpickle linkage + mutable val_range: range - mutable val_type: TType + mutable val_type: TType - /// Mutable for unpickle linkage - mutable val_stamp: Stamp + /// Mutable for unpickle linkage + mutable val_stamp: Stamp - /// See vflags section further below for encoding/decodings here - mutable val_flags: ValFlags + /// See vflags section further below for encoding/decodings here + mutable val_flags: ValFlags - mutable val_opt_data: ValOptionalData option } + mutable val_opt_data: ValOptionalData option + } static member NewEmptyValOptData() = - { val_compiled_name = None - val_other_range = None - val_const = None - val_defn = None - val_repr_info = None - val_repr_info_for_display = None - arg_repr_info_for_display = None - val_access = TAccess [] - val_xmldoc = XmlDoc.Empty - val_other_xmldoc = None - val_member_info = None - val_declaring_entity = ParentNone - val_xmldocsig = String.Empty - val_attribs = [] } - - /// Range of the definition (implementation) of the value, used by Visual Studio - member x.DefinitionRange = + { + val_compiled_name = None + val_other_range = None + val_const = None + val_defn = None + val_repr_info = None + val_repr_info_for_display = None + arg_repr_info_for_display = None + val_access = TAccess [] + val_xmldoc = XmlDoc.Empty + val_other_xmldoc = None + val_member_info = None + val_declaring_entity = ParentNone + val_xmldocsig = String.Empty + val_attribs = [] + } + + /// Range of the definition (implementation) of the value, used by Visual Studio + member x.DefinitionRange = match x.val_opt_data with | Some { val_other_range = Some(m, true) } -> m | _ -> x.val_range - /// Range of the definition (signature) of the value, used by Visual Studio + /// Range of the definition (signature) of the value, used by Visual Studio member x.SigRange = match x.val_opt_data with - | Some { arg_repr_info_for_display = Some { OtherRange = Some m } } -> m + | Some { + arg_repr_info_for_display = Some { OtherRange = Some m } + } -> m | Some { val_other_range = Some(m, false) } -> m | _ -> x.val_range - /// The place where the value was defined. + /// The place where the value was defined. member x.Range = x.val_range - /// A unique stamp within the context of this invocation of the compiler process + /// A unique stamp within the context of this invocation of the compiler process member x.Stamp = x.val_stamp - /// The type of the value. - /// May be a TType_forall for a generic value. - /// May be a type variable or type containing type variables during type inference. + /// The type of the value. + /// May be a TType_forall for a generic value. + /// May be a type variable or type containing type variables during type inference. // - // Note: this data is mutated during inference by adjustAllUsesOfRecValue when we replace the inferred type with a schema. + // Note: this data is mutated during inference by adjustAllUsesOfRecValue when we replace the inferred type with a schema. member x.Type = x.val_type /// How visible is this value, function or member? - member x.Accessibility = + member x.Accessibility = match x.val_opt_data with | Some optData -> optData.val_access | _ -> TAccess [] - /// The value of a value or member marked with [] - member x.LiteralValue = + /// The value of a value or member marked with [] + member x.LiteralValue = match x.val_opt_data with | Some optData -> optData.val_const | _ -> None /// Records the "extra information" for a value compiled as a method. /// - /// This indicates the number of arguments in each position for a curried + /// This indicates the number of arguments in each position for a curried /// functions, and relates to the F# spec for arity analysis. - /// For module-defined values, the currying is based - /// on the number of lambdas, and in each position the elements are - /// based on attempting to deconstruct the type of the argument as a - /// tuple-type. + /// For module-defined values, the currying is based + /// on the number of lambdas, and in each position the elements are + /// based on attempting to deconstruct the type of the argument as a + /// tuple-type. /// - /// The field is mutable because arities for recursive - /// values are only inferred after the r.h.s. is analyzed, but the - /// value itself is created before the r.h.s. is analyzed. + /// The field is mutable because arities for recursive + /// values are only inferred after the r.h.s. is analyzed, but the + /// value itself is created before the r.h.s. is analyzed. /// - /// TLR also sets this for inner bindings that it wants to - /// represent as "top level" bindings. + /// TLR also sets this for inner bindings that it wants to + /// represent as "top level" bindings. member x.ValReprInfo: ValReprInfo option = match x.val_opt_data with | Some optData -> optData.val_repr_info @@ -2869,28 +3229,35 @@ type Val = | Some optData -> optData.arg_repr_info_for_display | _ -> None - member x.Id = ident(x.LogicalName, x.Range) + member x.Id = ident (x.LogicalName, x.Range) /// Is this represented as a "top level" static binding (i.e. a static field, static member, /// instance member), rather than an "inner" binding that may result in a closure. /// /// This is implied by IsMemberOrModuleBinding, however not vice versa, for two reasons. - /// Some optimizations mutate this value when they decide to change the representation of a + /// Some optimizations mutate this value when they decide to change the representation of a /// binding to be IsCompiledAsTopLevel. Second, even immediately after type checking we expect - /// some non-module, non-member bindings to be marked IsCompiledAsTopLevel, e.g. 'y' in + /// some non-module, non-member bindings to be marked IsCompiledAsTopLevel, e.g. 'y' in /// 'let x = let y = 1 in y + y' (NOTE: check this, don't take it as gospel) - member x.IsCompiledAsTopLevel = x.ValReprInfo.IsSome + member x.IsCompiledAsTopLevel = x.ValReprInfo.IsSome /// The partial information used to index the methods of all those in a ModuleOrNamespace. - member x.GetLinkagePartialKey() : ValLinkagePartialKey = + member x.GetLinkagePartialKey() : ValLinkagePartialKey = assert x.IsCompiledAsTopLevel - { LogicalName = x.LogicalName - MemberParentMangledName = (if x.IsMember then Some x.MemberApparentEntity.LogicalName else None) - MemberIsOverride = x.IsOverrideOrExplicitImpl - TotalArgCount = if x.IsMember then x.ValReprInfo.Value.TotalArgCount else 0 } + + { + LogicalName = x.LogicalName + MemberParentMangledName = + (if x.IsMember then + Some x.MemberApparentEntity.LogicalName + else + None) + MemberIsOverride = x.IsOverrideOrExplicitImpl + TotalArgCount = if x.IsMember then x.ValReprInfo.Value.TotalArgCount else 0 + } /// The full information used to identify a specific overloaded method amongst all those in a ModuleOrNamespace. - member x.GetLinkageFullKey() : ValLinkageFullKey = + member x.GetLinkageFullKey() : ValLinkageFullKey = assert x.IsCompiledAsTopLevel let key = x.GetLinkagePartialKey() ValLinkageFullKey(key, (if x.IsMember then Some x.Type else None)) @@ -2911,7 +3278,7 @@ type Val = /// /// Note, the value may still be (a) an extension member or (b) and abstract slot without /// a true body. These cases are often causes of bugs in the compiler. - member x.MemberInfo = + member x.MemberInfo = match x.val_opt_data with | Some optData -> optData.val_member_info | _ -> None @@ -2923,12 +3290,12 @@ type Val = member x.IsIntrinsicMember = x.IsMember && not x.IsExtensionMember /// Indicates if this is an F#-defined value in a module, or an extension member, but excluding compiler generated bindings from optimizations - member x.IsModuleBinding = x.IsMemberOrModuleBinding && not x.IsMember + member x.IsModuleBinding = x.IsMemberOrModuleBinding && not x.IsMember /// Indicates if this is something compiled into a module, i.e. a user-defined value, an extension member or a compiler-generated value member x.IsCompiledIntoModule = x.IsExtensionMember || x.IsModuleBinding - /// Indicates if this is an F#-defined instance member. + /// Indicates if this is an F#-defined instance member. /// /// Note, the value may still be (a) an extension member or (b) and abstract slot without /// a true body. These cases are often causes of bugs in the compiler. @@ -2936,41 +3303,55 @@ type Val = /// Indicates if this is an F#-defined 'new' constructor member member x.IsConstructor = - match x.MemberInfo with - | Some memberInfo when not x.IsExtensionMember && (memberInfo.MemberFlags.MemberKind = SynMemberKind.Constructor) -> true + match x.MemberInfo with + | Some memberInfo when + not x.IsExtensionMember + && (memberInfo.MemberFlags.MemberKind = SynMemberKind.Constructor) + -> + true | _ -> false /// Indicates if this is a compiler-generated class constructor member member x.IsClassConstructor = - match x.MemberInfo with - | Some memberInfo when not x.IsExtensionMember && (memberInfo.MemberFlags.MemberKind = SynMemberKind.ClassConstructor) -> true + match x.MemberInfo with + | Some memberInfo when + not x.IsExtensionMember + && (memberInfo.MemberFlags.MemberKind = SynMemberKind.ClassConstructor) + -> + true | _ -> false /// Indicates if this value was a member declared 'override' or an implementation of an interface slot member x.IsOverrideOrExplicitImpl = - match x.MemberInfo with + match x.MemberInfo with | Some memberInfo when memberInfo.MemberFlags.IsOverrideOrExplicitImpl -> true | _ -> false - + /// Gets the dispatch slots implemented by this method member x.ImplementedSlotSigs = - match x.MemberInfo with + match x.MemberInfo with | Some memberInfo -> memberInfo.ImplementedSlotSigs | _ -> [] - + /// Indicates if this is declared 'mutable' - member x.IsMutable = (match x.val_flags.MutabilityInfo with Immutable -> false | Mutable -> true) + member x.IsMutable = + (match x.val_flags.MutabilityInfo with + | Immutable -> false + | Mutable -> true) /// Indicates if this is inferred to be a method or function that definitely makes no critical tailcalls? member x.MakesNoCriticalTailcalls = x.val_flags.MakesNoCriticalTailcalls - + /// Indicates if this is ever referenced? member x.HasBeenReferenced = x.val_flags.HasBeenReferenced /// Indicates if the backing field for a static value is suppressed. - member x.IsCompiledAsStaticPropertyWithoutField = - let hasValueAsStaticProperty = x.Attribs |> List.exists(fun (Attrib(tc, _, _, _, _, _, _)) -> tc.CompiledName = "ValueAsStaticPropertyAttribute") - x.val_flags.IsCompiledAsStaticPropertyWithoutField || hasValueAsStaticProperty + member x.IsCompiledAsStaticPropertyWithoutField = + let hasValueAsStaticProperty = + x.Attribs + |> List.exists (fun (Attrib(tc, _, _, _, _, _, _)) -> tc.CompiledName = "ValueAsStaticPropertyAttribute") + + x.val_flags.IsCompiledAsStaticPropertyWithoutField || hasValueAsStaticProperty /// Indicates if the value is pinned/fixed member x.IsFixed = x.val_flags.IsFixed @@ -2980,13 +3361,16 @@ type Val = /// Indicates if this value allows the use of an explicit type instantiation (i.e. does it itself have explicit type arguments, /// or does it have a signature?) - member x.PermitsExplicitTypeInstantiation = x.val_flags.PermitsExplicitTypeInstantiation + member x.PermitsExplicitTypeInstantiation = + x.val_flags.PermitsExplicitTypeInstantiation /// Indicates if this is a member generated from the de-sugaring of 'let' function bindings in the implicit class syntax? - member x.IsIncrClassGeneratedMember = x.IsCompilerGenerated && x.val_flags.IsIncrClassSpecialMember + member x.IsIncrClassGeneratedMember = + x.IsCompilerGenerated && x.val_flags.IsIncrClassSpecialMember /// Indicates if this is a constructor member generated from the de-sugaring of implicit constructor for a class type? - member x.IsIncrClassConstructor = x.IsConstructor && x.val_flags.IsIncrClassSpecialMember + member x.IsIncrClassConstructor = + x.IsConstructor && x.val_flags.IsIncrClassSpecialMember /// Get the information about the value used during type inference member x.RecursiveValInfo = x.val_flags.RecursiveValInfo @@ -3006,9 +3390,8 @@ type Val = // Indicates if this value was declared to be a type function, e.g. "let f<'a> = typeof<'a>" member x.IsTypeFunction = x.val_flags.IsTypeFunction - member x.HasSignatureFile = - x.SigRange <> x.DefinitionRange - + member x.HasSignatureFile = x.SigRange <> x.DefinitionRange + /// Get the inline declaration on the value member x.InlineInfo = x.val_flags.InlineInfo @@ -3028,10 +3411,11 @@ type Val = /// Indicates that this value's getter or setter are generated by the compiler member x.GetterOrSetterIsCompilerGenerated = - x.MemberInfo |> Option.exists (fun m -> m.MemberFlags.GetterOrSetterIsCompilerGenerated) + x.MemberInfo + |> Option.exists (fun m -> m.MemberFlags.GetterOrSetterIsCompilerGenerated) /// Get the declared attributes for the value - member x.Attribs = + member x.Attribs = match x.val_opt_data with | Some optData -> optData.val_attribs | _ -> [] @@ -3047,20 +3431,25 @@ type Val = | Some xmlDoc -> xmlDoc | None -> XmlDoc.Empty | _ -> XmlDoc.Empty - + ///Get the signature for the value's XML documentation - member x.XmlDocSig - with get() = - match x.val_opt_data with - | Some optData -> optData.val_xmldocsig + member x.XmlDocSig + with get () = + match x.val_opt_data with + | Some optData -> optData.val_xmldocsig | _ -> String.Empty - and set v = - match x.val_opt_data with - | Some optData -> optData.val_xmldocsig <- v - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_xmldocsig = v } + and set v = + match x.val_opt_data with + | Some optData -> optData.val_xmldocsig <- v + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_xmldocsig = v + } /// The parent type or module, if any (None for expression bindings and parameters) - member x.TryDeclaringEntity = + member x.TryDeclaringEntity = match x.val_opt_data with | Some optData -> optData.val_declaring_entity | _ -> ParentNone @@ -3068,33 +3457,33 @@ type Val = /// Get the actual parent entity for the value (a module or a type), i.e. the entity under which the /// value will appear in compiled code. For extension members this is the module where the extension member /// is declared. - member x.DeclaringEntity = - match x.TryDeclaringEntity with + member x.DeclaringEntity = + match x.TryDeclaringEntity with | Parent tcref -> tcref - | ParentNone -> error(InternalError("DeclaringEntity: does not have a parent", x.Range)) + | ParentNone -> error (InternalError("DeclaringEntity: does not have a parent", x.Range)) - member x.HasDeclaringEntity = - match x.TryDeclaringEntity with + member x.HasDeclaringEntity = + match x.TryDeclaringEntity with | Parent _ -> true | ParentNone -> false - + /// Get the apparent parent entity for a member - member x.MemberApparentEntity: TyconRef = - match x.MemberInfo with + member x.MemberApparentEntity: TyconRef = + match x.MemberInfo with | Some membInfo -> membInfo.ApparentEnclosingEntity - | None -> error(InternalError("MemberApparentEntity", x.Range)) + | None -> error (InternalError("MemberApparentEntity", x.Range)) /// Get the number of 'this'/'self' object arguments for the member. Instance extension members return '1'. member v.NumObjArgs = - match v.MemberInfo with + match v.MemberInfo with | Some membInfo -> if membInfo.MemberFlags.IsInstance then 1 else 0 | None -> 0 /// Get the apparent parent entity for the value, i.e. the entity under with which the /// value is associated. For extension members this is the nominal type the member extends. /// For other values it is just the actual parent. - member x.ApparentEnclosingEntity = - match x.MemberInfo with + member x.ApparentEnclosingEntity = + match x.MemberInfo with | Some membInfo -> Parent(membInfo.ApparentEnclosingEntity) | None -> x.TryDeclaringEntity @@ -3106,57 +3495,55 @@ type Val = // - in ilxgen.fs: when compiling fslib, we bind an entry for the value in a global table (see bind_escaping_local_vspec) // - in opt.fs: (fullDebugTextOfValRef) for error reporting of non-inlinable values // - in service.fs (output_item_description): to display the full text of a value's binding location - // - in check.fs: as a boolean to detect public values for saving quotations - // - in ilxgen.fs: as a boolean to detect public values for saving quotations + // - in check.fs: as a boolean to detect public values for saving quotations + // - in ilxgen.fs: as a boolean to detect public values for saving quotations // - in MakeExportRemapping, to build non-local references for values - member x.PublicPath = - match x.TryDeclaringEntity with - | Parent eref -> - match eref.PublicPath with + member x.PublicPath = + match x.TryDeclaringEntity with + | Parent eref -> + match eref.PublicPath with | None -> None | Some p -> Some(ValPubPath(p, x.GetLinkageFullKey())) - | ParentNone -> - None + | ParentNone -> None /// Indicates if this member is an F#-defined dispatch slot. - member x.IsDispatchSlot = - match x.MemberInfo with - | Some membInfo -> membInfo.MemberFlags.IsDispatchSlot + member x.IsDispatchSlot = + match x.MemberInfo with + | Some membInfo -> membInfo.MemberFlags.IsDispatchSlot | _ -> false /// Get the type of the value including any generic type parameters - member x.GeneralizedType = - match x.Type with + member x.GeneralizedType = + match x.Type with | TType_forall(tps, tau) -> tps, tau | ty -> [], ty /// Get the type of the value after removing any generic type parameters - member x.TauType = - match x.Type with + member x.TauType = + match x.Type with | TType_forall(_, tau) -> tau | ty -> ty /// Get the generic type parameters for the value - member x.Typars = - match x.Type with + member x.Typars = + match x.Type with | TType_forall(tps, _) -> tps | _ -> [] - /// The name of the method. + /// The name of the method. /// - If this is a property then this is 'get_Foo' or 'set_Foo' /// - If this is an implementation of an abstract slot then this is the name of the method implemented by the abstract slot /// - If this is an extension member then this will be the simple name - member x.LogicalName = - match x.MemberInfo with + member x.LogicalName = + match x.MemberInfo with | None -> x.val_logical_name - | Some membInfo -> - match membInfo.ImplementedSlotSigs with + | Some membInfo -> + match membInfo.ImplementedSlotSigs with | slotsig :: _ -> slotsig.Name | _ -> x.val_logical_name // Set the logical name of the value - member x.SetLogicalName(nm) = - x.val_logical_name <- nm + member x.SetLogicalName(nm) = x.val_logical_name <- nm member x.ValCompiledName = match x.val_opt_data with @@ -3168,13 +3555,13 @@ type Val = /// - If this is an implementation of an abstract slot then this may be a mangled name /// - If this is an extension member then this will be a mangled name /// - If this is an operator then this is 'op_Addition' - member x.CompiledName (compilerGlobalState:CompilerGlobalState option) = - let givenName = - match x.val_opt_data with + member x.CompiledName(compilerGlobalState: CompilerGlobalState option) = + let givenName = + match x.val_opt_data with | Some { val_compiled_name = Some n } -> n - | _ -> x.LogicalName + | _ -> x.LogicalName // These cases must get stable unique names for their static field & static property. This name - // must be stable across quotation generation and IL code generation (quotations can refer to the + // must be stable across quotation generation and IL code generation (quotations can refer to the // properties implicit in these) // // Variable 'x' here, which is compiled as a top level static: @@ -3182,19 +3569,23 @@ type Val = // // The implicit 'patternInput' variable here: // let [x] = expr in ... // IsMemberOrModuleBinding = true, IsCompiledAsTopLevel = true, IsMember = false, CompilerGenerated=true - // + // // The implicit 'copyOfStruct' variables here: // let dt = System.DateTime.Now - System.DateTime.Now // IsMemberOrModuleBinding = false, IsCompiledAsTopLevel = true, IsMember = false, CompilerGenerated=true - // + // // However we don't need this for CompilerGenerated members such as the implementations of IComparable match compilerGlobalState with - | Some state when x.IsCompiledAsTopLevel && not x.IsMember && (x.IsCompilerGenerated || not x.IsMemberOrModuleBinding) -> - state.StableNameGenerator.GetUniqueCompilerGeneratedName(givenName, x.Range, x.Stamp) + | Some state when + x.IsCompiledAsTopLevel + && not x.IsMember + && (x.IsCompilerGenerated || not x.IsMemberOrModuleBinding) + -> + state.StableNameGenerator.GetUniqueCompilerGeneratedName(givenName, x.Range, x.Stamp) | _ -> givenName /// The name of the property. - /// - If this is a property then this is 'Foo' - member x.PropertyName = + /// - If this is a property then this is 'Foo' + member x.PropertyName = let logicalName = x.LogicalName ChopPropertyName logicalName @@ -3209,14 +3600,14 @@ type Val = /// - If this is an active pattern --> |A|_| /// - If this is an operator --> op_Addition /// - If this is an identifier needing backticks --> A-B - member x.DisplayNameCoreMangled = - match x.MemberInfo with - | Some membInfo -> - match membInfo.MemberFlags.MemberKind with - | SynMemberKind.ClassConstructor - | SynMemberKind.Constructor + member x.DisplayNameCoreMangled = + match x.MemberInfo with + | Some membInfo -> + match membInfo.MemberFlags.MemberKind with + | SynMemberKind.ClassConstructor + | SynMemberKind.Constructor | SynMemberKind.Member -> x.LogicalName - | SynMemberKind.PropertyGetSet + | SynMemberKind.PropertyGetSet | SynMemberKind.PropertySet | SynMemberKind.PropertyGet -> x.PropertyName | None -> x.LogicalName @@ -3224,7 +3615,7 @@ type Val = /// The display name of the value or method with operator names decompiled but without backticks etc. /// /// Note: here "Core" means "without added backticks or parens" - member x.DisplayNameCore = + member x.DisplayNameCore = x.DisplayNameCoreMangled |> ConvertValLogicalNameToDisplayNameCore /// The full text for the value to show in error messages and to use in code. @@ -3237,141 +3628,202 @@ type Val = /// - If this is an identifier needing backticks --> ``A-B`` /// - If this is a base value --> base /// - If this is a value named ``base`` --> ``base`` - member x.DisplayName = + member x.DisplayName = ConvertValLogicalNameToDisplayName x.IsBaseVal x.DisplayNameCoreMangled - member x.SetValRec b = x.val_flags <- x.val_flags.WithRecursiveValInfo b + member x.SetValRec b = + x.val_flags <- x.val_flags.WithRecursiveValInfo b - member x.SetIsCompilerGenerated(v) = x.val_flags <- x.val_flags.WithIsCompilerGenerated(v) + member x.SetIsCompilerGenerated(v) = + x.val_flags <- x.val_flags.WithIsCompilerGenerated(v) - member x.SetIsMemberOrModuleBinding() = x.val_flags <- x.val_flags.WithIsMemberOrModuleBinding + member x.SetIsMemberOrModuleBinding() = + x.val_flags <- x.val_flags.WithIsMemberOrModuleBinding - member x.SetMakesNoCriticalTailcalls() = x.val_flags <- x.val_flags.WithMakesNoCriticalTailcalls + member x.SetMakesNoCriticalTailcalls() = + x.val_flags <- x.val_flags.WithMakesNoCriticalTailcalls - member x.SetHasBeenReferenced() = x.val_flags <- x.val_flags.WithHasBeenReferenced + member x.SetHasBeenReferenced() = + x.val_flags <- x.val_flags.WithHasBeenReferenced - member x.SetIsCompiledAsStaticPropertyWithoutField() = x.val_flags <- x.val_flags.WithIsCompiledAsStaticPropertyWithoutField + member x.SetIsCompiledAsStaticPropertyWithoutField() = + x.val_flags <- x.val_flags.WithIsCompiledAsStaticPropertyWithoutField member x.SetIsFixed() = x.val_flags <- x.val_flags.WithIsFixed - member x.SetIgnoresByrefScope() = x.val_flags <- x.val_flags.WithIgnoresByrefScope + member x.SetIgnoresByrefScope() = + x.val_flags <- x.val_flags.WithIgnoresByrefScope - member x.SetInlineIfLambda() = x.val_flags <- x.val_flags.WithInlineIfLambda + member x.SetInlineIfLambda() = + x.val_flags <- x.val_flags.WithInlineIfLambda - member x.SetIsImplied() = x.val_flags <- x.val_flags.WithIsImplied + member x.SetIsImplied() = + x.val_flags <- x.val_flags.WithIsImplied - member x.SetValReprInfo info = + member x.SetValReprInfo info = match x.val_opt_data with | Some optData -> optData.val_repr_info <- info - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_repr_info = info } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_repr_info = info + } - member x.SetValReprInfoForDisplay info = + member x.SetValReprInfoForDisplay info = match x.val_opt_data with | Some optData -> optData.val_repr_info_for_display <- info - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_repr_info_for_display = info } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_repr_info_for_display = info + } member x.SetArgReprInfoForDisplay info = match x.val_opt_data with | Some optData -> optData.arg_repr_info_for_display <- info - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with arg_repr_info_for_display = info } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + arg_repr_info_for_display = info + } member x.SetType ty = x.val_type <- ty member x.SetOtherRange m = match x.val_opt_data with | Some optData -> optData.val_other_range <- Some m - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_other_range = Some m } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_other_range = Some m + } member x.SetOtherXmlDoc xmlDoc = match x.val_opt_data with | Some optData -> optData.val_other_xmldoc <- Some xmlDoc - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_other_xmldoc = Some xmlDoc } - - member x.SetDeclaringEntity parent = + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_other_xmldoc = Some xmlDoc + } + + member x.SetDeclaringEntity parent = match x.val_opt_data with | Some optData -> optData.val_declaring_entity <- parent - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_declaring_entity = parent } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_declaring_entity = parent + } - member x.SetAttribs attribs = + member x.SetAttribs attribs = match x.val_opt_data with | Some optData -> optData.val_attribs <- attribs - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_attribs = attribs } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_attribs = attribs + } - member x.SetMemberInfo member_info = + member x.SetMemberInfo member_info = match x.val_opt_data with | Some optData -> optData.val_member_info <- Some member_info - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_member_info = Some member_info } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_member_info = Some member_info + } - member x.SetValDefn val_defn = + member x.SetValDefn val_defn = match x.val_opt_data with | Some optData -> optData.val_defn <- Some val_defn - | _ -> x.val_opt_data <- Some { Val.NewEmptyValOptData() with val_defn = Some val_defn } + | _ -> + x.val_opt_data <- + Some + { Val.NewEmptyValOptData() with + val_defn = Some val_defn + } /// Create a new value with empty, unlinked data. Only used during unpickling of F# metadata. - static member NewUnlinked() : Val = - { val_logical_name = Unchecked.defaultof<_> - val_range = Unchecked.defaultof<_> - val_type = Unchecked.defaultof<_> - val_stamp = Unchecked.defaultof<_> - val_flags = Unchecked.defaultof<_> - val_opt_data = Unchecked.defaultof<_> } - + static member NewUnlinked() : Val = + { + val_logical_name = Unchecked.defaultof<_> + val_range = Unchecked.defaultof<_> + val_type = Unchecked.defaultof<_> + val_stamp = Unchecked.defaultof<_> + val_flags = Unchecked.defaultof<_> + val_opt_data = Unchecked.defaultof<_> + } /// Create a new value with the given backing data. Only used during unpickling of F# metadata. - static member New data: Val = data + static member New data : Val = data /// Link a value based on empty, unlinked data to the given data. Only used during unpickling of F# metadata. - member x.Link (tg: ValData) = x.SetData tg + member x.Link(tg: ValData) = x.SetData tg /// Set all the data on a value - member x.SetData (tg: ValData) = - x.val_logical_name <- tg.val_logical_name - x.val_range <- tg.val_range - x.val_type <- tg.val_type - x.val_stamp <- tg.val_stamp - x.val_flags <- tg.val_flags + member x.SetData(tg: ValData) = + x.val_logical_name <- tg.val_logical_name + x.val_range <- tg.val_range + x.val_type <- tg.val_type + x.val_stamp <- tg.val_stamp + x.val_flags <- tg.val_flags + match tg.val_opt_data with - | Some tg -> - x.val_opt_data <- - Some { val_compiled_name = tg.val_compiled_name - val_other_range = tg.val_other_range - val_const = tg.val_const - val_defn = tg.val_defn - val_repr_info_for_display = tg.val_repr_info_for_display - arg_repr_info_for_display = tg.arg_repr_info_for_display - val_repr_info = tg.val_repr_info - val_access = tg.val_access - val_xmldoc = tg.val_xmldoc - val_other_xmldoc = tg.val_other_xmldoc - val_member_info = tg.val_member_info - val_declaring_entity = tg.val_declaring_entity - val_xmldocsig = tg.val_xmldocsig - val_attribs = tg.val_attribs } + | Some tg -> + x.val_opt_data <- + Some + { + val_compiled_name = tg.val_compiled_name + val_other_range = tg.val_other_range + val_const = tg.val_const + val_defn = tg.val_defn + val_repr_info_for_display = tg.val_repr_info_for_display + arg_repr_info_for_display = tg.arg_repr_info_for_display + val_repr_info = tg.val_repr_info + val_access = tg.val_access + val_xmldoc = tg.val_xmldoc + val_other_xmldoc = tg.val_other_xmldoc + val_member_info = tg.val_member_info + val_declaring_entity = tg.val_declaring_entity + val_xmldocsig = tg.val_xmldocsig + val_attribs = tg.val_attribs + } | None -> () /// Indicates if a value is linked to backing data yet. Only used during unpickling of F# metadata. - member x.IsLinked = match box x.val_logical_name with null -> false | _ -> true + member x.IsLinked = + match box x.val_logical_name with + | null -> false + | _ -> true [] member x.DebugText = x.ToString() override x.ToString() = x.LogicalName - - + /// Represents the extra information stored for a member [] -type ValMemberInfo = +type ValMemberInfo = { - /// The parent type. For an extension member this is the type being extended - ApparentEnclosingEntity: TyconRef + /// The parent type. For an extension member this is the type being extended + ApparentEnclosingEntity: TyconRef - /// Updated with the full implemented slotsig after interface implementation relation is checked - mutable ImplementedSlotSigs: SlotSig list + /// Updated with the full implemented slotsig after interface implementation relation is checked + mutable ImplementedSlotSigs: SlotSig list - /// Gets updated with 'true' if an abstract slot is implemented in the file being typechecked. Internal only. - mutable IsImplemented: bool + /// Gets updated with 'true' if an abstract slot is implemented in the file being typechecked. Internal only. + mutable IsImplemented: bool - MemberFlags: SynMemberFlags + MemberFlags: SynMemberFlags } [] @@ -3380,13 +3832,13 @@ type ValMemberInfo = override x.ToString() = "ValMemberInfo(...)" [] -type NonLocalValOrMemberRef = +type NonLocalValOrMemberRef = { - /// A reference to the entity containing the value or member. This will always be a non-local reference - EnclosingEntity: EntityRef + /// A reference to the entity containing the value or member. This will always be a non-local reference + EnclosingEntity: EntityRef - /// The name of the value, or the full signature of the member - ItemKey: ValLinkageFullKey + /// The name of the value, or the full signature of the member + ItemKey: ValLinkageFullKey } /// Get the thunk for the assembly referred to @@ -3400,12 +3852,13 @@ type NonLocalValOrMemberRef = member x.DebugText = x.ToString() /// For debugging - override x.ToString() = !! x.EnclosingEntity.nlr.ToString() + "::" + x.ItemKey.PartialKey.LogicalName - + override x.ToString() = + !!x.EnclosingEntity.nlr.ToString() + "::" + x.ItemKey.PartialKey.LogicalName + /// Represents the path information for a reference to a value or member in another assembly, disassociated /// from any particular reference. [] -type ValPublicPath = +type ValPublicPath = | ValPubPath of PublicPath * ValLinkageFullKey [] @@ -3415,15 +3868,16 @@ type ValPublicPath = /// Represents an index into the namespace/module structure of an assembly [] -type NonLocalEntityRef = +type NonLocalEntityRef = | NonLocalEntityRef of CcuThunk * string[] /// Try to find the entity corresponding to the given path in the given CCU - static member TryDerefEntityPath(ccu: CcuThunk, path: string[], i: int, entity: Entity) = - if i >= path.Length then ValueSome entity - else - match entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryGetValue path[i] with - | true, res -> NonLocalEntityRef.TryDerefEntityPath(ccu, path, (i+1), res) + static member TryDerefEntityPath(ccu: CcuThunk, path: string[], i: int, entity: Entity) = + if i >= path.Length then + ValueSome entity + else + match entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryGetValue path[i] with + | true, res -> NonLocalEntityRef.TryDerefEntityPath(ccu, path, (i + 1), res) #if !NO_TYPEPROVIDERS | _ -> NonLocalEntityRef.TryDerefEntityPathViaProvidedType(ccu, path, i, entity) #else @@ -3432,31 +3886,37 @@ type NonLocalEntityRef = #if !NO_TYPEPROVIDERS /// Try to find the entity corresponding to the given path, using type-providers to link the data - static member TryDerefEntityPathViaProvidedType(ccu: CcuThunk, path: string[], i: int, entity: Entity) = + static member TryDerefEntityPathViaProvidedType(ccu: CcuThunk, path: string[], i: int, entity: Entity) = // Errors during linking are not necessarily given good ranges. This has always been the case in F# 2.0, but also applies to // type provider type linking errors in F# 3.0. let m = range0 + match entity.TypeReprInfo with - | TProvidedTypeRepr info -> + | TProvidedTypeRepr info -> let resolutionEnvironment = info.ResolutionEnvironment let st = info.ProvidedType - + // In this case, we're safely in the realm of types. Just iterate through the nested // types until i = path.Length-1. Create the Tycon's as needed - let rec tryResolveNestedTypeOf(parentEntity: Entity, resolutionEnvironment, st: Tainted, i) = + let rec tryResolveNestedTypeOf (parentEntity: Entity, resolutionEnvironment, st: Tainted, i) = match st.PApply((fun st -> st.GetNestedType path[i]), m) with | Tainted.Null -> ValueNone - | Tainted.NonNull st -> - let newEntity = Construct.NewProvidedTycon(resolutionEnvironment, st, ccu.ImportProvidedType, false, m) + | Tainted.NonNull st -> + let newEntity = + Construct.NewProvidedTycon(resolutionEnvironment, st, ccu.ImportProvidedType, false, m) + parentEntity.ModuleOrNamespaceType.AddProvidedTypeEntity newEntity - if i = path.Length-1 then ValueSome newEntity - else tryResolveNestedTypeOf(newEntity, resolutionEnvironment, st, i+1) - tryResolveNestedTypeOf(entity, resolutionEnvironment, st, i) + if i = path.Length - 1 then + ValueSome newEntity + else + tryResolveNestedTypeOf (newEntity, resolutionEnvironment, st, i + 1) - | TProvidedNamespaceRepr(resolutionEnvironment, resolvers) -> + tryResolveNestedTypeOf (entity, resolutionEnvironment, st, i) - // In this case, we're still in the realm of extensible namespaces. + | TProvidedNamespaceRepr(resolutionEnvironment, resolvers) -> + + // In this case, we're still in the realm of extensible namespaces. // <----entity--> // 0 .........i-1..i .......... j ..... path.Length-1 // @@ -3466,177 +3926,217 @@ type NonLocalEntityRef = // <----entity--> <---resolver----> <--loop---> // 0 .........i-1..i ............. j ..... path.Length-1 // - // We now query the resolvers with - // moduleOrNamespace = path.[0..j-1] - // typeName = path.[j] + // We now query the resolvers with + // moduleOrNamespace = path.[0..j-1] + // typeName = path.[j] // starting with j = i and then progressively increasing j - + // This function queries at 'j' - let tryResolvePrefix j = + let tryResolvePrefix j = assert (j >= 0) assert (j <= path.Length - 1) - let matched = - [ for resolver in resolvers do - let moduleOrNamespace = if j = 0 then [| |] else path[0..j-1] - let typename = path[j] - let resolution = TryLinkProvidedType(resolver, moduleOrNamespace, typename, m) - match resolution with - | None -> () - | Some st -> - match st with - | Tainted.Null -> () - | Tainted.NonNull st -> yield (resolver, st) ] + + let matched = + [ + for resolver in resolvers do + let moduleOrNamespace = if j = 0 then [||] else path[0 .. j - 1] + let typename = path[j] + let resolution = TryLinkProvidedType(resolver, moduleOrNamespace, typename, m) + + match resolution with + | None -> () + | Some st -> + match st with + | Tainted.Null -> () + | Tainted.NonNull st -> yield (resolver, st) + ] + match matched with - | [(_, st)] -> + | [ (_, st) ] -> // 'entity' is at position i in the dereference chain. We resolved to position 'j'. // Inject namespaces until we're an position j, and then inject the type. // Note: this is similar to code in CompileOps.fs - let rec injectNamespacesFromIToJ (entity: Entity) k = - if k = j then - let newEntity = Construct.NewProvidedTycon(resolutionEnvironment, st, ccu.ImportProvidedType, false, m) + let rec injectNamespacesFromIToJ (entity: Entity) k = + if k = j then + let newEntity = + Construct.NewProvidedTycon(resolutionEnvironment, st, ccu.ImportProvidedType, false, m) + entity.ModuleOrNamespaceType.AddProvidedTypeEntity newEntity newEntity else - let cpath = entity.CompilationPath.NestedCompPath entity.LogicalName (ModuleOrNamespaceKind.Namespace false) - let newEntity = - Construct.NewModuleOrNamespace - (Some cpath) - (TAccess []) (ident(path[k], m)) XmlDoc.Empty [] - (MaybeLazy.Strict (Construct.NewEmptyModuleOrNamespaceType (Namespace true))) + let cpath = + entity.CompilationPath.NestedCompPath entity.LogicalName (ModuleOrNamespaceKind.Namespace false) + + let newEntity = + Construct.NewModuleOrNamespace + (Some cpath) + (TAccess []) + (ident (path[k], m)) + XmlDoc.Empty + [] + (MaybeLazy.Strict(Construct.NewEmptyModuleOrNamespaceType(Namespace true))) + entity.ModuleOrNamespaceType.AddModuleOrNamespaceByMutation newEntity - injectNamespacesFromIToJ newEntity (k+1) + injectNamespacesFromIToJ newEntity (k + 1) + let newEntity = injectNamespacesFromIToJ entity i - + // newEntity is at 'j' - NonLocalEntityRef.TryDerefEntityPath(ccu, path, (j+1), newEntity) + NonLocalEntityRef.TryDerefEntityPath(ccu, path, (j + 1), newEntity) - | [] -> ValueNone + | [] -> ValueNone | _ -> failwith "Unexpected" - let rec tryResolvePrefixes j = - if j >= path.Length then ValueNone - else match tryResolvePrefix j with - | ValueNone -> tryResolvePrefixes (j+1) - | ValueSome res -> ValueSome res + let rec tryResolvePrefixes j = + if j >= path.Length then + ValueNone + else + match tryResolvePrefix j with + | ValueNone -> tryResolvePrefixes (j + 1) + | ValueSome res -> ValueSome res tryResolvePrefixes i | _ -> ValueNone #endif - + /// Try to link a non-local entity reference to an actual entity - member nleref.TryDeref canError = - let (NonLocalEntityRef(ccu, path)) = nleref - if canError then + member nleref.TryDeref canError = + let (NonLocalEntityRef(ccu, path)) = nleref + + if canError then ccu.EnsureDerefable path - if ccu.IsUnresolvedReference then ValueNone else + if ccu.IsUnresolvedReference then + ValueNone + else + + match NonLocalEntityRef.TryDerefEntityPath(ccu, path, 0, ccu.Contents) with + | ValueSome _ as r -> r + | ValueNone -> + // OK, the lookup failed. Check if we can redirect through a type forwarder on this assembly. + // Look for a forwarder for each prefix-path + let rec tryForwardPrefixPath i = + if i < path.Length then + match ccu.TryForward(path[0 .. i - 1], path[i]) with + // OK, found a forwarder, now continue with the lookup to find the nested type + | Some tcref -> NonLocalEntityRef.TryDerefEntityPath(ccu, path, (i + 1), tcref.Deref) + | None -> tryForwardPrefixPath (i + 1) + else + ValueNone + + tryForwardPrefixPath 0 - match NonLocalEntityRef.TryDerefEntityPath(ccu, path, 0, ccu.Contents) with - | ValueSome _ as r -> r - | ValueNone -> - // OK, the lookup failed. Check if we can redirect through a type forwarder on this assembly. - // Look for a forwarder for each prefix-path - let rec tryForwardPrefixPath i = - if i < path.Length then - match ccu.TryForward(path[0..i-1], path[i]) with - // OK, found a forwarder, now continue with the lookup to find the nested type - | Some tcref -> NonLocalEntityRef.TryDerefEntityPath(ccu, path, (i+1), tcref.Deref) - | None -> tryForwardPrefixPath (i+1) - else - ValueNone - tryForwardPrefixPath 0 - /// Get the CCU referenced by the nonlocal reference. member nleref.Ccu = - let (NonLocalEntityRef(ccu, _)) = nleref + let (NonLocalEntityRef(ccu, _)) = nleref ccu /// Get the path into the CCU referenced by the nonlocal reference. member nleref.Path = - let (NonLocalEntityRef(_, p)) = nleref + let (NonLocalEntityRef(_, p)) = nleref p - member nleref.DisplayName = - String.concat "." nleref.Path + member nleref.DisplayName = String.concat "." nleref.Path /// Get the mangled name of the last item in the path of the nonlocal reference. - member nleref.LastItemMangledName = + member nleref.LastItemMangledName = let p = nleref.Path - p[p.Length-1] + p[p.Length - 1] /// Get the all-but-last names of the path of the nonlocal reference. - member nleref.EnclosingMangledPath = + member nleref.EnclosingMangledPath = let p = nleref.Path - p[0..p.Length-2] - + p[0 .. p.Length - 2] + /// Get the name of the assembly referenced by the nonlocal reference. member nleref.AssemblyName = nleref.Ccu.AssemblyName /// Dereference the nonlocal reference, and raise an error if this fails. - member nleref.Deref = - match nleref.TryDeref(canError=true) with + member nleref.Deref = + match nleref.TryDeref(canError = true) with | ValueSome res -> res - | ValueNone -> - errorR (InternalUndefinedItemRef (FSComp.SR.tastUndefinedItemRefModuleNamespace, nleref.DisplayName, nleref.AssemblyName, "")) - raise (KeyNotFoundException()) + | ValueNone -> + errorR ( + InternalUndefinedItemRef( + FSComp.SR.tastUndefinedItemRefModuleNamespace, + nleref.DisplayName, + nleref.AssemblyName, + "" + ) + ) + + raise (KeyNotFoundException()) [] member x.DebugText = x.ToString() override x.ToString() = x.DisplayName - + [] -type EntityRef = +type EntityRef = { - /// Indicates a reference to something bound in this CCU - mutable binding: NonNullSlot + /// Indicates a reference to something bound in this CCU + mutable binding: NonNullSlot - /// Indicates a reference to something bound in another CCU - nlr: NonLocalEntityRef + /// Indicates a reference to something bound in another CCU + nlr: NonLocalEntityRef } /// Indicates if the reference is a local reference - member x.IsLocalRef = match box x.nlr with null -> true | _ -> false + member x.IsLocalRef = + match box x.nlr with + | null -> true + | _ -> false /// Indicates if the reference has been resolved - member x.IsResolved = match box x.binding with null -> false | _ -> true + member x.IsResolved = + match box x.binding with + | null -> false + | _ -> true /// The resolved target of the reference member x.ResolvedTarget = x.binding /// Resolve the reference - member private tcr.Resolve canError = + member private tcr.Resolve canError = let res = tcr.nlr.TryDeref canError - match res with - | ValueSome r -> - tcr.binding <- nullableSlotFull r - | ValueNone -> - () + + match res with + | ValueSome r -> tcr.binding <- nullableSlotFull r + | ValueNone -> () /// Dereference the TyconRef to a Tycon. Amortize the cost of doing this. /// This path should not allocate in the amortized case - member tcr.Deref = - match box tcr.binding with + member tcr.Deref = + match box tcr.binding with | null -> - tcr.Resolve(canError=true) - match box tcr.binding with - | null -> error (InternalUndefinedItemRef (FSComp.SR.tastUndefinedItemRefModuleNamespaceType, String.concat "." tcr.nlr.EnclosingMangledPath, tcr.nlr.AssemblyName, tcr.nlr.LastItemMangledName)) + tcr.Resolve(canError = true) + + match box tcr.binding with + | null -> + error ( + InternalUndefinedItemRef( + FSComp.SR.tastUndefinedItemRefModuleNamespaceType, + String.concat "." tcr.nlr.EnclosingMangledPath, + tcr.nlr.AssemblyName, + tcr.nlr.LastItemMangledName + ) + ) | _ -> tcr.binding - | _ -> - tcr.binding + | _ -> tcr.binding /// Dereference the TyconRef to a Tycon option. - member tcr.TryDeref = - match box tcr.binding with - | null -> - tcr.Resolve(canError=false) - match box tcr.binding with + member tcr.TryDeref = + match box tcr.binding with + | null -> + tcr.Resolve(canError = false) + + match box tcr.binding with | null -> ValueNone | _ -> ValueSome tcr.binding - | _ -> - ValueSome tcr.binding + | _ -> ValueSome tcr.binding /// Is the destination assembly available? member tcr.CanDeref = tcr.TryDeref.IsSome @@ -3645,7 +4145,8 @@ type EntityRef = member x.CompiledRepresentation = x.Deref.CompiledRepresentation /// Gets the data indicating the compiled representation of a named type or module in terms of Abstract IL data structures. - member x.CompiledRepresentationForNamedType = x.Deref.CompiledRepresentationForNamedType + member x.CompiledRepresentationForNamedType = + x.Deref.CompiledRepresentationForNamedType /// The implementation definition location of the namespace, module or type member x.DefinitionRange = x.Deref.DefinitionRange @@ -3653,10 +4154,10 @@ type EntityRef = /// The signature definition location of the namespace, module or type member x.SigRange = x.Deref.SigRange - /// The name of the namespace, module or type, possibly with mangling, e.g. List`1, List or FailureException + /// The name of the namespace, module or type, possibly with mangling, e.g. List`1, List or FailureException member x.LogicalName = x.Deref.LogicalName - /// The compiled name of the namespace, module or type, e.g. FSharpList`1, ListModule or FailureException + /// The compiled name of the namespace, module or type, e.g. FSharpList`1, ListModule or FailureException member x.CompiledName = x.Deref.CompiledName /// The display name of the namespace, module or type, e.g. List instead of List`1, not including static parameters @@ -3672,7 +4173,8 @@ type EntityRef = /// The display name of the namespace, module or type with <_, _, _> added for generic types, including static parameters /// /// Backticks are added implicitly for entities with non-identifier names - member x.DisplayNameWithStaticParametersAndUnderscoreTypars = x.Deref.DisplayNameWithStaticParametersAndUnderscoreTypars + member x.DisplayNameWithStaticParametersAndUnderscoreTypars = + x.Deref.DisplayNameWithStaticParametersAndUnderscoreTypars /// The display name of the namespace, module or type, e.g. List instead of List`1, including static parameters /// @@ -3682,8 +4184,8 @@ type EntityRef = /// The code location where the module, namespace or type is defined. member x.Range = x.Deref.Range - /// A unique stamp for this module, namespace or type definition within the context of this compilation. - /// Note that because of signatures, there are situations where in a single compilation the "same" + /// A unique stamp for this module, namespace or type definition within the context of this compilation. + /// Note that because of signatures, there are situations where in a single compilation the "same" /// module, namespace or type may have two distinct Entity objects that have distinct stamps. member x.Stamp = x.Deref.Stamp @@ -3693,17 +4195,17 @@ type EntityRef = /// The XML documentation of the entity, if any. If the entity is backed by provided metadata /// then this _does_ include this documentation. If the entity is backed by Abstract IL metadata - /// or comes from another F# assembly then it does not (because the documentation will get read from + /// or comes from another F# assembly then it does not (because the documentation will get read from /// an XML file). member x.XmlDoc = if not (x.Deref.XmlDoc.IsEmpty) then - x.Deref.XmlDoc + x.Deref.XmlDoc else x.Deref.entity_opt_data |> Option.bind (fun d -> d.entity_other_xmldoc) |> Option.defaultValue XmlDoc.Empty - - member x.SetOtherXmlDoc (xmlDoc: XmlDoc) = x.Deref.SetOtherXmlDoc(xmlDoc) + + member x.SetOtherXmlDoc(xmlDoc: XmlDoc) = x.Deref.SetOtherXmlDoc(xmlDoc) /// The XML documentation sig-string of the entity, if any, to use to lookup an .xml doc file. This also acts /// as a cache for this sig-string computation. @@ -3711,7 +4213,7 @@ type EntityRef = /// The logical contents of the entity when it is a module or namespace fragment. member x.ModuleOrNamespaceType = x.Deref.ModuleOrNamespaceType - + /// Demangle the module name, if FSharpModuleWithSuffix is used member x.DemangledModuleOrNamespaceName = x.Deref.DemangledModuleOrNamespaceName @@ -3727,14 +4229,14 @@ type EntityRef = /// The information about the r.h.s. of a type definition, if any. For example, the r.h.s. of a union or record type. member x.TypeReprInfo = x.Deref.TypeReprInfo - /// The information about the r.h.s. of an F# exception definition, if any. + /// The information about the r.h.s. of an F# exception definition, if any. member x.ExceptionInfo = x.Deref.ExceptionInfo /// Indicates if the entity represents an F# exception declaration. member x.IsFSharpException = x.Deref.IsFSharpException - + /// Get the type parameters for an entity that is a type declaration, otherwise return the empty list. - /// + /// /// Lazy because it may read metadata, must provide a context "range" in case error occurs reading metadata. member x.Typars m = x.Deref.Typars m @@ -3759,10 +4261,10 @@ type EntityRef = /// Get the value representing the accessibility of an F# type definition or module. member x.Accessibility = x.Deref.Accessibility - /// Indicates the type prefers the "tycon" syntax for display etc. + /// Indicates the type prefers the "tycon" syntax for display etc. member x.IsPrefixDisplay = x.Deref.IsPrefixDisplay - /// Indicates the "tycon blob" is actually a module + /// Indicates the "tycon blob" is actually a module member x.IsModuleOrNamespace = x.Deref.IsModuleOrNamespace /// Indicates if the entity is a namespace @@ -3843,7 +4345,8 @@ type EntityRef = member x.ImmediateInterfacesOfFSharpTycon = x.Deref.ImmediateInterfacesOfFSharpTycon /// Gets the immediate interface types of an F# type definition. Further interfaces may be supported through class and interface inheritance. - member x.ImmediateInterfaceTypesOfFSharpTycon = x.Deref.ImmediateInterfaceTypesOfFSharpTycon + member x.ImmediateInterfaceTypesOfFSharpTycon = + x.Deref.ImmediateInterfaceTypesOfFSharpTycon /// Gets the immediate members of an F# type definition, excluding compiler-generated ones. /// Note: result is alphabetically sorted, then for each name the results are in declaration order @@ -3856,7 +4359,7 @@ type EntityRef = /// Indicates if this is a struct or enum type definition, i.e. a value type definition, including struct records and unions member x.IsStructOrEnumTycon = x.Deref.IsStructOrEnumTycon - /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses + /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses /// an assembly-code representation for the type, e.g. the primitive array type constructor. member x.IsAsmReprTycon = x.Deref.IsAsmReprTycon @@ -3866,23 +4369,25 @@ type EntityRef = /// Indicates if the entity is erased, either a measure definition, or an erased provided type definition member x.IsErased = x.Deref.IsErased - + /// Gets any implicit hash/equals (with comparer argument) methods added to an F# record, union or struct type definition. - member x.GeneratedHashAndEqualsWithComparerValues = x.Deref.GeneratedHashAndEqualsWithComparerValues + member x.GeneratedHashAndEqualsWithComparerValues = + x.Deref.GeneratedHashAndEqualsWithComparerValues /// Gets any implicit CompareTo (with comparer argument) methods added to an F# record, union or struct type definition. - member x.GeneratedCompareToWithComparerValues = x.Deref.GeneratedCompareToWithComparerValues + member x.GeneratedCompareToWithComparerValues = + x.Deref.GeneratedCompareToWithComparerValues /// Gets any implicit CompareTo methods added to an F# record, union or struct type definition. member x.GeneratedCompareToValues = x.Deref.GeneratedCompareToValues /// Gets any implicit hash/equals methods added to an F# record, union or struct type definition. member x.GeneratedHashAndEqualsValues = x.Deref.GeneratedHashAndEqualsValues - + /// Indicate if this is a type definition backed by Abstract IL metadata. member x.IsILTycon = x.Deref.IsILTycon - /// Get the Abstract IL scope, nesting and metadata for this + /// Get the Abstract IL scope, nesting and metadata for this /// type definition, assuming it is backed by Abstract IL metadata. member x.ILTyconInfo = x.Deref.ILTyconInfo @@ -3922,19 +4427,19 @@ type EntityRef = /// which in F# is called a 'unknown representation' type). member x.IsHiddenReprTycon = x.Deref.IsHiddenReprTycon - /// Indicates if this is an F#-defined interface type definition + /// Indicates if this is an F#-defined interface type definition member x.IsFSharpInterfaceTycon = x.Deref.IsFSharpInterfaceTycon - /// Indicates if this is an F#-defined delegate type definition + /// Indicates if this is an F#-defined delegate type definition member x.IsFSharpDelegateTycon = x.Deref.IsFSharpDelegateTycon - /// Indicates if this is an F#-defined enum type definition + /// Indicates if this is an F#-defined enum type definition member x.IsFSharpEnumTycon = x.Deref.IsFSharpEnumTycon - /// Indicates if this is a .NET-defined enum type definition + /// Indicates if this is a .NET-defined enum type definition member x.IsILEnumTycon = x.Deref.IsILEnumTycon - /// Indicates if this is an enum type definition + /// Indicates if this is an enum type definition member x.IsEnumTycon = x.Deref.IsEnumTycon /// Indicates if this is an F#-defined value type definition, including struct records and unions @@ -3944,29 +4449,31 @@ type EntityRef = member x.IsILStructOrEnumTycon = x.Deref.IsILStructOrEnumTycon /// Indicates if we have pre-determined that a type definition has a default constructor. - member x.PreEstablishedHasDefaultConstructor = x.Deref.PreEstablishedHasDefaultConstructor + member x.PreEstablishedHasDefaultConstructor = + x.Deref.PreEstablishedHasDefaultConstructor /// Indicates if we have pre-determined that a type definition has a self-referential constructor using 'as x' member x.HasSelfReferentialConstructor = x.Deref.HasSelfReferentialConstructor member x.UnionCasesAsRefList = x.UnionCasesAsList |> List.map x.MakeNestedUnionCaseRef - member x.TrueInstanceFieldsAsRefList = x.TrueInstanceFieldsAsList |> List.map x.MakeNestedRecdFieldRef + member x.TrueInstanceFieldsAsRefList = + x.TrueInstanceFieldsAsList |> List.map x.MakeNestedRecdFieldRef member x.AllFieldAsRefList = x.AllFieldsAsList |> List.map x.MakeNestedRecdFieldRef - member x.MakeNestedRecdFieldRef (rf: RecdField) = RecdFieldRef (x, rf.LogicalName) + member x.MakeNestedRecdFieldRef(rf: RecdField) = RecdFieldRef(x, rf.LogicalName) - member x.MakeNestedUnionCaseRef (uc: UnionCase) = UnionCaseRef (x, uc.Id.idText) + member x.MakeNestedUnionCaseRef(uc: UnionCase) = UnionCaseRef(x, uc.Id.idText) [] member x.DebugText = x.ToString() - override x.ToString() = - if x.IsLocalRef then - x.ResolvedTarget.DisplayName - else - x.nlr.DisplayName + override x.ToString() = + if x.IsLocalRef then + x.ResolvedTarget.DisplayName + else + x.nlr.DisplayName /// Represents a module-or-namespace reference in the typed abstract syntax. type ModuleOrNamespaceRef = EntityRef @@ -3976,13 +4483,13 @@ type TyconRef = EntityRef /// References are either local or nonlocal [] -type ValRef = +type ValRef = { - /// Indicates a reference to something bound in this CCU - mutable binding: NonNullSlot + /// Indicates a reference to something bound in this CCU + mutable binding: NonNullSlot - /// Indicates a reference to something bound in another CCU - nlr: NonLocalValOrMemberRef + /// Indicates a reference to something bound in another CCU + nlr: NonLocalValOrMemberRef } member x.IsLocalRef = obj.ReferenceEquals(x.nlr, null) @@ -3992,35 +4499,50 @@ type ValRef = member x.ResolvedTarget = x.binding /// Dereference the ValRef to a Val. - member x.Deref = + member x.Deref = if obj.ReferenceEquals(x.binding, null) then - let res = - let nlr = x.nlr - let e = nlr.EnclosingEntity.Deref - let possible = e.ModuleOrNamespaceType.TryLinkVal(nlr.EnclosingEntity.nlr.Ccu, nlr.ItemKey) - match possible with - | ValueNone -> error (InternalUndefinedItemRef (FSComp.SR.tastUndefinedItemRefVal, e.DisplayNameWithStaticParameters, nlr.AssemblyName, sprintf "%+A" nlr.ItemKey.PartialKey)) + let res = + let nlr = x.nlr + let e = nlr.EnclosingEntity.Deref + + let possible = + e.ModuleOrNamespaceType.TryLinkVal(nlr.EnclosingEntity.nlr.Ccu, nlr.ItemKey) + + match possible with + | ValueNone -> + error ( + InternalUndefinedItemRef( + FSComp.SR.tastUndefinedItemRefVal, + e.DisplayNameWithStaticParameters, + nlr.AssemblyName, + sprintf "%+A" nlr.ItemKey.PartialKey + ) + ) | ValueSome h -> h - x.binding <- nullableSlotFull res - res - else x.binding + + x.binding <- nullableSlotFull res + res + else + x.binding /// Dereference the ValRef to a Val option. - member x.TryDeref = + member x.TryDeref = if obj.ReferenceEquals(x.binding, null) then - let resOpt = - match x.nlr.EnclosingEntity.TryDeref with + let resOpt = + match x.nlr.EnclosingEntity.TryDeref with | ValueNone -> ValueNone | ValueSome e -> e.ModuleOrNamespaceType.TryLinkVal(x.nlr.EnclosingEntity.nlr.Ccu, x.nlr.ItemKey) - match resOpt with + + match resOpt with | ValueNone -> () - | ValueSome res -> - x.binding <- nullableSlotFull res + | ValueSome res -> x.binding <- nullableSlotFull res + resOpt - else ValueSome x.binding + else + ValueSome x.binding - /// The type of the value. May be a TType_forall for a generic value. - /// May be a type variable or type containing type variables during type inference. + /// The type of the value. May be a TType_forall for a generic value. + /// May be a type variable or type containing type variables during type inference. member x.Type = x.Deref.Type /// Get the type of the value including any generic type parameters @@ -4056,29 +4578,33 @@ type ValRef = member x.SigRange = x.Deref.SigRange - /// The value of a value or member marked with [] + /// The value of a value or member marked with [] member x.LiteralValue = x.Deref.LiteralValue member x.Id = x.Deref.Id /// Get the name of the value, assuming it is compiled as a property. - /// - If this is a property then this is 'Foo' + /// - If this is a property then this is 'Foo' /// - If this is an implementation of an abstract slot then this is the name of the property implemented by the abstract slot member x.PropertyName = x.Deref.PropertyName /// Indicates whether this value represents a property getter. - member x.IsPropertyGetterMethod = + member x.IsPropertyGetterMethod = match x.MemberInfo with | None -> false - | Some (memInfo: ValMemberInfo) -> memInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGet || memInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGetSet + | Some(memInfo: ValMemberInfo) -> + memInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGet + || memInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGetSet /// Indicates whether this value represents a property setter. - member x.IsPropertySetterMethod = + member x.IsPropertySetterMethod = match x.MemberInfo with | None -> false - | Some (memInfo: ValMemberInfo) -> memInfo.MemberFlags.MemberKind = SynMemberKind.PropertySet || memInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGetSet + | Some(memInfo: ValMemberInfo) -> + memInfo.MemberFlags.MemberKind = SynMemberKind.PropertySet + || memInfo.MemberFlags.MemberKind = SynMemberKind.PropertyGetSet - /// A unique stamp within the context of this invocation of the compiler process + /// A unique stamp within the context of this invocation of the compiler process member x.Stamp = x.Deref.Stamp /// Is this represented as a "top level" static binding (i.e. a static field, static member, @@ -4116,7 +4642,7 @@ type ValRef = /// Indicates if this is an F#-defined value in a module, or an extension member, but excluding compiler generated bindings from optimizations member x.IsModuleBinding = x.Deref.IsModuleBinding - /// Indicates if this is an F#-defined instance member. + /// Indicates if this is an F#-defined instance member. /// /// Note, the value may still be (a) an extension member or (b) and abstract slot without /// a true body. These cases are often causes of bugs in the compiler. @@ -4210,13 +4736,15 @@ type ValRef = [] member x.DebugText = x.ToString() - override x.ToString() = - if x.IsLocalRef then x.ResolvedTarget.DisplayName - else x.nlr.ToString() + override x.ToString() = + if x.IsLocalRef then + x.ResolvedTarget.DisplayName + else + x.nlr.ToString() /// Represents a reference to a case of a union type [] -type UnionCaseRef = +type UnionCaseRef = | UnionCaseRef of tyconRef: TyconRef * caseName: string /// Get a reference to the type containing this union case @@ -4229,14 +4757,14 @@ type UnionCaseRef = member x.Tycon = x.TyconRef.Deref /// Dereference the reference to the union case - member x.UnionCase = - match x.TyconRef.GetUnionCaseByName x.CaseName with + member x.UnionCase = + match x.TyconRef.GetUnionCaseByName x.CaseName with | Some res -> res - | None -> error(InternalError(sprintf "union case %s not found in type %s" x.CaseName x.TyconRef.LogicalName, x.TyconRef.Range)) + | None -> error (InternalError(sprintf "union case %s not found in type %s" x.CaseName x.TyconRef.LogicalName, x.TyconRef.Range)) - /// Try to dereference the reference + /// Try to dereference the reference member x.TryUnionCase = - x.TyconRef.TryDeref + x.TyconRef.TryDeref |> ValueOption.bind (fun tcref -> tcref.GetUnionCaseByName x.CaseName |> ValueOption.ofOption) /// Get the attributes associated with the union case @@ -4252,12 +4780,13 @@ type UnionCaseRef = member x.SigRange = x.UnionCase.SigRange /// Get the index of the union case amongst the cases - member x.Index = - try - // REVIEW: this could be faster, e.g. by storing the index in the NameMap - x.TyconRef.UnionCasesArray |> Array.findIndex (fun uc -> uc.LogicalName = x.CaseName) - with :? KeyNotFoundException -> - error(InternalError(sprintf "union case %s not found in type %s" x.CaseName x.TyconRef.LogicalName, x.TyconRef.Range)) + member x.Index = + try + // REVIEW: this could be faster, e.g. by storing the index in the NameMap + x.TyconRef.UnionCasesArray + |> Array.findIndex (fun uc -> uc.LogicalName = x.CaseName) + with :? KeyNotFoundException -> + error (InternalError(sprintf "union case %s not found in type %s" x.CaseName x.TyconRef.LogicalName, x.TyconRef.Range)) /// Get the fields of the union case member x.AllFieldsAsList = x.UnionCase.FieldTable.AllFieldsAsList @@ -4273,22 +4802,32 @@ type UnionCaseRef = override x.ToString() = x.CaseName -let findLogicalFieldIndexOfRecordField (tcref:TyconRef) (id:string) = +let findLogicalFieldIndexOfRecordField (tcref: TyconRef) (id: string) = let arr = tcref.AllFieldsArray // We are skipping compiler generated fields such as "init@5" from index calculation let rec go originalIdx skippedItems = - if originalIdx >= arr.Length then error(InternalError(sprintf "field %s not found in type %s" id tcref.LogicalName, tcref.Range)) + if originalIdx >= arr.Length then + error (InternalError(sprintf "field %s not found in type %s" id tcref.LogicalName, tcref.Range)) else let currentItem = arr[originalIdx] - if currentItem.LogicalName = id then (originalIdx-skippedItems) - else go (originalIdx + 1) (skippedItems + (if currentItem.IsCompilerGenerated && currentItem.IsStatic then 1 else 0)) + + if currentItem.LogicalName = id then + (originalIdx - skippedItems) + else + go + (originalIdx + 1) + (skippedItems + + (if currentItem.IsCompilerGenerated && currentItem.IsStatic then + 1 + else + 0)) go 0 0 /// Represents a reference to a field in a record, class or struct [] -type RecdFieldRef = +type RecdFieldRef = | RecdFieldRef of tyconRef: TyconRef * fieldName: string /// Get a reference to the type containing this record field @@ -4303,96 +4842,104 @@ type RecdFieldRef = /// Get the Entity for the type containing this record field member x.Tycon = x.TyconRef.Deref - /// Dereference the reference - member x.RecdField = + /// Dereference the reference + member x.RecdField = let (RecdFieldRef(tcref, id)) = x - match tcref.GetFieldByName id with + + match tcref.GetFieldByName id with | Some res -> res - | None -> error(InternalError(sprintf "field %s not found in type %s" id tcref.LogicalName, tcref.Range)) + | None -> error (InternalError(sprintf "field %s not found in type %s" id tcref.LogicalName, tcref.Range)) - /// Try to dereference the reference - member x.TryRecdField = - x.TyconRef.TryDeref + /// Try to dereference the reference + member x.TryRecdField = + x.TyconRef.TryDeref |> ValueOption.bind (fun tcref -> tcref.GetFieldByName x.FieldName |> ValueOption.ofOption) - /// Get the attributes associated with the compiled property of the record field + /// Get the attributes associated with the compiled property of the record field member x.PropertyAttribs = x.RecdField.PropertyAttribs - /// Get the declaration range of the record field + /// Get the declaration range of the record field member x.Range = x.RecdField.Range - /// Get the definition range of the record field + /// Get the definition range of the record field member x.DefinitionRange = x.RecdField.DefinitionRange - /// Get the signature range of the record field + /// Get the signature range of the record field member x.SigRange = x.RecdField.SigRange member x.Index = let (RecdFieldRef(tcref, id)) = x findLogicalFieldIndexOfRecordField tcref id - [] member x.DebugText = x.ToString() override x.ToString() = x.FieldName -[] -type Nullness = - | Known of NullnessInfo - | Variable of NullnessVar - - member n.Evaluate() = - match n with - | Known info -> info - | Variable v -> v.Evaluate() - - member n.TryEvaluate() = - match n with - | Known info -> ValueSome info - | Variable v -> v.TryEvaluate() - - override n.ToString() = match n.Evaluate() with NullnessInfo.WithNull -> "?" | NullnessInfo.WithoutNull -> "" | NullnessInfo.AmbivalentToNull -> "%" - - member n.ToFsharpCodeString() = match n.Evaluate() with NullnessInfo.WithNull -> " | null " | NullnessInfo.WithoutNull -> "" | NullnessInfo.AmbivalentToNull -> "" +[] +type Nullness = + | Known of NullnessInfo + | Variable of NullnessVar + + member n.Evaluate() = + match n with + | Known info -> info + | Variable v -> v.Evaluate() + + member n.TryEvaluate() = + match n with + | Known info -> ValueSome info + | Variable v -> v.TryEvaluate() + + override n.ToString() = + match n.Evaluate() with + | NullnessInfo.WithNull -> "?" + | NullnessInfo.WithoutNull -> "" + | NullnessInfo.AmbivalentToNull -> "%" + + member n.ToFsharpCodeString() = + match n.Evaluate() with + | NullnessInfo.WithNull -> " | null " + | NullnessInfo.WithoutNull -> "" + | NullnessInfo.AmbivalentToNull -> "" // Note, nullness variables are only created if the nullness checking feature is on -[] -type NullnessVar() = +[] +type NullnessVar() = let mutable solution: Nullness option = None - member nv.Evaluate() = - match solution with - | None -> NullnessInfo.WithoutNull - | Some soln -> soln.Evaluate() + member nv.Evaluate() = + match solution with + | None -> NullnessInfo.WithoutNull + | Some soln -> soln.Evaluate() - member nv.TryEvaluate() = - match solution with - | None -> ValueNone - | Some soln -> soln.TryEvaluate() + member nv.TryEvaluate() = + match solution with + | None -> ValueNone + | Some soln -> soln.TryEvaluate() member nv.IsSolved = solution.IsSome - member nv.IsFullySolved = + member nv.IsFullySolved = match solution with | None -> false - | Some (Nullness.Known _) -> true - | Some (Nullness.Variable v) -> v.IsFullySolved + | Some(Nullness.Known _) -> true + | Some(Nullness.Variable v) -> v.IsFullySolved - member nv.Set(nullness) = - assert (not nv.IsSolved) - solution <- Some nullness + member nv.Set(nullness) = + assert (not nv.IsSolved) + solution <- Some nullness - member nv.Unset() = - assert nv.IsSolved - solution <- None + member nv.Unset() = + assert nv.IsSolved + solution <- None - member nv.Solution = - assert nv.IsSolved - solution.Value + member nv.Solution = + assert nv.IsSolved + solution.Value [] -type NullnessInfo = +type NullnessInfo = /// we know that there is an extra null value in the type | WithNull @@ -4407,7 +4954,7 @@ type NullnessInfo = [] type TType = - /// Indicates the type is a universal type, only used for types of values and members + /// Indicates the type is a universal type, only used for types of values and members | TType_forall of typars: Typars * bodyTy: TType /// TType_app(tyconRef, typeInstantiation, nullness). @@ -4423,7 +4970,7 @@ type TType = /// TType_fun(domainType, rangeType, nullness). /// - /// Indicates the type is a function type + /// Indicates the type is a function type | TType_fun of domainType: TType * rangeType: TType * nullness: Nullness /// Indicates the type is a non-F#-visible type representing a "proof" that a union value belongs to a particular union case @@ -4431,7 +4978,7 @@ type TType = /// the temporaries arising out of pattern matching on union values. | TType_ucase of unionCaseRef: UnionCaseRef * typeInstantiation: TypeInst - /// Indicates the type is a variable type, whether declared, generalized or an inference type parameter + /// Indicates the type is a variable type, whether declared, generalized or an inference type parameter | TType_var of typar: Typar * nullness: Nullness /// Indicates the type is a unit-of-measure expression being used as an argument to a type or member @@ -4441,66 +4988,83 @@ type TType = /// See https://github.com/dotnet/fsharp/issues/2561 member x.GetAssemblyName() = match x with - | TType_forall (_tps, ty) -> ty.GetAssemblyName() - | TType_app (tcref, _tinst, _) -> tcref.CompilationPath.ILScopeRef.QualifiedName + | TType_forall(_tps, ty) -> ty.GetAssemblyName() + | TType_app(tcref, _tinst, _) -> tcref.CompilationPath.ILScopeRef.QualifiedName | TType_tuple _ -> "" - | TType_anon (anonInfo, _tinst) -> defaultArg anonInfo.Assembly.QualifiedName "" + | TType_anon(anonInfo, _tinst) -> defaultArg anonInfo.Assembly.QualifiedName "" | TType_fun _ -> "" | TType_measure _ -> "" - | TType_var (tp, _) -> tp.Solution |> function Some slnTy -> slnTy.GetAssemblyName() | None -> "" - | TType_ucase (_uc, _tinst) -> + | TType_var(tp, _) -> + tp.Solution + |> function + | Some slnTy -> slnTy.GetAssemblyName() + | None -> "" + | TType_ucase(_uc, _tinst) -> let (TILObjectReprData(scope, _nesting, _definition)) = _uc.Tycon.ILTyconInfo scope.QualifiedName [] member x.DebugText = x.ToString() - override x.ToString() = - match x with - | TType_forall (_tps, ty) -> "forall ... " + ty.ToString() - | TType_app (tcref, tinst, nullness) -> tcref.DisplayName + (match tinst with [] -> "" | tys -> "<" + String.concat "," (List.map string tys) + ">") + nullness.ToString() - | TType_tuple (tupInfo, tinst) -> - (match tupInfo with + override x.ToString() = + match x with + | TType_forall(_tps, ty) -> "forall ... " + ty.ToString() + | TType_app(tcref, tinst, nullness) -> + tcref.DisplayName + + (match tinst with + | [] -> "" + | tys -> "<" + String.concat "," (List.map string tys) + ">") + + nullness.ToString() + | TType_tuple(tupInfo, tinst) -> + (match tupInfo with | TupInfo.Const false -> "" | TupInfo.Const true -> "struct ") - + String.concat "," (List.map string tinst) + ")" - | TType_anon (anonInfo, tinst) -> - (match anonInfo.TupInfo with + + String.concat "," (List.map string tinst) + + ")" + | TType_anon(anonInfo, tinst) -> + (match anonInfo.TupInfo with | TupInfo.Const false -> "" | TupInfo.Const true -> "struct ") - + "{|" + String.concat "," (Seq.map2 (fun nm ty -> nm + " " + string ty + ";") anonInfo.SortedNames tinst) + "|}" - | TType_fun (domainTy, retTy, nullness) -> "(" + string domainTy + " -> " + string retTy + ")" + nullness.ToString() - | TType_ucase (uc, tinst) -> "ucase " + uc.CaseName + (match tinst with [] -> "" | tys -> "<" + String.concat "," (List.map string tys) + ">") - | TType_var (tp, _) -> - match tp.Solution with + + "{|" + + String.concat "," (Seq.map2 (fun nm ty -> nm + " " + string ty + ";") anonInfo.SortedNames tinst) + + "|}" + | TType_fun(domainTy, retTy, nullness) -> "(" + string domainTy + " -> " + string retTy + ")" + nullness.ToString() + | TType_ucase(uc, tinst) -> + "ucase " + + uc.CaseName + + (match tinst with + | [] -> "" + | tys -> "<" + String.concat "," (List.map string tys) + ">") + | TType_var(tp, _) -> + match tp.Solution with | None -> tp.DisplayName | Some _ -> tp.DisplayName + " (solved)" | TType_measure ms -> ms.ToString() -type TypeInst = TType list +type TypeInst = TType list -type TTypes = TType list +type TTypes = TType list -/// Represents the information identifying an anonymous record -[] -type AnonRecdTypeInfo = +/// Represents the information identifying an anonymous record +[] +type AnonRecdTypeInfo = { - // Mutability for pickling/unpickling only - mutable Assembly: CcuThunk + // Mutability for pickling/unpickling only + mutable Assembly: CcuThunk - mutable TupInfo: TupInfo + mutable TupInfo: TupInfo - mutable SortedIds: Ident[] + mutable SortedIds: Ident[] - mutable Stamp: Stamp + mutable Stamp: Stamp - mutable SortedNames: string[] + mutable SortedNames: string[] - mutable IlTypeName : int64 + mutable IlTypeName: int64 } /// Create an AnonRecdTypeInfo from the basic data - static member Create(ccu: CcuThunk, tupInfo, ids: Ident[]) = + static member Create(ccu: CcuThunk, tupInfo, ids: Ident[]) = let sortedIds = ids |> Array.sortBy (fun id -> id.idText) // Hash all the data to form a unique stamp. @@ -4508,40 +5072,70 @@ type AnonRecdTypeInfo = // had to be modified to fix #6411, and the IL type name must remain unchanged for back compat reasons. let stamp = sha1HashInt64 - [| for c in ccu.AssemblyName do yield byte c; yield byte (int32 c >>> 8) - match tupInfo with - | TupInfo.Const b -> yield (if b then 0uy else 1uy) - for id in sortedIds do - for c in id.idText do yield byte c; yield byte (int32 c >>> 8) - yield 0uy |] + [| + for c in ccu.AssemblyName do + yield byte c + yield byte (int32 c >>> 8) + match tupInfo with + | TupInfo.Const b -> yield (if b then 0uy else 1uy) + for id in sortedIds do + for c in id.idText do + yield byte c + yield byte (int32 c >>> 8) + + yield 0uy + |] // Hash data to form a code used in generating IL type name. // To maintain backward compatibility this should not be changed. let ilName = sha1HashInt64 - [| for c in ccu.AssemblyName do yield byte c; yield byte (int32 c >>> 8) - match tupInfo with - | TupInfo.Const b -> yield (if b then 0uy else 1uy) - for id in sortedIds do - for c in id.idText do yield byte c; yield byte (int32 c >>> 8) |] + [| + for c in ccu.AssemblyName do + yield byte c + yield byte (int32 c >>> 8) + match tupInfo with + | TupInfo.Const b -> yield (if b then 0uy else 1uy) + for id in sortedIds do + for c in id.idText do + yield byte c + yield byte (int32 c >>> 8) + |] let sortedNames = Array.map textOfId sortedIds - { Assembly = ccu; TupInfo = tupInfo; SortedIds = sortedIds; Stamp = stamp; SortedNames = sortedNames; IlTypeName = ilName } + + { + Assembly = ccu + TupInfo = tupInfo + SortedIds = sortedIds + Stamp = stamp + SortedNames = sortedNames + IlTypeName = ilName + } /// Get the ILTypeRef for the generated type implied by the anonymous type - member x.ILTypeRef = - let ilTypeName = sprintf "<>f__AnonymousType%s%u`%d" (match x.TupInfo with TupInfo.Const b -> if b then "1000" else "") (uint32 x.IlTypeName) x.SortedIds.Length - mkILTyRef(x.Assembly.ILScopeRef, ilTypeName) - - static member NewUnlinked() : AnonRecdTypeInfo = - { Assembly = Unchecked.defaultof<_> - TupInfo = Unchecked.defaultof<_> - SortedIds = Unchecked.defaultof<_> - Stamp = Unchecked.defaultof<_> - SortedNames = Unchecked.defaultof<_> - IlTypeName = Unchecked.defaultof<_> } - - member x.Link d = + member x.ILTypeRef = + let ilTypeName = + sprintf + "<>f__AnonymousType%s%u`%d" + (match x.TupInfo with + | TupInfo.Const b -> if b then "1000" else "") + (uint32 x.IlTypeName) + x.SortedIds.Length + + mkILTyRef (x.Assembly.ILScopeRef, ilTypeName) + + static member NewUnlinked() : AnonRecdTypeInfo = + { + Assembly = Unchecked.defaultof<_> + TupInfo = Unchecked.defaultof<_> + SortedIds = Unchecked.defaultof<_> + Stamp = Unchecked.defaultof<_> + SortedNames = Unchecked.defaultof<_> + IlTypeName = Unchecked.defaultof<_> + } + + member x.Link d = let sortedNames = Array.map textOfId d.SortedIds x.Assembly <- d.Assembly x.TupInfo <- d.TupInfo @@ -4550,20 +5144,24 @@ type AnonRecdTypeInfo = x.SortedNames <- sortedNames x.IlTypeName <- d.IlTypeName - member x.IsLinked = (match box x.SortedIds with null -> true | _ -> false) - + member x.IsLinked = + (match box x.SortedIds with + | null -> true + | _ -> false) + member x.DisplayNameCoreByIdx idx = x.SortedNames[idx] - member x.DisplayNameByIdx idx = x.SortedNames[idx] |> ConvertLogicalNameToDisplayName + member x.DisplayNameByIdx idx = + x.SortedNames[idx] |> ConvertLogicalNameToDisplayName -[] -type TupInfo = +[] +type TupInfo = /// Some constant, e.g. true or false for tupInfo | Const of bool /// Represents a unit of measure in the typed AST [] -type Measure = +type Measure = /// A variable unit-of-measure | Var of typar: Typar @@ -4580,44 +5178,44 @@ type Measure = /// The unit of measure '1', e.g. float = float<1> | One of range: range - /// Raising a measure to a rational power + /// Raising a measure to a rational power | RationalPower of measure: Measure * power: Rational // %+A formatting is used, so this is not needed //[] //member x.DebugText = x.ToString() - + override x.ToString() = sprintf "%+A" x - - member x.Range = - match x with + + member x.Range = + match x with | Var(typar) -> typar.Range - | Const(range= m) -> m - | Prod(range= m) -> m + | Const(range = m) -> m + | Prod(range = m) -> m | Inv(m) -> m.Range - | One(range= m) -> m - | RationalPower(measure= ms) -> ms.Range + | One(range = m) -> m + | RationalPower(measure = ms) -> ms.Range -type Attribs = Attrib list +type Attribs = Attrib list [] -type AttribKind = +type AttribKind = - /// Indicates an attribute refers to a type defined in an imported .NET assembly - | ILAttrib of ilMethodRef: ILMethodRef + /// Indicates an attribute refers to a type defined in an imported .NET assembly + | ILAttrib of ilMethodRef: ILMethodRef - /// Indicates an attribute refers to a type defined in an imported F# assembly + /// Indicates an attribute refers to a type defined in an imported F# assembly | FSAttrib of valRef: ValRef // %+A formatting is used, so this is not needed //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x /// Attrib(tyconRef, kind, unnamedArgs, propVal, appliedToAGetterOrSetter, targetsOpt, range) [] -type Attrib = +type Attrib = | Attrib of tyconRef: TyconRef * @@ -4639,10 +5237,10 @@ type Attrib = /// We keep both source expression and evaluated expression around to help intellisense and signature printing [] -type AttribExpr = +type AttribExpr = /// AttribExpr(source, evaluated) - | AttribExpr of source: Expr * evaluated: Expr + | AttribExpr of source: Expr * evaluated: Expr [] member x.DebugText = x.ToString() @@ -4651,8 +5249,8 @@ type AttribExpr = /// AttribNamedArg(name, type, isField, value) [] -type AttribNamedArg = - | AttribNamedArg of (string*TType*bool*AttribExpr) +type AttribNamedArg = + | AttribNamedArg of (string * TType * bool * AttribExpr) [] member x.DebugText = x.ToString() @@ -4661,7 +5259,7 @@ type AttribNamedArg = /// Constants in expressions [] -type Const = +type Const = | Bool of bool | SByte of sbyte | Byte of byte @@ -4677,9 +5275,9 @@ type Const = | Double of double | Char of char | String of string - | Decimal of Decimal + | Decimal of Decimal | Unit - | Zero // null/zero-bit-pattern + | Zero // null/zero-bit-pattern [] member x.DebugText = x.ToString() @@ -4700,9 +5298,9 @@ type Const = | Single x -> string x + "f" | Double x -> string x | Char x -> "'" + string x + "'" - | String x -> "\"" + x + "\"" - | Decimal x -> string x + "M" - | Unit -> "()" + | String x -> "\"" + x + "\"" + | Decimal x -> string x + "M" + | Unit -> "()" | Zero -> "Const.Zero" /// Decision trees. Pattern matching has been compiled down to @@ -4711,12 +5309,12 @@ type Const = /// the decision tree are labelled by integers that are unique for that /// particular tree. [] -type DecisionTree = +type DecisionTree = /// TDSwitch(input, cases, default, range) /// - /// Indicates a decision point in a decision tree. - /// input -- The expression being tested. If switching over a struct union this + /// Indicates a decision point in a decision tree. + /// input -- The expression being tested. If switching over a struct union this /// must be the address of the expression being tested. /// cases -- The list of tests and their subsequent decision trees /// default -- The default decision tree, if any @@ -4728,11 +5326,11 @@ type DecisionTree = /// Indicates the decision tree has terminated with success, transferring control to the given target with the given parameters. /// results -- the expressions to be bound to the variables at the target /// target -- the target number for the continuation - | TDSuccess of results: Exprs * targetNum: int + | TDSuccess of results: Exprs * targetNum: int /// TDBind(binding, body) /// - /// Bind the given value through the remaining cases of the dtree. + /// Bind the given value through the remaining cases of the dtree. /// These arise from active patterns and some optimizations to prevent /// repeated computations in decision trees. /// binding -- the value and the expression it is bound to @@ -4743,11 +5341,11 @@ type DecisionTree = //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x /// Represents a test and a subsequent decision tree [] -type DecisionTreeCase = +type DecisionTreeCase = | TCase of discriminator: DecisionTreeTest * caseTree: DecisionTree /// Get the discriminator associated with the case @@ -4760,49 +5358,50 @@ type DecisionTreeCase = member x.DebugText = x.ToString() override x.ToString() = sprintf "DecisionTreeCase(...)" - + [] type ActivePatternReturnKind = | RefTypeWrapper | StructTypeWrapper | Boolean - member this.IsStruct with get () = + + member this.IsStruct = match this with | RefTypeWrapper -> false | StructTypeWrapper | Boolean -> true [] -type DecisionTreeTest = +type DecisionTreeTest = /// Test if the input to a decision tree matches the given union case | UnionCase of caseRef: UnionCaseRef * tinst: TypeInst - /// Test if the input to a decision tree is an array of the given length - | ArrayLength of length: int * ty: TType + /// Test if the input to a decision tree is an array of the given length + | ArrayLength of length: int * ty: TType - /// Test if the input to a decision tree is the given constant value + /// Test if the input to a decision tree is the given constant value | Const of value: Const - /// Test if the input to a decision tree is null - | IsNull + /// Test if the input to a decision tree is null + | IsNull /// IsInst(source, target) /// - /// Test if the input to a decision tree is an instance of the given type + /// Test if the input to a decision tree is an instance of the given type | IsInst of source: TType * target: TType /// Test.ActivePatternCase(activePatExpr, activePatResTys, activePatRetKind, activePatIdentity, idx, activePatInfo) /// - /// Run the active pattern and bind a successful result to a - /// variable in the remaining tree. + /// Run the active pattern and bind a successful result to a + /// variable in the remaining tree. /// activePatExpr -- The active pattern function being called, perhaps applied to some active pattern parameters. /// activePatResTys -- The result types (case types) of the active pattern. /// activePatRetKind -- Indicating what is returning from the active pattern - /// activePatIdentity -- The value and the types it is applied to. If there are any active pattern parameters then this is empty. + /// activePatIdentity -- The value and the types it is applied to. If there are any active pattern parameters then this is empty. /// idx -- The case number of the active pattern which the test relates to. /// activePatternInfo -- The extracted info for the active pattern. | ActivePatternCase of - activePatExpr: Expr * + activePatExpr: Expr * activePatResTys: TTypes * activePatRetKind: ActivePatternReturnKind * activePatIdentity: (ValRef * TypeInst) option * @@ -4816,19 +5415,16 @@ type DecisionTreeTest = //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x -/// A target of a decision tree. Can be thought of as a little function, though is compiled as a local block. +/// A target of a decision tree. Can be thought of as a little function, though is compiled as a local block. /// -- boundVals - The values bound at the target, matching the valuesin the TDSuccess /// -- targetExpr - The expression to evaluate if we branch to the target /// -- debugPoint - The debug point for the target /// -- isStateVarFlags - Indicates which, if any, of the values are represents as state machine variables [] -type DecisionTreeTarget = - | TTarget of - boundVals: Val list * - targetExpr: Expr * - isStateVarFlags: bool list option +type DecisionTreeTarget = + | TTarget of boundVals: Val list * targetExpr: Expr * isStateVarFlags: bool list option [] member x.DebugText = x.ToString() @@ -4845,11 +5441,8 @@ type Bindings = Binding list /// -- expr: The expression to execute to get the value /// -- debugPoint: The debug point for the binding [] -type Binding = - | TBind of - var: Val * - expr: Expr * - debugPoint: DebugPointAtBinding +type Binding = + | TBind of var: Val * expr: Expr * debugPoint: DebugPointAtBinding /// The value being bound member x.Var = (let (TBind(v, _, _)) = x in v) @@ -4863,12 +5456,13 @@ type Binding = [] member x.DebugText = x.ToString() - override x.ToString() = sprintf "TBind(%s, ...)" (x.Var.CompiledName None) + override x.ToString() = + sprintf "TBind(%s, ...)" (x.Var.CompiledName None) -/// Represents a reference to an active pattern element. The -/// integer indicates which choice in the target set is being selected by this item. +/// Represents a reference to an active pattern element. The +/// integer indicates which choice in the target set is being selected by this item. [] -type ActivePatternElemRef = +type ActivePatternElemRef = | APElemRef of activePatternInfo: ActivePatternInfo * activePatternVal: ValRef * @@ -4882,9 +5476,10 @@ type ActivePatternElemRef = member x.ActivePatternVal = (let (APElemRef(_, vref, _, _)) = x in vref) /// Get a reference to the value for the active pattern being referred to - member x.ActivePatternRetKind = (let (APElemRef(_, _, _, activePatRetKind)) = x in activePatRetKind) + member x.ActivePatternRetKind = + (let (APElemRef(_, _, _, activePatRetKind)) = x in activePatRetKind) - /// Get the index of the active pattern element within the overall active pattern + /// Get the index of the active pattern element within the overall active pattern member x.CaseIndex = (let (APElemRef(_, _, n, _)) = x in n) [] @@ -4895,12 +5490,9 @@ type ActivePatternElemRef = /// Records the "extra information" for a value compiled as a method (rather /// than a closure or a local), including argument names, attributes etc. [] -type ValReprInfo = +type ValReprInfo = /// ValReprInfo (typars, args, result) - | ValReprInfo of - typars: TyparReprInfo list * - args: ArgReprInfo list list * - result: ArgReprInfo + | ValReprInfo of typars: TyparReprInfo list * args: ArgReprInfo list list * result: ArgReprInfo /// Get the extra information about the arguments for the value member x.ArgInfos = (let (ValReprInfo(_, args, _)) = x in args) @@ -4915,30 +5507,35 @@ type ValReprInfo = member x.HasNoArgs = (let (ValReprInfo(n, args, _)) = x in n.IsEmpty && args.IsEmpty) /// Get the number of tupled arguments in each curried argument position - member x.AritiesOfArgs = (let (ValReprInfo(_, args, _)) = x in List.map List.length args) + member x.AritiesOfArgs = + (let (ValReprInfo(_, args, _)) = x in List.map List.length args) /// Get the kind of each type parameter - member x.KindsOfTypars = (let (ValReprInfo(n, _, _)) = x in n |> List.map (fun (TyparReprInfo(_, k)) -> k)) + member x.KindsOfTypars = + (let (ValReprInfo(n, _, _)) = x in n |> List.map (fun (TyparReprInfo(_, k)) -> k)) - /// Get the total number of arguments - member x.TotalArgCount = + /// Get the total number of arguments + member x.TotalArgCount = let (ValReprInfo(_, args, _)) = x // This is List.sumBy List.length args // We write this by hand as it can be a performance bottleneck in LinkagePartialKey - let rec loop (args: ArgReprInfo list list) acc = - match args with - | [] -> acc - | [] :: t -> loop t acc - | [_] :: t -> loop t (acc+1) - | (_ :: _ :: h) :: t -> loop t (acc + h.Length + 2) + let rec loop (args: ArgReprInfo list list) acc = + match args with + | [] -> acc + | [] :: t -> loop t acc + | [ _ ] :: t -> loop t (acc + 1) + | (_ :: _ :: h) :: t -> loop t (acc + h.Length + 2) + loop args 0 member x.ArgNames = - [ for argTys in x.ArgInfos do - for argInfo in argTys do - match argInfo.Name with - | None -> () - | Some nm -> nm.idText ] + [ + for argTys in x.ArgInfos do + for argInfo in argTys do + match argInfo.Name with + | None -> () + | Some nm -> nm.idText + ] [] member x.DebugText = x.ToString() @@ -4950,17 +5547,17 @@ type ValReprInfo = [] type ArgReprInfo = { - /// The attributes for the argument - // MUTABILITY: used when propagating signature attributes into the implementation. - mutable Attribs: Attribs + /// The attributes for the argument + // MUTABILITY: used when propagating signature attributes into the implementation. + mutable Attribs: Attribs - /// The name for the argument at this position, if any - // MUTABILITY: used when propagating names of parameters from signature into the implementation. - mutable Name: Ident option + /// The name for the argument at this position, if any + // MUTABILITY: used when propagating names of parameters from signature into the implementation. + mutable Name: Ident option - /// The range of the signature/implementation counterpart to this argument, if any - // MUTABILITY: used when propagating ranges from signature into the implementation. - mutable OtherRange: range option + /// The range of the signature/implementation counterpart to this argument, if any + // MUTABILITY: used when propagating ranges from signature into the implementation. + mutable OtherRange: range option } [] @@ -4969,13 +5566,13 @@ type ArgReprInfo = override _.ToString() = "ArgReprInfo(...)" /// Records the extra metadata stored about typars for type parameters -/// compiled as "real" IL type parameters, specifically for values with +/// compiled as "real" IL type parameters, specifically for values with /// ValReprInfo. Any information here is propagated from signature through /// to the compiled code. type TyparReprInfo = TyparReprInfo of Ident * TyparKind type Typars = Typar list - + type Exprs = Expr list type Vals = Val list @@ -4983,89 +5580,60 @@ type Vals = Val list /// Represents an expression in the typed abstract syntax [] type Expr = - /// A constant expression. - | Const of - value: Const * - range: range * - constType: TType + /// A constant expression. + | Const of value: Const * range: range * constType: TType - /// Reference a value. The flag is only relevant if the value is an object model member - /// and indicates base calls and special uses of object constructors. - | Val of - valRef: ValRef * - flags: ValUseFlag * - range: range + /// Reference a value. The flag is only relevant if the value is an object model member + /// and indicates base calls and special uses of object constructors. + | Val of valRef: ValRef * flags: ValUseFlag * range: range - /// Sequence expressions, used for "a;b", "let a = e in b;a" and "a then b" (the last an OO constructor). - | Sequential of - expr1: Expr * - expr2: Expr * - kind: SequentialOpKind * - range: range + /// Sequence expressions, used for "a;b", "let a = e in b;a" and "a then b" (the last an OO constructor). + | Sequential of expr1: Expr * expr2: Expr * kind: SequentialOpKind * range: range - /// Lambda expressions. - - /// Why multiple vspecs? A Expr.Lambda taking multiple arguments really accepts a tuple. - /// But it is in a convenient form to be compile accepting multiple - /// arguments, e.g. if compiled as a toplevel static method. + /// Lambda expressions. + /// Why multiple vspecs? A Expr.Lambda taking multiple arguments really accepts a tuple. + /// But it is in a convenient form to be compile accepting multiple + /// arguments, e.g. if compiled as a toplevel static method. | Lambda of unique: Unique * ctorThisValOpt: Val option * baseValOpt: Val option * valParams: Val list * - bodyExpr: Expr * - range: range * - overallType: TType - - /// Type lambdas. These are used for the r.h.s. of polymorphic 'let' bindings and - /// for expressions that implement first-class polymorphic values. - | TyLambda of - unique: Unique * - typeParams: Typars * bodyExpr: Expr * range: range * overallType: TType + /// Type lambdas. These are used for the r.h.s. of polymorphic 'let' bindings and + /// for expressions that implement first-class polymorphic values. + | TyLambda of unique: Unique * typeParams: Typars * bodyExpr: Expr * range: range * overallType: TType + /// Applications. - /// Applications combine type and term applications, and are normalized so - /// that sequential applications are combined, so "(f x y)" becomes "f [[x];[y]]". - /// The type attached to the function is the formal function type, used to ensure we don't build application - /// nodes that over-apply when instantiating at function types. - | App of - funcExpr: Expr * - formalType: TType * - typeArgs: TypeInst * - args: Exprs * - range: range - - /// Bind a recursive set of values. - | LetRec of - bindings: Bindings * - bodyExpr: Expr * - range: range * - frees: FreeVarsCache + /// Applications combine type and term applications, and are normalized so + /// that sequential applications are combined, so "(f x y)" becomes "f [[x];[y]]". + /// The type attached to the function is the formal function type, used to ensure we don't build application + /// nodes that over-apply when instantiating at function types. + | App of funcExpr: Expr * formalType: TType * typeArgs: TypeInst * args: Exprs * range: range - /// Bind a value. - | Let of - binding: Binding * - bodyExpr: Expr * - range: range * - frees: FreeVarsCache - - // Object expressions: A closure that implements an interface or a base type. - // The base object type might be a delegate type. - | Obj of - unique: Unique * - objTy: TType * (* <-- NOTE: specifies type parameters for base type *) - baseVal: Val option * - ctorCall: Expr * - overrides: ObjExprMethod list * - interfaceImpls: (TType * ObjExprMethod list) list * + /// Bind a recursive set of values. + | LetRec of bindings: Bindings * bodyExpr: Expr * range: range * frees: FreeVarsCache + + /// Bind a value. + | Let of binding: Binding * bodyExpr: Expr * range: range * frees: FreeVarsCache + + // Object expressions: A closure that implements an interface or a base type. + // The base object type might be a delegate type. + | Obj of + unique: Unique * + objTy: TType (* <-- NOTE: specifies type parameters for base type *) * + baseVal: Val option * + ctorCall: Expr * + overrides: ObjExprMethod list * + interfaceImpls: (TType * ObjExprMethod list) list * range: range - /// Matches are a more complicated form of "let" with multiple possible destinations - /// and possibly multiple ways to get to each destination. - /// The first range is that of the expression being matched, which is used + /// Matches are a more complicated form of "let" with multiple possible destinations + /// and possibly multiple ways to get to each destination. + /// The first range is that of the expression being matched, which is used /// as the range for all the decision making and binding that happens during the decision tree /// execution. | Match of @@ -5076,24 +5644,16 @@ type Expr = fullRange: range * exprType: TType - /// If we statically know some information then in many cases we can use a more optimized expression - /// This is primarily used by terms in the standard library, particularly those implementing overloaded - /// operators. - | StaticOptimization of - conditions: StaticOptimization list * - expr: Expr * - alternativeExpr: Expr * - range: range + /// If we statically know some information then in many cases we can use a more optimized expression + /// This is primarily used by terms in the standard library, particularly those implementing overloaded + /// operators. + | StaticOptimization of conditions: StaticOptimization list * expr: Expr * alternativeExpr: Expr * range: range - /// An intrinsic applied to some (strictly evaluated) arguments - /// A few of intrinsics (TOp_try, TOp.While, TOp.IntegerForLoop) expect arguments kept in a normal form involving lambdas - | Op of - op: TOp * - typeArgs: TypeInst * - args: Exprs * - range: range + /// An intrinsic applied to some (strictly evaluated) arguments + /// A few of intrinsics (TOp_try, TOp.While, TOp.IntegerForLoop) expect arguments kept in a normal form involving lambdas + | Op of op: TOp * typeArgs: TypeInst * args: Exprs * range: range - /// Indicates the expression is a quoted expression tree. + /// Indicates the expression is a quoted expression tree. /// // MUTABILITY: this use of mutability is awkward and perhaps should be removed | Quote of @@ -5101,8 +5661,8 @@ type Expr = quotationInfo: ((ILTypeRef list * TTypes * Exprs * ExprData) * (ILTypeRef list * TTypes * Exprs * ExprData)) option ref * isFromQueryExpression: bool * range: range * - quotedType: TType - + quotedType: TType + /// Used in quotation generation to indicate a witness argument, spliced into a quotation literal. /// /// For example: @@ -5116,28 +5676,23 @@ type Expr = /// /// f$W(witnessForSin, x) { return Deserialize(<@ sin$W _spliceHole1 _spliceHole2 @>, [| WitnessArg(witnessForSin), x |]) } /// - /// where _spliceHole1 will be the location of the witness argument in the quotation data, and + /// where _spliceHole1 will be the location of the witness argument in the quotation data, and /// witnessArg is the lambda for the witness - /// - | WitnessArg of - traitInfo: TraitConstraintInfo * - range: range + /// + | WitnessArg of traitInfo: TraitConstraintInfo * range: range - /// Indicates a free choice of typars that arises due to - /// minimization of polymorphism at let-rec bindings. These are - /// resolved to a concrete instantiation on subsequent rewrites. - | TyChoose of - typeParams: Typars * - bodyExpr: Expr * - range: range + /// Indicates a free choice of typars that arises due to + /// minimization of polymorphism at let-rec bindings. These are + /// resolved to a concrete instantiation on subsequent rewrites. + | TyChoose of typeParams: Typars * bodyExpr: Expr * range: range - /// An instance of a link node occurs for every use of a recursively bound variable. When type-checking - /// the recursive bindings a dummy expression is stored in the mutable reference cell. - /// After type checking the bindings this is replaced by a use of the variable, perhaps at an - /// appropriate type instantiation. These are immediately eliminated on subsequent rewrites. + /// An instance of a link node occurs for every use of a recursively bound variable. When type-checking + /// the recursive bindings a dummy expression is stored in the mutable reference cell. + /// After type checking the bindings this is replaced by a use of the variable, perhaps at an + /// appropriate type instantiation. These are immediately eliminated on subsequent rewrites. | Link of Expr ref - /// Indicates a debug point should be placed prior to the expression. + /// Indicates a debug point should be placed prior to the expression. | DebugPoint of DebugPointAtLeafExpr * Expr [] @@ -5145,50 +5700,80 @@ type Expr = override expr.ToString() = expr.ToDebugString(3) - member expr.ToDebugString(depth: int) : string = - if depth = 0 then ".." else - let depth = depth - 1 - match expr with - | Const (c, _, _) -> string c - | Val (v, _, _) -> v.LogicalName - | Sequential (e1, e2, _, _) -> "Sequential(" + e1.ToDebugString(depth) + ", " + e2.ToDebugString(depth) + ")" - | Lambda (_, _, _, vs, body, _, _) -> sprintf "Lambda(%+A, " vs + body.ToDebugString(depth) + ")" - | TyLambda (_, tps, body, _, _) -> sprintf "TyLambda(%+A, " tps + body.ToDebugString(depth) + ")" - | App (f, _, _, args, _) -> "App(" + f.ToDebugString(depth) + ", [" + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + "])" - | LetRec _ -> "LetRec(..)" - | Let (bind, body, _, _) -> "Let(" + bind.Var.DisplayName + ", " + bind.Expr.ToDebugString(depth) + ", " + body.ToDebugString(depth) + ")" - | Obj (_, _objTy, _, _, _, _, _) -> "Obj(..)" - | Match (_, _, _dt, _tgs, _, _) -> "Match(..)" - | StaticOptimization _ -> "StaticOptimization(..)" - | Op (op, _, args, _) -> "Op(" + op.ToString() + ", " + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + ")" - | Quote _ -> "Quote(..)" - | WitnessArg _ -> "WitnessArg(..)" - | TyChoose _ -> "TyChoose(..)" - | Link e -> "Link(" + e.Value.ToDebugString(depth) + ")" - | DebugPoint (DebugPointAtLeafExpr.Yes m, e) -> sprintf "DebugPoint(%s, " (m.ToString()) + e.ToDebugString(depth) + ")" + member expr.ToDebugString(depth: int) : string = + if depth = 0 then + ".." + else + let depth = depth - 1 + + match expr with + | Const(c, _, _) -> string c + | Val(v, _, _) -> v.LogicalName + | Sequential(e1, e2, _, _) -> "Sequential(" + e1.ToDebugString(depth) + ", " + e2.ToDebugString(depth) + ")" + | Lambda(_, _, _, vs, body, _, _) -> sprintf "Lambda(%+A, " vs + body.ToDebugString(depth) + ")" + | TyLambda(_, tps, body, _, _) -> sprintf "TyLambda(%+A, " tps + body.ToDebugString(depth) + ")" + | App(f, _, _, args, _) -> + "App(" + + f.ToDebugString(depth) + + ", [" + + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + + "])" + | LetRec _ -> "LetRec(..)" + | Let(bind, body, _, _) -> + "Let(" + + bind.Var.DisplayName + + ", " + + bind.Expr.ToDebugString(depth) + + ", " + + body.ToDebugString(depth) + + ")" + | Obj(_, _objTy, _, _, _, _, _) -> "Obj(..)" + | Match(_, _, _dt, _tgs, _, _) -> "Match(..)" + | StaticOptimization _ -> "StaticOptimization(..)" + | Op(op, _, args, _) -> + "Op(" + + op.ToString() + + ", " + + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + + ")" + | Quote _ -> "Quote(..)" + | WitnessArg _ -> "WitnessArg(..)" + | TyChoose _ -> "TyChoose(..)" + | Link e -> "Link(" + e.Value.ToDebugString(depth) + ")" + | DebugPoint(DebugPointAtLeafExpr.Yes m, e) -> sprintf "DebugPoint(%s, " (m.ToString()) + e.ToDebugString(depth) + ")" /// Get the mark/range/position information from an expression member expr.Range = match expr with - | Expr.Val (_, _, m) | Expr.Op (_, _, _, m) | Expr.Const (_, m, _) | Expr.Quote (_, _, _, m, _) - | Expr.Obj (_, _, _, _, _, _, m) | Expr.App (_, _, _, _, m) | Expr.Sequential (_, _, _, m) - | Expr.StaticOptimization (_, _, _, m) | Expr.Lambda (_, _, _, _, _, m, _) - | Expr.WitnessArg (_, m) - | Expr.TyLambda (_, _, _, m, _)| Expr.TyChoose (_, _, m) | Expr.LetRec (_, _, m, _) | Expr.Let (_, _, m, _) | Expr.Match (_, _, _, _, m, _) -> m + | Expr.Val(_, _, m) + | Expr.Op(_, _, _, m) + | Expr.Const(_, m, _) + | Expr.Quote(_, _, _, m, _) + | Expr.Obj(_, _, _, _, _, _, m) + | Expr.App(_, _, _, _, m) + | Expr.Sequential(_, _, _, m) + | Expr.StaticOptimization(_, _, _, m) + | Expr.Lambda(_, _, _, _, _, m, _) + | Expr.WitnessArg(_, m) + | Expr.TyLambda(_, _, _, m, _) + | Expr.TyChoose(_, _, m) + | Expr.LetRec(_, _, m, _) + | Expr.Let(_, _, m, _) + | Expr.Match(_, _, _, _, m, _) -> m | Expr.Link eref -> eref.Value.Range - | Expr.DebugPoint (_, e2) -> e2.Range - -[] + | Expr.DebugPoint(_, e2) -> e2.Range + +[] type TOp = /// An operation representing the creation of a union value of the particular union case - | UnionCase of UnionCaseRef + | UnionCase of UnionCaseRef /// An operation representing the creation of an exception value using an F# exception declaration | ExnConstr of TyconRef /// An operation representing the creation of a tuple value - | Tuple of TupInfo + | Tuple of TupInfo /// An operation representing the creation of an anonymous record | AnonRecd of AnonRecdTypeInfo @@ -5203,7 +5788,7 @@ type TOp = | Bytes of byte[] /// Constant uint16 arrays (used for parser tables) - | UInt16s of uint16[] + | UInt16s of uint16[] /// An operation representing a lambda-encoded while loop. The special while loop marker is used to mark compilations of 'foreach' expressions | While of spWhile: DebugPointAtWhile * marker: SpecialWhileLoopMarker @@ -5217,30 +5802,30 @@ type TOp = /// An operation representing a lambda-encoded try/finally | TryFinally of spTry: DebugPointAtTry * spFinally: DebugPointAtFinally - /// Construct a record or object-model value. The ValRef is for self-referential class constructors, otherwise - /// it indicates that we're in a constructor and the purpose of the expression is to - /// fill in the fields of a pre-created but uninitialized object, and to assign the initialized - /// version of the object into the optional mutable cell pointed to be the given value. + /// Construct a record or object-model value. The ValRef is for self-referential class constructors, otherwise + /// it indicates that we're in a constructor and the purpose of the expression is to + /// fill in the fields of a pre-created but uninitialized object, and to assign the initialized + /// version of the object into the optional mutable cell pointed to be the given value. | Recd of RecordConstructionInfo * TyconRef - + /// An operation representing setting a record or class field - | ValFieldSet of RecdFieldRef + | ValFieldSet of RecdFieldRef /// An operation representing getting a record or class field - | ValFieldGet of RecdFieldRef + | ValFieldGet of RecdFieldRef /// An operation representing getting the address of a record field - | ValFieldGetAddr of RecdFieldRef * readonly: bool + | ValFieldGetAddr of RecdFieldRef * readonly: bool /// An operation representing getting an integer tag for a union value representing the union case number - | UnionCaseTagGet of TyconRef + | UnionCaseTagGet of TyconRef /// An operation representing a coercion that proves a union value is of a particular union case. This is not a test, its /// simply added proof to enable us to generate verifiable code for field access on union types | UnionCaseProof of UnionCaseRef /// An operation representing a field-get from a union value, where that value has been proven to be of the corresponding union case. - | UnionCaseFieldGet of UnionCaseRef * int + | UnionCaseFieldGet of UnionCaseRef * int /// An operation representing a field-get from a union value, where that value has been proven to be of the corresponding union case. | UnionCaseFieldGetAddr of UnionCaseRef * int * readonly: bool @@ -5249,27 +5834,25 @@ type TOp = | UnionCaseFieldSet of UnionCaseRef * int /// An operation representing a field-get from an F# exception value. - | ExnFieldGet of TyconRef * int + | ExnFieldGet of TyconRef * int /// An operation representing a field-set on an F# exception value. - | ExnFieldSet of TyconRef * int + | ExnFieldSet of TyconRef * int /// An operation representing a field-get from an F# tuple value. - | TupleFieldGet of TupInfo * int + | TupleFieldGet of TupInfo * int - /// IL assembly code - type list are the types pushed on the stack - | ILAsm of - instrs: ILInstr list * - retTypes: TTypes + /// IL assembly code - type list are the types pushed on the stack + | ILAsm of instrs: ILInstr list * retTypes: TTypes - /// Generate a ldflda on an 'a ref. + /// Generate a ldflda on an 'a ref. | RefAddrGet of bool - /// Conversion node, compiled via type-directed translation or to box/unbox - | Coerce + /// Conversion node, compiled via type-directed translation or to box/unbox + | Coerce - /// Represents a "rethrow" operation. May not be rebound, or used outside of try-finally, expecting a unit argument - | Reraise + /// Represents a "rethrow" operation. May not be rebound, or used outside of try-finally, expecting a unit argument + | Reraise /// Used for state machine compilation | Return @@ -5280,34 +5863,34 @@ type TOp = /// Used for state machine compilation | Label of ILCodeLabel - /// Pseudo method calls. This is used for overloaded operations like op_Addition. - | TraitCall of TraitConstraintInfo + /// Pseudo method calls. This is used for overloaded operations like op_Addition. + | TraitCall of TraitConstraintInfo - /// Operation nodes representing C-style operations on byrefs and mutable vals (l-values) - | LValueOp of LValueOperation * ValRef + /// Operation nodes representing C-style operations on byrefs and mutable vals (l-values) + | LValueOp of LValueOperation * ValRef /// IL method calls. - /// isProperty -- used for quotation reflection, property getters & setters - /// noTailCall - DllImport? if so don't tailcall + /// isProperty -- used for quotation reflection, property getters & setters + /// noTailCall - DllImport? if so don't tailcall /// retTypes -- the types of pushed values, if any - | ILCall of - isVirtual: bool * - isProtected: bool * - isStruct: bool * - isCtor: bool * - valUseFlag: ValUseFlag * - isProperty: bool * - noTailCall: bool * - ilMethRef: ILMethodRef * - enclTypeInst: TypeInst * - methInst: TypeInst * - retTypes: TTypes + | ILCall of + isVirtual: bool * + isProtected: bool * + isStruct: bool * + isCtor: bool * + valUseFlag: ValUseFlag * + isProperty: bool * + noTailCall: bool * + ilMethRef: ILMethodRef * + enclTypeInst: TypeInst * + methInst: TypeInst * + retTypes: TTypes [] member x.DebugText = x.ToString() - - override op.ToString() = - match op with + + override op.ToString() = + match op with | UnionCase ucref -> "UnionCase(" + ucref.CaseName + ")" | ExnConstr ecref -> "ExnConstr(" + ecref.LogicalName + ")" | Tuple _tupinfo -> "Tuple" @@ -5320,17 +5903,17 @@ type TOp = | IntegerForLoop _ -> "FastIntegerForLoop" | TryWith _ -> "TryWith" | TryFinally _ -> "TryFinally" - | Recd (_, tcref) -> "Recd(" + tcref.LogicalName + ")" + | Recd(_, tcref) -> "Recd(" + tcref.LogicalName + ")" | ValFieldSet rfref -> "ValFieldSet(" + rfref.FieldName + ")" | ValFieldGet rfref -> "ValFieldGet(" + rfref.FieldName + ")" - | ValFieldGetAddr (rfref, _) -> "ValFieldGetAddr(" + rfref.FieldName + ",..)" + | ValFieldGetAddr(rfref, _) -> "ValFieldGetAddr(" + rfref.FieldName + ",..)" | UnionCaseTagGet tcref -> "UnionCaseTagGet(" + tcref.LogicalName + ")" | UnionCaseProof ucref -> "UnionCaseProof(" + ucref.CaseName + ")" - | UnionCaseFieldGet (ucref, _) -> "UnionCaseFieldGet(" + ucref.CaseName + ",..)" - | UnionCaseFieldGetAddr (ucref, _, _) -> "UnionCaseFieldGetAddr(" + ucref.CaseName + ",..)" - | UnionCaseFieldSet (ucref, _) -> "UnionCaseFieldSet(" + ucref.CaseName + ",..)" - | ExnFieldGet (tcref, _) -> "ExnFieldGet(" + tcref.LogicalName + ",..)" - | ExnFieldSet (tcref, _) -> "ExnFieldSet(" + tcref.LogicalName + ",..)" + | UnionCaseFieldGet(ucref, _) -> "UnionCaseFieldGet(" + ucref.CaseName + ",..)" + | UnionCaseFieldGetAddr(ucref, _, _) -> "UnionCaseFieldGetAddr(" + ucref.CaseName + ",..)" + | UnionCaseFieldSet(ucref, _) -> "UnionCaseFieldSet(" + ucref.CaseName + ",..)" + | ExnFieldGet(tcref, _) -> "ExnFieldGet(" + tcref.LogicalName + ",..)" + | ExnFieldSet(tcref, _) -> "ExnFieldSet(" + tcref.LogicalName + ",..)" | TupleFieldGet _ -> "TupleFieldGet(..)" | ILAsm _ -> "ILAsm(..)" | RefAddrGet _ -> "RefAddrGet(..)" @@ -5340,17 +5923,17 @@ type TOp = | Goto n -> "Goto(" + string n + ")" | Label n -> "Label(" + string n + ")" | TraitCall info -> "TraitCall(" + info.MemberLogicalName + ")" - | LValueOp (op, vref) -> sprintf "%+A(%s)" op vref.LogicalName - | ILCall (_,_,_,_,_,_,_,ilMethRef,_,_,_) -> "ILCall(" + ilMethRef.ToString() + ",..)" + | LValueOp(op, vref) -> sprintf "%+A(%s)" op vref.LogicalName + | ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _) -> "ILCall(" + ilMethRef.ToString() + ",..)" /// Represents the kind of record construction operation. -type RecordConstructionInfo = +type RecordConstructionInfo = - /// We're in an explicit constructor. The purpose of the record expression is to - /// fill in the fields of a pre-created but uninitialized object + /// We're in an explicit constructor. The purpose of the record expression is to + /// fill in the fields of a pre-created but uninitialized object | RecdExprIsObjInit - /// Normal record construction + /// Normal record construction | RecdExpr /// If this is Some ty then it indicates that a .NET 2.0 constrained call is required, with the given type as the @@ -5358,52 +5941,52 @@ type RecordConstructionInfo = type ConstrainedCallInfo = TType option /// Represents the kind of looping operation. -type SpecialWhileLoopMarker = +type SpecialWhileLoopMarker = | NoSpecialWhileLoopMarker /// Marks the compiled form of a 'for ... in ... do ' expression | WhileLoopForCompiledForEachExprMarker - + /// Represents the kind of looping operation. -type ForLoopStyle = +type ForLoopStyle = /// Evaluate start and end once, loop up - | FSharpForLoopUp + | FSharpForLoopUp /// Evaluate start and end once, loop down - | FSharpForLoopDown + | FSharpForLoopDown /// Evaluate start once and end multiple times, loop up | CSharpForLoopUp /// Indicates what kind of pointer operation this is. -type LValueOperation = +type LValueOperation = - /// In C syntax this is: &localv + /// In C syntax this is: &localv | LAddrOf of readonly: bool - /// In C syntax this is: *localv_ptr - | LByrefGet + /// In C syntax this is: *localv_ptr + | LByrefGet /// In C syntax this is: localv = e, note == *(&localv) = e == LAddrOf; LByrefSet - | LSet + | LSet - /// In C syntax this is: *localv_ptr = e - | LByrefSet + /// In C syntax this is: *localv_ptr = e + | LByrefSet /// Represents the kind of sequential operation, i.e. "normal" or "to a before returning b" -type SequentialOpKind = - /// a ; b - | NormalSeq +type SequentialOpKind = + /// a ; b + | NormalSeq - /// let res = a in b;res - | ThenDoSeq + /// let res = a in b;res + | ThenDoSeq /// Indicates how a value, function or member is being used at a particular usage point. type ValUseFlag = /// Indicates a use of a value represents a call to a method that may require - /// a .NET 2.0 constrained call. A constrained call is only used for calls where + /// a .NET 2.0 constrained call. A constrained call is only used for calls where // the object argument is a value type or generic type, and the call is to a method // on System.Object, System.ValueType, System.Enum or an interface methods. | PossibleConstrainedCall of ty: TType @@ -5419,21 +6002,21 @@ type ValUseFlag = /// A call to a base method, e.g. 'base.OnPaint(args)' | VSlotDirectCall - + /// Represents the kind of an F# core library static optimization construct -type StaticOptimization = +type StaticOptimization = /// Indicates the static optimization applies when a type equality holds | TTyconEqualsTycon of ty1: TType * ty2: TType /// Indicates the static optimization applies when a type is a struct - | TTyconIsStruct of ty: TType - -/// A representation of a method in an object expression. + | TTyconIsStruct of ty: TType + +/// A representation of a method in an object expression. /// /// TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExpr, m) [] -type ObjExprMethod = +type ObjExprMethod = | TObjExprMethod of slotSig: SlotSig * @@ -5443,18 +6026,20 @@ type ObjExprMethod = methodBodyExpr: Expr * range: range - member x.Id = let (TObjExprMethod(slotsig, _, _, _, _, m)) = x in mkSynId m slotsig.Name + member x.Id = + let (TObjExprMethod(slotsig, _, _, _, _, m)) = x in mkSynId m slotsig.Name [] member x.DebugText = x.ToString() - override x.ToString() = sprintf "TObjExprMethod(%s, ...)" x.Id.idText + override x.ToString() = + sprintf "TObjExprMethod(%s, ...)" x.Id.idText /// Represents an abstract method slot, or delegate signature. /// /// TSlotSig(methodName, declaringType, declaringTypeParameters, methodTypeParameters, slotParameters, returnTy) [] -type SlotSig = +type SlotSig = | TSlotSig of methodName: string * declaringType: TType * @@ -5466,7 +6051,7 @@ type SlotSig = /// The name of the method member ss.Name = let (TSlotSig(nm, _, _, _, _, _)) = ss in nm - /// The (instantiated) type which the slot is logically a part of + /// The (instantiated) type which the slot is logically a part of member ss.DeclaringType = let (TSlotSig(_, ty, _, _, _, _)) = ss in ty /// The class type parameters of the slot @@ -5486,18 +6071,12 @@ type SlotSig = override ss.ToString() = sprintf "TSlotSig(%s, ...)" ss.Name -/// Represents a parameter to an abstract method slot. +/// Represents a parameter to an abstract method slot. /// /// TSlotParam(nm, ty, inFlag, outFlag, optionalFlag, attribs) [] -type SlotParam = - | TSlotParam of - paramName: string option * - paramType: TType * - isIn: bool * - isOut: bool * - isOptional: bool * - attributes: Attribs +type SlotParam = + | TSlotParam of paramName: string option * paramType: TType * isIn: bool * isOut: bool * isOptional: bool * attributes: Attribs member x.Type = let (TSlotParam(_, ty, _, _, _, _)) = x in ty @@ -5508,47 +6087,52 @@ type SlotParam = /// Represents open declaration statement. type OpenDeclaration = - { /// Syntax after 'open' as it's presented in source code. - Target: SynOpenDeclTarget - - /// Full range of the open declaration. - Range: range option - - /// Modules or namespaces which is opened with this declaration. - Modules: ModuleOrNamespaceRef list - - /// Types whose static content is opened with this declaration. - Types: TType list - - /// Scope in which open declaration is visible. - AppliedScope: range - - /// If it's `namespace Xxx.Yyy` declaration. - IsOwnNamespace: bool + { + /// Syntax after 'open' as it's presented in source code. + Target: SynOpenDeclTarget + + /// Full range of the open declaration. + Range: range option + + /// Modules or namespaces which is opened with this declaration. + Modules: ModuleOrNamespaceRef list + + /// Types whose static content is opened with this declaration. + Types: TType list + + /// Scope in which open declaration is visible. + AppliedScope: range + + /// If it's `namespace Xxx.Yyy` declaration. + IsOwnNamespace: bool } /// Create a new instance of OpenDeclaration. - static member Create(target: SynOpenDeclTarget, modules: ModuleOrNamespaceRef list, types: TType list, appliedScope: range, isOwnNamespace: bool) = - { Target = target - Range = - match target with - | SynOpenDeclTarget.ModuleOrNamespace (range=m) - | SynOpenDeclTarget.Type (range=m) -> Some m - Types = types - Modules = modules - AppliedScope = appliedScope - IsOwnNamespace = isOwnNamespace } - -/// The contents of a module-or-namespace-fragment definition + static member Create + (target: SynOpenDeclTarget, modules: ModuleOrNamespaceRef list, types: TType list, appliedScope: range, isOwnNamespace: bool) + = + { + Target = target + Range = + match target with + | SynOpenDeclTarget.ModuleOrNamespace(range = m) + | SynOpenDeclTarget.Type(range = m) -> Some m + Types = types + Modules = modules + AppliedScope = appliedScope + IsOwnNamespace = isOwnNamespace + } + +/// The contents of a module-or-namespace-fragment definition [] -type ModuleOrNamespaceContents = - /// Indicates the module fragment is made of several module fragments in succession - | TMDefs of defs: ModuleOrNamespaceContents list +type ModuleOrNamespaceContents = + /// Indicates the module fragment is made of several module fragments in succession + | TMDefs of defs: ModuleOrNamespaceContents list /// Indicates the given 'open' declarations are active | TMDefOpens of openDecls: OpenDeclaration list - /// Indicates the module fragment is a 'let' definition + /// Indicates the module fragment is a 'let' definition | TMDefLet of binding: Binding * range: range /// Indicates the module fragment is an evaluation of expression for side-effects @@ -5561,20 +6145,18 @@ type ModuleOrNamespaceContents = //[] member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x -/// A named module-or-namespace-fragment definition +/// A named module-or-namespace-fragment definition [] -type ModuleOrNamespaceBinding = +type ModuleOrNamespaceBinding = - | Binding of binding: Binding + | Binding of binding: Binding /// The moduleOrNamespace represents the signature of the module. /// The moduleOrNamespaceContents contains the definitions of the module. /// The same set of entities are bound in the ModuleOrNamespace as in the ModuleOrNamespaceContents. - | Module of - moduleOrNamespace: ModuleOrNamespace * - moduleOrNamespaceContents: ModuleOrNamespaceContents + | Module of moduleOrNamespace: ModuleOrNamespace * moduleOrNamespaceContents: ModuleOrNamespaceContents [] member x.DebugText = x.ToString() @@ -5583,31 +6165,32 @@ type ModuleOrNamespaceBinding = [] type NamedDebugPointKey = - { Range: range - Name: string } + { + Range: range + Name: string + } override x.GetHashCode() = hash x.Name + hash x.Range - override x.Equals(yobj: objnull) = - match yobj with + override x.Equals(yobj: objnull) = + match yobj with | :? NamedDebugPointKey as y -> Range.equals x.Range y.Range && x.Name = y.Name | _ -> false interface IComparable with member x.CompareTo(yobj: obj) = - match yobj with - | :? NamedDebugPointKey as y -> - let c = Range.rangeOrder.Compare(x.Range, y.Range) - if c <> 0 then c else - compare x.Name y.Name - | _ -> -1 + match yobj with + | :? NamedDebugPointKey as y -> + let c = Range.rangeOrder.Compare(x.Range, y.Range) + if c <> 0 then c else compare x.Name y.Name + | _ -> -1 /// Represents a complete typechecked implementation file, including its inferred or explicit signature. /// /// CheckedImplFile (qualifiedNameOfFile, pragmas, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypeInfo) [] -type CheckedImplFile = - | CheckedImplFile of +type CheckedImplFile = + | CheckedImplFile of qualifiedNameOfFile: QualifiedNameOfFile * signature: ModuleOrNamespaceType * contents: ModuleOrNamespaceContents * @@ -5616,15 +6199,17 @@ type CheckedImplFile = anonRecdTypeInfo: StampMap * namedDebugPointsForInlinedCode: Map - member x.Signature = let (CheckedImplFile (signature=res)) = x in res + member x.Signature = let (CheckedImplFile(signature = res)) = x in res - member x.Contents = let (CheckedImplFile (contents=res)) = x in res + member x.Contents = let (CheckedImplFile(contents = res)) = x in res - member x.QualifiedNameOfFile = let (CheckedImplFile (qualifiedNameOfFile=res)) = x in res + member x.QualifiedNameOfFile = + let (CheckedImplFile(qualifiedNameOfFile = res)) = x in res - member x.HasExplicitEntryPoint = let (CheckedImplFile (hasExplicitEntryPoint=res)) = x in res + member x.HasExplicitEntryPoint = + let (CheckedImplFile(hasExplicitEntryPoint = res)) = x in res - member x.IsScript = let (CheckedImplFile (isScript=res)) = x in res + member x.IsScript = let (CheckedImplFile(isScript = res)) = x in res [] member x.DebugText = x.ToString() @@ -5633,9 +6218,11 @@ type CheckedImplFile = /// Represents a complete typechecked assembly, made up of multiple implementation files. [] -type CheckedImplFileAfterOptimization = - { ImplFile: CheckedImplFile - OptimizeDuringCodeGen: bool -> Expr -> Expr } +type CheckedImplFileAfterOptimization = + { + ImplFile: CheckedImplFile + OptimizeDuringCodeGen: bool -> Expr -> Expr + } [] member x.DebugText = x.ToString() @@ -5644,7 +6231,7 @@ type CheckedImplFileAfterOptimization = /// Represents a complete typechecked assembly, made up of multiple implementation files. [] -type CheckedAssemblyAfterOptimization = +type CheckedAssemblyAfterOptimization = | CheckedAssemblyAfterOptimization of CheckedImplFileAfterOptimization list [] @@ -5653,57 +6240,58 @@ type CheckedAssemblyAfterOptimization = override x.ToString() = "CheckedAssemblyAfterOptimization(...)" [] -type CcuData = +type CcuData = { - /// Holds the file name for the DLL, if any - FileName: string option - - /// Holds the data indicating how this assembly/module is referenced from the code being compiled. - ILScopeRef: ILScopeRef - - /// A unique stamp for this DLL - Stamp: Stamp - - /// The fully qualified assembly reference string to refer to this assembly. This is persisted in quotations - QualifiedName: string option - - /// A hint as to where does the code for the CCU live (e.g what was the tcConfig.implicitIncludeDir at compilation time for this DLL?) - SourceCodeDirectory: string - - /// Indicates that this DLL was compiled using the F# compiler and has F# metadata - IsFSharp: bool - + /// Holds the file name for the DLL, if any + FileName: string option + + /// Holds the data indicating how this assembly/module is referenced from the code being compiled. + ILScopeRef: ILScopeRef + + /// A unique stamp for this DLL + Stamp: Stamp + + /// The fully qualified assembly reference string to refer to this assembly. This is persisted in quotations + QualifiedName: string option + + /// A hint as to where does the code for the CCU live (e.g what was the tcConfig.implicitIncludeDir at compilation time for this DLL?) + SourceCodeDirectory: string + + /// Indicates that this DLL was compiled using the F# compiler and has F# metadata + IsFSharp: bool + #if !NO_TYPEPROVIDERS - /// Is the CCu an assembly injected by a type provider - IsProviderGenerated: bool + /// Is the CCu an assembly injected by a type provider + IsProviderGenerated: bool - /// Triggered when the contents of the CCU are invalidated - InvalidateEvent: IEvent + /// Triggered when the contents of the CCU are invalidated + InvalidateEvent: IEvent + + /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality + /// logic in tastops.fs + ImportProvidedType: Tainted -> TType - /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality - /// logic in tastops.fs - ImportProvidedType: Tainted -> TType - #endif - /// Indicates that this DLL uses pre-F#-4.0 quotation literals somewhere. This is used to implement a restriction on static linking - mutable UsesFSharp20PlusQuotations: bool - - /// A handle to the full specification of the contents of the module contained in this ccu - // NOTE: may contain transient state during typechecking - mutable Contents: ModuleOrNamespace - - /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality - /// logic in tastops.fs - TryGetILModuleDef: unit -> ILModuleDef option - - /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality - /// logic in tastops.fs - MemberSignatureEquality: TType -> TType -> bool - - /// The table of .NET CLI type forwarders for this assembly - TypeForwarders: CcuTypeForwarderTable - - XmlDocumentationInfo: XmlDocumentationInfo option } + /// Indicates that this DLL uses pre-F#-4.0 quotation literals somewhere. This is used to implement a restriction on static linking + mutable UsesFSharp20PlusQuotations: bool + + /// A handle to the full specification of the contents of the module contained in this ccu + // NOTE: may contain transient state during typechecking + mutable Contents: ModuleOrNamespace + + /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality + /// logic in tastops.fs + TryGetILModuleDef: unit -> ILModuleDef option + + /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality + /// logic in tastops.fs + MemberSignatureEquality: TType -> TType -> bool + + /// The table of .NET CLI type forwarders for this assembly + TypeForwarders: CcuTypeForwarderTable + + XmlDocumentationInfo: XmlDocumentationInfo option + } [] member x.DebugText = x.ToString() @@ -5712,36 +6300,46 @@ type CcuData = type CcuTypeForwarderTree = { - Value : Lazy option - Children : ImmutableDictionary + Value: Lazy option + Children: ImmutableDictionary } - static member Empty = { Value = None; Children = ImmutableDictionary.Empty } + static member Empty = + { + Value = None + Children = ImmutableDictionary.Empty + } module CcuTypeForwarderTable = - let rec findInTree (remainingPath: ArraySegment) (finalKey : string) (tree:CcuTypeForwarderTree): Lazy option = + let rec findInTree (remainingPath: ArraySegment) (finalKey: string) (tree: CcuTypeForwarderTree) : Lazy option = let nodes = tree.Children + let searchTerm = if remainingPath.Count = 0 then finalKey else (!!remainingPath.Array).[remainingPath.Offset] + match nodes.TryGetValue searchTerm with | true, innerTree -> if remainingPath.Count = 0 then innerTree.Value else - findInTree (ArraySegment((!!remainingPath.Array), remainingPath.Offset + 1, remainingPath.Count - 1)) finalKey innerTree + findInTree + (ArraySegment((!!remainingPath.Array), remainingPath.Offset + 1, remainingPath.Count - 1)) + finalKey + innerTree | false, _ -> None /// Represents a table of .NET CLI type forwarders for an assembly type CcuTypeForwarderTable = { - Root : CcuTypeForwarderTree + Root: CcuTypeForwarderTree } - static member Empty : CcuTypeForwarderTable = { Root = CcuTypeForwarderTree.Empty } - member this.TryGetValue (path:string array) (item:string): Lazy option = + static member Empty: CcuTypeForwarderTable = { Root = CcuTypeForwarderTree.Empty } + + member this.TryGetValue (path: string array) (item: string) : Lazy option = CcuTypeForwarderTable.findInTree (ArraySegment path) item this.Root type CcuReference = string // ILAssemblyRef @@ -5765,44 +6363,45 @@ type CcuReference = string // ILAssemblyRef // the data structure, or it is a delayed fixup, i.e. an invalid dangling // reference that has not had an appropriate fixup applied. [] -type CcuThunk = +type CcuThunk = { - /// ccu.target is null when a reference is missing in the transitive closure of static references that - /// may potentially be required for the metadata of referenced DLLs. - mutable target: CcuData - name: CcuReference + /// ccu.target is null when a reference is missing in the transitive closure of static references that + /// may potentially be required for the metadata of referenced DLLs. + mutable target: CcuData + name: CcuReference } - /// Dereference the assembly reference - member ccu.Deref = - if isNull (box ccu.target) then - raise(UnresolvedReferenceNoRange ccu.name) + /// Dereference the assembly reference + member ccu.Deref = + if isNull (box ccu.target) then + raise (UnresolvedReferenceNoRange ccu.name) + ccu.target - + /// Indicates if this assembly reference is unresolved member ccu.IsUnresolvedReference = isNull (box ccu.target) /// Ensure the ccu is derefable in advance. Supply a path to attach to any resulting error message. - member ccu.EnsureDerefable(requiringPath: string[]) = - if ccu.IsUnresolvedReference then + member ccu.EnsureDerefable(requiringPath: string[]) = + if ccu.IsUnresolvedReference then let path = String.Join(".", requiringPath) - raise(UnresolvedPathReferenceNoRange(ccu.name, path)) - + raise (UnresolvedPathReferenceNoRange(ccu.name, path)) + /// Indicates that this DLL uses F# 2.0+ quotation literals somewhere. This is used to implement a restriction on static linking. - member ccu.UsesFSharp20PlusQuotations - with get() = ccu.Deref.UsesFSharp20PlusQuotations + member ccu.UsesFSharp20PlusQuotations + with get () = ccu.Deref.UsesFSharp20PlusQuotations and set v = ccu.Deref.UsesFSharp20PlusQuotations <- v /// The short name of the assembly being referenced member ccu.AssemblyName = ccu.name - /// Holds the data indicating how this assembly/module is referenced from the code being compiled. + /// Holds the data indicating how this assembly/module is referenced from the code being compiled. member ccu.ILScopeRef = ccu.Deref.ILScopeRef /// A unique stamp for this assembly member ccu.Stamp = ccu.Deref.Stamp - /// Holds the file name for the assembly, if any + /// Holds the file name for the assembly, if any member ccu.FileName = ccu.Deref.FileName /// Try to get the .NET Assembly, if known. May not be present for `IsFSharp` for @@ -5814,74 +6413,86 @@ type CcuThunk = member ccu.IsProviderGenerated = ccu.Deref.IsProviderGenerated /// Used to make 'forward' calls into the loader during linking - member ccu.ImportProvidedType ty: TType = ccu.Deref.ImportProvidedType ty + member ccu.ImportProvidedType ty : TType = ccu.Deref.ImportProvidedType ty #endif - /// The fully qualified assembly reference string to refer to this assembly. This is persisted in quotations + /// The fully qualified assembly reference string to refer to this assembly. This is persisted in quotations member ccu.QualifiedName = ccu.Deref.QualifiedName - /// A hint as to where does the code for the CCU live (e.g what was the tcConfig.implicitIncludeDir at compilation time for this DLL?) + /// A hint as to where does the code for the CCU live (e.g what was the tcConfig.implicitIncludeDir at compilation time for this DLL?) member ccu.SourceCodeDirectory = ccu.Deref.SourceCodeDirectory /// Indicates that this DLL was compiled using the F# compiler and has F# metadata member ccu.IsFSharp = ccu.Deref.IsFSharp /// A handle to the full specification of the contents of the module contained in this ccu - // NOTE: may contain transient state during typechecking + // NOTE: may contain transient state during typechecking member ccu.Contents = ccu.Deref.Contents /// The table of type forwarders for this assembly member ccu.TypeForwarders: CcuTypeForwarderTable = ccu.Deref.TypeForwarders /// The table of modules and namespaces at the "root" of the assembly - member ccu.RootModulesAndNamespaces = ccu.Contents.ModuleOrNamespaceType.ModuleAndNamespaceDefinitions + member ccu.RootModulesAndNamespaces = + ccu.Contents.ModuleOrNamespaceType.ModuleAndNamespaceDefinitions /// The table of type definitions at the "root" of the assembly - member ccu.RootTypeAndExceptionDefinitions = ccu.Contents.ModuleOrNamespaceType.TypeAndExceptionDefinitions + member ccu.RootTypeAndExceptionDefinitions = + ccu.Contents.ModuleOrNamespaceType.TypeAndExceptionDefinitions /// Create a CCU with the given name and contents - static member Create(nm, x) = - { target = x - name = nm } + static member Create(nm, x) = { target = x; name = nm } /// Create a CCU with the given name but where the contents have not yet been specified - static member CreateDelayed nm = - { target = Unchecked.defaultof<_> - name = nm } + static member CreateDelayed nm = + { + target = Unchecked.defaultof<_> + name = nm + } /// Fixup a CCU to have the given contents - member x.Fixup(avail: CcuThunk) = + member x.Fixup(avail: CcuThunk) = match box x.target with | null -> () - | _ -> + | _ -> // In the IDE we tolerate a double-fixup of FSHarp.Core when editing the FSharp.Core project itself - if x.AssemblyName <> "FSharp.Core" then - errorR(Failure("internal error: Fixup: the ccu thunk for assembly "+x.AssemblyName+" not delayed!")) + if x.AssemblyName <> "FSharp.Core" then + errorR ( + Failure( + "internal error: Fixup: the ccu thunk for assembly " + + x.AssemblyName + + " not delayed!" + ) + ) assert (avail.AssemblyName = x.AssemblyName) - x.target <- + + x.target <- match box avail.target with - | null -> error(Failure("internal error: ccu thunk '"+avail.name+"' not fixed up!")) + | null -> error (Failure("internal error: ccu thunk '" + avail.name + "' not fixed up!")) | _ -> avail.target /// Try to resolve a path into the CCU by referencing the .NET/CLI type forwarder table of the CCU - member ccu.TryForward(nlpath: string[], item: string) : EntityRef option = + member ccu.TryForward(nlpath: string[], item: string) : EntityRef option = ccu.EnsureDerefable nlpath + ccu.TypeForwarders.TryGetValue nlpath item |> Option.map (fun entity -> entity.Force()) /// Used to make forward calls into the type/assembly loader when comparing member signatures during linking - member ccu.MemberSignatureEquality(ty1: TType, ty2: TType) = + member ccu.MemberSignatureEquality(ty1: TType, ty2: TType) = ccu.Deref.MemberSignatureEquality ty1 ty2 - + [] member x.DebugText = x.ToString() /// Used at the end of compiling an assembly to get a frozen, final stable CCU /// for the compilation which we no longer mutate. member x.CloneWithFinalizedContents(ccuContents) = - { x with target = { x.target with Contents = ccuContents } } + { x with + target = { x.target with Contents = ccuContents } + } override ccu.ToString() = ccu.AssemblyName @@ -5897,17 +6508,20 @@ type CcuResolutionResult = [] member x.DebugText = x.ToString() - override x.ToString() = match x with ResolvedCcu ccu -> ccu.ToString() | UnresolvedCcu s -> "unresolved " + s + override x.ToString() = + match x with + | ResolvedCcu ccu -> ccu.ToString() + | UnresolvedCcu s -> "unresolved " + s /// Represents the information saved in the assembly signature data resource for an F# assembly [] type PickledCcuInfo = { - mspec: ModuleOrNamespace + mspec: ModuleOrNamespace - compileTimeWorkingDir: string + compileTimeWorkingDir: string - usesQuotations: bool + usesQuotations: bool } [] @@ -5915,7 +6529,6 @@ type PickledCcuInfo = override _.ToString() = "PickledCcuInfo(...)" - /// Represents a set of free local values. Computed and cached by later phases /// (never cached type checking). Cached in expressions. Not pickled. type FreeLocals = Zset @@ -5924,12 +6537,12 @@ type FreeLocals = Zset /// (never cached type checking). Cached in expressions. Not pickled. type FreeTypars = Zset -/// Represents a set of 'free' named type definitions. Used to collect the named type definitions referred to +/// Represents a set of 'free' named type definitions. Used to collect the named type definitions referred to /// from a type or expression. Computed and cached by later phases (never cached type checking). Cached /// in expressions. Not pickled. type FreeTycons = Zset -/// Represents a set of 'free' record field definitions. Used to collect the record field definitions referred to +/// Represents a set of 'free' record field definitions. Used to collect the record field definitions referred to /// from an expression. type FreeRecdFields = Zset @@ -5939,18 +6552,18 @@ type FreeUnionCases = Zset /// Represents a set of 'free' type-related elements, including named types, trait solutions, union cases and /// record fields. [] -type FreeTyvars = +type FreeTyvars = { - /// The summary of locally defined type definitions used in the expression. These may be made private by a signature - /// and we have to check various conditions associated with that. - FreeTycons: FreeTycons - - /// The summary of values used as trait solutions - FreeTraitSolutions: FreeLocals - - /// The summary of type parameters used in the expression. These may not escape the enclosing generic construct - /// and we have to check various conditions associated with that. - FreeTypars: FreeTypars + /// The summary of locally defined type definitions used in the expression. These may be made private by a signature + /// and we have to check various conditions associated with that. + FreeTycons: FreeTycons + + /// The summary of values used as trait solutions + FreeTraitSolutions: FreeLocals + + /// The summary of type parameters used in the expression. These may not escape the enclosing generic construct + /// and we have to check various conditions associated with that. + FreeTypars: FreeTypars } [] @@ -5963,34 +6576,35 @@ type FreeVarsCache = FreeVars cache /// Represents the set of free variables in an expression [] -type FreeVars = +type FreeVars = { - /// The summary of locally defined variables used in the expression. These may be hidden at let bindings etc. - /// or made private by a signature or marked 'internal' or 'private', and we have to check various conditions associated with that. - FreeLocals: FreeLocals - - /// Indicates if the expression contains a call to a protected member or a base call. - /// Calls to protected members and direct calls to super classes can't escape, also code can't be inlined - UsesMethodLocalConstructs: bool - - /// Indicates if the expression contains a call to rethrow that is not bound under a (try-)with branch. - /// Rethrow may only occur in such locations. - UsesUnboundRethrow: bool - - /// The summary of locally defined tycon representations used in the expression. These may be made private by a signature - /// or marked 'internal' or 'private' and we have to check various conditions associated with that. - FreeLocalTyconReprs: FreeTycons - - /// The summary of fields used in the expression. These may be made private by a signature - /// or marked 'internal' or 'private' and we have to check various conditions associated with that. - FreeRecdFields: FreeRecdFields - - /// The summary of union constructors used in the expression. These may be - /// marked 'internal' or 'private' and we have to check various conditions associated with that. - FreeUnionCases: FreeUnionCases - - /// See FreeTyvars above. - FreeTyvars: FreeTyvars } + /// The summary of locally defined variables used in the expression. These may be hidden at let bindings etc. + /// or made private by a signature or marked 'internal' or 'private', and we have to check various conditions associated with that. + FreeLocals: FreeLocals + + /// Indicates if the expression contains a call to a protected member or a base call. + /// Calls to protected members and direct calls to super classes can't escape, also code can't be inlined + UsesMethodLocalConstructs: bool + + /// Indicates if the expression contains a call to rethrow that is not bound under a (try-)with branch. + /// Rethrow may only occur in such locations. + UsesUnboundRethrow: bool + + /// The summary of locally defined tycon representations used in the expression. These may be made private by a signature + /// or marked 'internal' or 'private' and we have to check various conditions associated with that. + FreeLocalTyconReprs: FreeTycons + + /// The summary of fields used in the expression. These may be made private by a signature + /// or marked 'internal' or 'private' and we have to check various conditions associated with that. + FreeRecdFields: FreeRecdFields + + /// The summary of union constructors used in the expression. These may be + /// marked 'internal' or 'private' and we have to check various conditions associated with that. + FreeUnionCases: FreeUnionCases + + /// See FreeTyvars above. + FreeTyvars: FreeTyvars + } [] member x.DebugText = x.ToString() @@ -5998,167 +6612,231 @@ type FreeVars = override x.ToString() = "FreeVars(...)" /// A set of static methods for constructing types. -type Construct() = +type Construct() = + + static let taccessPublic = TAccess [] - static let taccessPublic = TAccess [] - /// Key a Tycon or TyconRef by decoded name - static member KeyTyconByDecodedName<'T> (nm: string) (x: 'T) : KeyValuePair = + static member KeyTyconByDecodedName<'T> (nm: string) (x: 'T) : KeyValuePair = KeyValuePair(DecodeGenericTypeName nm, x) /// Key a Tycon or TyconRef by both mangled and demangled name. /// Generic types can be accessed either by 'List' or 'List`1'. /// This lists both keys. - static member KeyTyconByAccessNames<'T> (nm: string) (x: 'T) : KeyValuePair[] = + static member KeyTyconByAccessNames<'T> (nm: string) (x: 'T) : KeyValuePair[] = match TryDemangleGenericNameAndPos nm with | ValueSome pos -> - let dnm = DemangleGenericTypeNameWithPos pos nm + let dnm = DemangleGenericTypeNameWithPos pos nm [| KeyValuePair(nm, x); KeyValuePair(dnm, x) |] - | _ -> - [| KeyValuePair(nm, x) |] + | _ -> [| KeyValuePair(nm, x) |] /// Create a new node for the contents of a module or namespace - static member NewModuleOrNamespaceType mkind tycons vals = + static member NewModuleOrNamespaceType mkind tycons vals = ModuleOrNamespaceType(mkind, QueueList.ofList vals, QueueList.ofList tycons) /// Create a new node for an empty module or namespace contents - static member NewEmptyModuleOrNamespaceType mkind = + static member NewEmptyModuleOrNamespaceType mkind = Construct.NewModuleOrNamespaceType mkind [] [] static member NewEmptyFSharpTyconData kind = - { fsobjmodel_cases = Construct.MakeUnionCases [] - fsobjmodel_kind = kind - fsobjmodel_vslots = [] - fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] } + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind = kind + fsobjmodel_vslots = [] + fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] + } #if !NO_TYPEPROVIDERS /// Create a new node for the representation information for a provided type definition - static member NewProvidedTyconRepr(resolutionEnvironment, st: Tainted, importProvidedType, isSuppressRelocate, m) = + static member NewProvidedTyconRepr(resolutionEnvironment, st: Tainted, importProvidedType, isSuppressRelocate, m) = let isErased = st.PUntaint((fun st -> st.IsErased), m) - let lazyBaseTy = - LazyWithContext.Create - ((fun (m, objTy) -> - let baseSystemTy = st.PApplyOption((fun st -> match st.BaseType with null -> None | ty -> Some (ty)), m) - match baseSystemTy with - | None -> objTy - | Some t -> importProvidedType t), - findOriginalException) - - TProvidedTypeRepr - { ResolutionEnvironment=resolutionEnvironment - ProvidedType=st - LazyBaseType=lazyBaseTy - UnderlyingTypeOfEnum = (fun () -> importProvidedType (st.PApply((fun st -> st.GetEnumUnderlyingType()), m))) - IsDelegate = (fun () -> st.PUntaint((fun st -> - let baseType = st.BaseType - match baseType with - | Null -> false - | NonNull x -> - match x with - | x when x.IsGenericType -> false - | x when x.DeclaringType <> null -> false - | x -> x.FullName = "System.Delegate" || x.FullName = "System.MulticastDelegate"), m)) - IsEnum = st.PUntaint((fun st -> st.IsEnum), m) - IsStructOrEnum = st.PUntaint((fun st -> st.IsValueType || st.IsEnum), m) - IsInterface = st.PUntaint((fun st -> st.IsInterface), m) - IsSealed = st.PUntaint((fun st -> st.IsSealed), m) - IsAbstract = st.PUntaint((fun st -> st.IsAbstract), m) - IsClass = st.PUntaint((fun st -> st.IsClass), m) - IsErased = isErased - IsSuppressRelocate = isSuppressRelocate } + let lazyBaseTy = + LazyWithContext.Create( + (fun (m, objTy) -> + let baseSystemTy = + st.PApplyOption( + (fun st -> + match st.BaseType with + | null -> None + | ty -> Some(ty)), + m + ) + + match baseSystemTy with + | None -> objTy + | Some t -> importProvidedType t), + findOriginalException + ) + + TProvidedTypeRepr + { + ResolutionEnvironment = resolutionEnvironment + ProvidedType = st + LazyBaseType = lazyBaseTy + UnderlyingTypeOfEnum = (fun () -> importProvidedType (st.PApply((fun st -> st.GetEnumUnderlyingType()), m))) + IsDelegate = + (fun () -> + st.PUntaint( + (fun st -> + let baseType = st.BaseType + + match baseType with + | Null -> false + | NonNull x -> + match x with + | x when x.IsGenericType -> false + | x when x.DeclaringType <> null -> false + | x -> x.FullName = "System.Delegate" || x.FullName = "System.MulticastDelegate"), + m + )) + IsEnum = st.PUntaint((fun st -> st.IsEnum), m) + IsStructOrEnum = st.PUntaint((fun st -> st.IsValueType || st.IsEnum), m) + IsInterface = st.PUntaint((fun st -> st.IsInterface), m) + IsSealed = st.PUntaint((fun st -> st.IsSealed), m) + IsAbstract = st.PUntaint((fun st -> st.IsAbstract), m) + IsClass = st.PUntaint((fun st -> st.IsClass), m) + IsErased = isErased + IsSuppressRelocate = isSuppressRelocate + } /// Create a new entity node for a provided type definition - static member NewProvidedTycon(resolutionEnvironment, st: Tainted, importProvidedType, isSuppressRelocate, m, ?access, ?cpath) = - let stamp = newStamp() + static member NewProvidedTycon + (resolutionEnvironment, st: Tainted, importProvidedType, isSuppressRelocate, m, ?access, ?cpath) + = + let stamp = newStamp () let name = st.PUntaint((fun st -> st.Name), m) let id = ident (name, m) - let kind = - let isMeasure = - st.PApplyWithProvider((fun (st, provider) -> - ignore provider - st.IsMeasure), m) - .PUntaintNoFailure(Operators.id) + + let kind = + let isMeasure = + st + .PApplyWithProvider( + (fun (st, provider) -> + ignore provider + st.IsMeasure), + m + ) + .PUntaintNoFailure(Operators.id) + if isMeasure then TyparKind.Measure else TyparKind.Type - let access = - match access with - | Some a -> a + let access = + match access with + | Some a -> a | None -> TAccess [] - let cpath = - match cpath with - | None -> + + let cpath = + match cpath with + | None -> let ilScopeRef = st.TypeProviderAssemblyRef let enclosingName = GetFSharpPathToProvidedType(st, m) - CompPath(ilScopeRef, SyntaxAccess.Unknown, enclosingName |> List.map(fun id->id, ModuleOrNamespaceKind.Namespace true)) + CompPath(ilScopeRef, SyntaxAccess.Unknown, enclosingName |> List.map (fun id -> id, ModuleOrNamespaceKind.Namespace true)) | Some p -> p + let pubpath = cpath.NestedPublicPath id - let repr = Construct.NewProvidedTyconRepr(resolutionEnvironment, st, importProvidedType, isSuppressRelocate, m) - - Tycon.New "tycon" - { entity_stamp=stamp - entity_logical_name=name - entity_range=m - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) - entity_attribs=[] // fetched on demand via est.fs API - entity_typars= LazyWithContext.NotLazy [] - entity_tycon_repr = repr - entity_tycon_tcaug=TyconAugmentation.Create() - entity_modul_type = MaybeLazy.Lazy(InterruptibleLazy(fun _ -> ModuleOrNamespaceType(Namespace true, QueueList.ofList [], QueueList.ofList []))) - // Generated types get internal accessibility - entity_pubpath = Some pubpath - entity_cpath = Some cpath - entity_il_repr_cache = newCache() - entity_opt_data = - match kind, access with - | TyparKind.Type, TAccess [] -> None - | _ -> Some { Entity.NewEmptyEntityOptData() with - entity_kind = kind - entity_accessibility = access } } + let repr = + Construct.NewProvidedTyconRepr(resolutionEnvironment, st, importProvidedType, isSuppressRelocate, m) + + Tycon.New + "tycon" + { + entity_stamp = stamp + entity_logical_name = name + entity_range = m + entity_flags = + EntityFlags( + usesPrefixDisplay = false, + isModuleOrNamespace = false, + preEstablishedHasDefaultCtor = false, + hasSelfReferentialCtor = false, + isStructRecordOrUnionType = false + ) + entity_attribs = [] // fetched on demand via est.fs API + entity_typars = LazyWithContext.NotLazy [] + entity_tycon_repr = repr + entity_tycon_tcaug = TyconAugmentation.Create() + entity_modul_type = + MaybeLazy.Lazy( + InterruptibleLazy(fun _ -> ModuleOrNamespaceType(Namespace true, QueueList.ofList [], QueueList.ofList [])) + ) + // Generated types get internal accessibility + entity_pubpath = Some pubpath + entity_cpath = Some cpath + entity_il_repr_cache = newCache () + entity_opt_data = + match kind, access with + | TyparKind.Type, TAccess [] -> None + | _ -> + Some + { Entity.NewEmptyEntityOptData() with + entity_kind = kind + entity_accessibility = access + } + } #endif /// Create a new entity node for a module or namespace - static member NewModuleOrNamespace cpath access (id: Ident) (xml: XmlDoc) attribs mtype = - let stamp = newStamp() - // Put the module suffix on if needed - Tycon.New "mspec" - { entity_logical_name=id.idText - entity_range = id.idRange - entity_stamp=stamp - entity_modul_type = mtype - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) - entity_typars=LazyWithContext.NotLazy [] - entity_tycon_repr = TNoRepr - entity_tycon_tcaug=TyconAugmentation.Create() - entity_pubpath=cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath id) - entity_cpath=cpath - entity_attribs=attribs - entity_il_repr_cache = newCache() - entity_opt_data = - match xml, access with - | doc, TAccess [] when doc.IsEmpty -> None - | _ -> Some { Entity.NewEmptyEntityOptData() with - entity_xmldoc = xml - entity_tycon_repr_accessibility = access - entity_accessibility = access } } + static member NewModuleOrNamespace cpath access (id: Ident) (xml: XmlDoc) attribs mtype = + let stamp = newStamp () + // Put the module suffix on if needed + Tycon.New + "mspec" + { + entity_logical_name = id.idText + entity_range = id.idRange + entity_stamp = stamp + entity_modul_type = mtype + entity_flags = + EntityFlags( + usesPrefixDisplay = false, + isModuleOrNamespace = true, + preEstablishedHasDefaultCtor = false, + hasSelfReferentialCtor = false, + isStructRecordOrUnionType = false + ) + entity_typars = LazyWithContext.NotLazy [] + entity_tycon_repr = TNoRepr + entity_tycon_tcaug = TyconAugmentation.Create() + entity_pubpath = cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath id) + entity_cpath = cpath + entity_attribs = attribs + entity_il_repr_cache = newCache () + entity_opt_data = + match xml, access with + | doc, TAccess [] when doc.IsEmpty -> None + | _ -> + Some + { Entity.NewEmptyEntityOptData() with + entity_xmldoc = xml + entity_tycon_repr_accessibility = access + entity_accessibility = access + } + } /// Create a new unfilled cache for free variable calculations static member NewFreeVarsCache() = newCache () /// Create the field tables for a record or class type - static member MakeRecdFieldsTable ucs: TyconRecdFields = - { FieldsByIndex = Array.ofList ucs - FieldsByName = ucs |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) } + static member MakeRecdFieldsTable ucs : TyconRecdFields = + { + FieldsByIndex = Array.ofList ucs + FieldsByName = ucs |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) + } /// Create the union case tables for a union type - static member MakeUnionCases ucs: TyconUnionData = - { CasesTable = - { CasesByIndex = Array.ofList ucs - CasesByName = NameMap.ofKeyedList (fun uc -> uc.LogicalName) ucs } - CompiledRepresentation=newCache() } + static member MakeUnionCases ucs : TyconUnionData = + { + CasesTable = + { + CasesByIndex = Array.ofList ucs + CasesByName = NameMap.ofKeyedList (fun uc -> uc.LogicalName) ucs + } + CompiledRepresentation = newCache () + } /// Create a node for a union type static member MakeUnionRepr ucs = @@ -6169,181 +6847,287 @@ type Construct() = fsobjmodel_kind = TFSharpUnion fsobjmodel_vslots = [] } + TFSharpTyconRepr repr /// Create a new type parameter node - static member NewTypar (kind, rigid, SynTypar(id, staticReq, isCompGen), isFromError, dynamicReq, attribs, eqDep, compDep) = + static member NewTypar(kind, rigid, SynTypar(id, staticReq, isCompGen), isFromError, dynamicReq, attribs, eqDep, compDep) = Typar.New - { typar_id = id - typar_stamp = newStamp() - typar_flags= TyparFlags(kind, rigid, isFromError, isCompGen, staticReq, dynamicReq, eqDep, compDep, false) - typar_solution = None - typar_astype = Unchecked.defaultof<_> - typar_opt_data = - match attribs with - | [] -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false } } + { + typar_id = id + typar_stamp = newStamp () + typar_flags = TyparFlags(kind, rigid, isFromError, isCompGen, staticReq, dynamicReq, eqDep, compDep, false) + typar_solution = None + typar_astype = Unchecked.defaultof<_> + typar_opt_data = + match attribs with + | [] -> None + | _ -> + Some + { + typar_il_name = None + typar_xmldoc = XmlDoc.Empty + typar_constraints = [] + typar_attribs = attribs + typar_is_contravariant = false + } + } /// Create a new type parameter node for a declared type parameter static member NewRigidTypar nm m = - Construct.NewTypar (TyparKind.Type, TyparRigidity.Rigid, SynTypar(mkSynId m nm, TyparStaticReq.None, true), false, TyparDynamicReq.Yes, [], false, false) + Construct.NewTypar( + TyparKind.Type, + TyparRigidity.Rigid, + SynTypar(mkSynId m nm, TyparStaticReq.None, true), + false, + TyparDynamicReq.Yes, + [], + false, + false + ) /// Create a new union case node - static member NewUnionCase id tys retTy attribs docOption access: UnionCase = - { Id = id - OwnXmlDoc = docOption - OtherXmlDoc = XmlDoc.Empty - XmlDocSig = "" - Accessibility = access - FieldTable = Construct.MakeRecdFieldsTable tys - ReturnType = retTy - Attribs = attribs - OtherRangeOpt = None } + static member NewUnionCase id tys retTy attribs docOption access : UnionCase = + { + Id = id + OwnXmlDoc = docOption + OtherXmlDoc = XmlDoc.Empty + XmlDocSig = "" + Accessibility = access + FieldTable = Construct.MakeRecdFieldsTable tys + ReturnType = retTy + Attribs = attribs + OtherRangeOpt = None + } /// Create a new TAST Entity node for an F# exception definition - static member NewExn cpath (id: Ident) access repr attribs (doc: XmlDoc) = - Tycon.New "exnc" - { entity_stamp = newStamp() - entity_attribs = attribs - entity_logical_name = id.idText - entity_range = id.idRange - entity_tycon_tcaug = TyconAugmentation.Create() - entity_pubpath = cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath id) - entity_modul_type = MaybeLazy.Strict (Construct.NewEmptyModuleOrNamespaceType ModuleOrType) - entity_cpath = cpath - entity_typars = LazyWithContext.NotLazy [] - entity_tycon_repr = TNoRepr - entity_flags = EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) - entity_il_repr_cache = newCache() - entity_opt_data = - match doc, access, repr with - | doc, TAccess [], TExnNone when doc.IsEmpty -> None - | _ -> Some { Entity.NewEmptyEntityOptData() with entity_xmldoc = doc; entity_accessibility = access; entity_tycon_repr_accessibility = access; entity_exn_info = repr } } + static member NewExn cpath (id: Ident) access repr attribs (doc: XmlDoc) = + Tycon.New + "exnc" + { + entity_stamp = newStamp () + entity_attribs = attribs + entity_logical_name = id.idText + entity_range = id.idRange + entity_tycon_tcaug = TyconAugmentation.Create() + entity_pubpath = cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath id) + entity_modul_type = MaybeLazy.Strict(Construct.NewEmptyModuleOrNamespaceType ModuleOrType) + entity_cpath = cpath + entity_typars = LazyWithContext.NotLazy [] + entity_tycon_repr = TNoRepr + entity_flags = + EntityFlags( + usesPrefixDisplay = false, + isModuleOrNamespace = false, + preEstablishedHasDefaultCtor = false, + hasSelfReferentialCtor = false, + isStructRecordOrUnionType = false + ) + entity_il_repr_cache = newCache () + entity_opt_data = + match doc, access, repr with + | doc, TAccess [], TExnNone when doc.IsEmpty -> None + | _ -> + Some + { Entity.NewEmptyEntityOptData() with + entity_xmldoc = doc + entity_accessibility = access + entity_tycon_repr_accessibility = access + entity_exn_info = repr + } + } /// Create a new TAST RecdField node for an F# class, struct or record field static member NewRecdField stat konst id nameGenerated ty isMutable isVolatile pattribs fattribs docOption access secret = - { rfield_mutable = isMutable - rfield_pattribs = pattribs - rfield_fattribs = fattribs - rfield_type = ty - rfield_static = stat - rfield_volatile = isVolatile - rfield_const = konst - rfield_access = access - rfield_secret = secret - rfield_xmldoc = docOption - rfield_otherxmldoc = XmlDoc.Empty - rfield_xmldocsig = "" - rfield_id = id - rfield_name_generated = nameGenerated - rfield_other_range = None } - + { + rfield_mutable = isMutable + rfield_pattribs = pattribs + rfield_fattribs = fattribs + rfield_type = ty + rfield_static = stat + rfield_volatile = isVolatile + rfield_const = konst + rfield_access = access + rfield_secret = secret + rfield_xmldoc = docOption + rfield_otherxmldoc = XmlDoc.Empty + rfield_xmldocsig = "" + rfield_id = id + rfield_name_generated = nameGenerated + rfield_other_range = None + } + /// Create a new type definition node - static member NewTycon (cpath, nm, m, access, reprAccess, kind, typars, doc: XmlDoc, usesPrefixDisplay, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, mtyp) = - let stamp = newStamp() - Tycon.New "tycon" - { entity_stamp=stamp - entity_logical_name=nm - entity_range=m - entity_flags=EntityFlags(usesPrefixDisplay=usesPrefixDisplay, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=preEstablishedHasDefaultCtor, hasSelfReferentialCtor=hasSelfReferentialCtor, isStructRecordOrUnionType=false) - entity_attribs=[] // fixed up after - entity_typars=typars - entity_tycon_repr = TNoRepr - entity_tycon_tcaug=TyconAugmentation.Create() - entity_modul_type = mtyp - entity_pubpath=cpath |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath (mkSynId m nm)) - entity_cpath = cpath - entity_il_repr_cache = newCache() - entity_opt_data = - match kind, doc, reprAccess, access with - | TyparKind.Type, doc, TAccess [], TAccess [] when doc.IsEmpty -> None - | _ -> Some { Entity.NewEmptyEntityOptData() with entity_kind = kind; entity_xmldoc = doc; entity_tycon_repr_accessibility = reprAccess; entity_accessibility=access } } + static member NewTycon + ( + cpath, + nm, + m, + access, + reprAccess, + kind, + typars, + doc: XmlDoc, + usesPrefixDisplay, + preEstablishedHasDefaultCtor, + hasSelfReferentialCtor, + mtyp + ) = + let stamp = newStamp () + + Tycon.New + "tycon" + { + entity_stamp = stamp + entity_logical_name = nm + entity_range = m + entity_flags = + EntityFlags( + usesPrefixDisplay = usesPrefixDisplay, + isModuleOrNamespace = false, + preEstablishedHasDefaultCtor = preEstablishedHasDefaultCtor, + hasSelfReferentialCtor = hasSelfReferentialCtor, + isStructRecordOrUnionType = false + ) + entity_attribs = [] // fixed up after + entity_typars = typars + entity_tycon_repr = TNoRepr + entity_tycon_tcaug = TyconAugmentation.Create() + entity_modul_type = mtyp + entity_pubpath = + cpath + |> Option.map (fun (cp: CompilationPath) -> cp.NestedPublicPath(mkSynId m nm)) + entity_cpath = cpath + entity_il_repr_cache = newCache () + entity_opt_data = + match kind, doc, reprAccess, access with + | TyparKind.Type, doc, TAccess [], TAccess [] when doc.IsEmpty -> None + | _ -> + Some + { Entity.NewEmptyEntityOptData() with + entity_kind = kind + entity_xmldoc = doc + entity_tycon_repr_accessibility = reprAccess + entity_accessibility = access + } + } /// Create a new type definition node for a .NET type definition static member NewILTycon nlpath (nm, m) tps (scoref: ILScopeRef, enc, tdef: ILTypeDef) mtyp = - let tycon = Construct.NewTycon(nlpath, nm, m, taccessPublic, taccessPublic, TyparKind.Type, tps, XmlDoc.Empty, true, false, false, mtyp) + let tycon = + Construct.NewTycon(nlpath, nm, m, taccessPublic, taccessPublic, TyparKind.Type, tps, XmlDoc.Empty, true, false, false, mtyp) - tycon.entity_tycon_repr <- TILObjectRepr (TILObjectReprData (scoref, enc, tdef)) + tycon.entity_tycon_repr <- TILObjectRepr(TILObjectReprData(scoref, enc, tdef)) tycon.TypeContents.tcaug_closed <- true tycon /// Create a new Val node - static member NewVal( - logicalName: string, - m: range, - compiledName, - ty, - isMutable, - isCompGen, - arity, - access, - recValInfo, - specialRepr, - baseOrThis, - attribs, - inlineInfo, - doc: XmlDoc, - isModuleOrMemberBinding, - isExtensionMember, - isIncrClassSpecialMember, - isTyFunc, - allowTypeInst, - isGeneratedEventVal, - konst, - actualParent) : Val = - - let stamp = newStamp() - let optData = + static member NewVal + ( + logicalName: string, + m: range, + compiledName, + ty, + isMutable, + isCompGen, + arity, + access, + recValInfo, + specialRepr, + baseOrThis, + attribs, + inlineInfo, + doc: XmlDoc, + isModuleOrMemberBinding, + isExtensionMember, + isIncrClassSpecialMember, + isTyFunc, + allowTypeInst, + isGeneratedEventVal, + konst, + actualParent + ) : Val = + + let stamp = newStamp () + + let optData = match compiledName, arity, konst, access, doc, specialRepr, actualParent, attribs with | None, None, None, TAccess [], doc, None, ParentNone, [] when doc.IsEmpty -> None - | _ -> + | _ -> { Val.NewEmptyValOptData() with - val_compiled_name = (match compiledName with Some v when v <> logicalName -> compiledName | _ -> None) + val_compiled_name = + (match compiledName with + | Some v when v <> logicalName -> compiledName + | _ -> None) val_repr_info = arity val_const = konst val_access = access val_xmldoc = doc val_member_info = specialRepr val_declaring_entity = actualParent - val_attribs = attribs } + val_attribs = attribs + } |> Some - let flags = ValFlags(recValInfo, baseOrThis, isCompGen, inlineInfo, isMutable, isModuleOrMemberBinding, isExtensionMember, isIncrClassSpecialMember, isTyFunc, allowTypeInst, isGeneratedEventVal) - - Val.New { - val_stamp = stamp - val_logical_name = logicalName - val_range = m - val_flags = flags - val_type = ty - val_opt_data = optData - } + let flags = + ValFlags( + recValInfo, + baseOrThis, + isCompGen, + inlineInfo, + isMutable, + isModuleOrMemberBinding, + isExtensionMember, + isIncrClassSpecialMember, + isTyFunc, + allowTypeInst, + isGeneratedEventVal + ) + + Val.New + { + val_stamp = stamp + val_logical_name = logicalName + val_range = m + val_flags = flags + val_type = ty + val_opt_data = optData + } /// Create the new contents of an overall assembly static member NewCcuContents sref m nm mty = - Construct.NewModuleOrNamespace (Some(CompPath(sref, SyntaxAccess.Unknown, []))) taccessPublic (ident(nm, m)) XmlDoc.Empty [] (MaybeLazy.Strict mty) - - /// Create a tycon based on an existing one using the function 'f'. - /// We require that we be given the new parent for the new tycon. - /// We pass the new tycon to 'f' in case it needs to reparent the - /// contents of the tycon. - static member NewModifiedTycon f (orig: Tycon) = - let data = { orig with entity_stamp = newStamp() } - Tycon.New "NewModifiedTycon" (f data) - - /// Create a module Tycon based on an existing one using the function 'f'. - /// We require that we be given the parent for the new module. - /// We pass the new module to 'f' in case it needs to reparent the - /// contents of the module. - static member NewModifiedModuleOrNamespace f orig = - orig |> Construct.NewModifiedTycon (fun d -> - { d with entity_modul_type = MaybeLazy.Strict (f (d.entity_modul_type.Force())) }) - - /// Create a Val based on an existing one using the function 'f'. - /// We require that we be given the parent for the new Val. - static member NewModifiedVal f (orig: Val) = - let stamp = newStamp() - let data' = f { orig with val_stamp=stamp } + Construct.NewModuleOrNamespace + (Some(CompPath(sref, SyntaxAccess.Unknown, []))) + taccessPublic + (ident (nm, m)) + XmlDoc.Empty + [] + (MaybeLazy.Strict mty) + + /// Create a tycon based on an existing one using the function 'f'. + /// We require that we be given the new parent for the new tycon. + /// We pass the new tycon to 'f' in case it needs to reparent the + /// contents of the tycon. + static member NewModifiedTycon f (orig: Tycon) = + let data = { orig with entity_stamp = newStamp () } + Tycon.New "NewModifiedTycon" (f data) + + /// Create a module Tycon based on an existing one using the function 'f'. + /// We require that we be given the parent for the new module. + /// We pass the new module to 'f' in case it needs to reparent the + /// contents of the module. + static member NewModifiedModuleOrNamespace f orig = + orig + |> Construct.NewModifiedTycon(fun d -> + { d with + entity_modul_type = MaybeLazy.Strict(f (d.entity_modul_type.Force())) + }) + + /// Create a Val based on an existing one using the function 'f'. + /// We require that we be given the parent for the new Val. + static member NewModifiedVal f (orig: Val) = + let stamp = newStamp () + let data' = f { orig with val_stamp = stamp } Val.New data' /// Create a new module or namespace node by cloning an existing one @@ -6351,18 +7135,20 @@ type Construct() = Construct.NewModifiedModuleOrNamespace id orig /// Create a new type definition node by cloning an existing one - static member NewClonedTycon orig = - Construct.NewModifiedTycon id orig + static member NewClonedTycon orig = Construct.NewModifiedTycon id orig #if !NO_TYPEPROVIDERS /// Compute the definition location of a provided item - static member ComputeDefinitionLocationOfProvidedItem<'T when 'T :> IProvidedCustomAttributeProvider> (p: Tainted<'T>) : range option = - let attrs = p.PUntaintNoFailure(fun x -> x.GetDefinitionLocationAttribute(p.TypeProvider.PUntaintNoFailure id)) + static member ComputeDefinitionLocationOfProvidedItem<'T when 'T :> IProvidedCustomAttributeProvider>(p: Tainted<'T>) : range option = + let attrs = + p.PUntaintNoFailure(fun x -> x.GetDefinitionLocationAttribute(p.TypeProvider.PUntaintNoFailure id)) + match attrs with - | None | Some (Null, _, _) -> None - | Some (NonNull filePath, line, column) -> + | None + | Some(Null, _, _) -> None + | Some(NonNull filePath, line, column) -> // Coordinates from type provider are 1-based for lines and columns // Coordinates internally in the F# compiler are 1-based for lines and 0-based for columns - let pos = Position.mkPos line (max 0 (column - 1)) + let pos = Position.mkPos line (max 0 (column - 1)) mkRange !!filePath pos pos |> Some #endif diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index 582d6767d7e..7248683665d 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -1,13 +1,13 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - + //------------------------------------------------------------------------- // Defines the typed abstract syntax trees used throughout the F# compiler. -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- module internal FSharp.Compiler.TypedTreeBasics open Internal.Utilities.Library -open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.CompilerGlobalState open FSharp.Compiler.Text open FSharp.Compiler.Syntax @@ -19,16 +19,26 @@ assert (sizeof = 8) assert (sizeof = 4) #endif -/// Metadata on values (names of arguments etc.) -module ValReprInfo = +/// Metadata on values (names of arguments etc.) +module ValReprInfo = - let unnamedTopArg1: ArgReprInfo = { Attribs = []; Name = None; OtherRange = None } + let unnamedTopArg1: ArgReprInfo = + { + Attribs = [] + Name = None + OtherRange = None + } - let unnamedTopArg = [unnamedTopArg1] + let unnamedTopArg = [ unnamedTopArg1 ] - let unitArgData: ArgReprInfo list list = [[]] + let unitArgData: ArgReprInfo list list = [ [] ] - let unnamedRetVal: ArgReprInfo = { Attribs = []; Name = None; OtherRange = None } + let unnamedRetVal: ArgReprInfo = + { + Attribs = [] + Name = None + OtherRange = None + } let selfMetadata = unnamedTopArg @@ -36,14 +46,27 @@ module ValReprInfo = let IsEmpty info = match info with - | ValReprInfo([], [], { Attribs = []; Name = None; OtherRange = None }) -> true + | ValReprInfo([], + [], + { + Attribs = [] + Name = None + OtherRange = None + }) -> true | _ -> false - let InferTyparInfo (tps: Typar list) = tps |> List.map (fun tp -> TyparReprInfo(tp.Id, tp.Kind)) + let InferTyparInfo (tps: Typar list) = + tps |> List.map (fun tp -> TyparReprInfo(tp.Id, tp.Kind)) - let InferArgReprInfo (v: Val) : ArgReprInfo = { Attribs = []; Name = Some v.Id; OtherRange = None } + let InferArgReprInfo (v: Val) : ArgReprInfo = + { + Attribs = [] + Name = Some v.Id + OtherRange = None + } - let InferArgReprInfos (vs: Val list list) = ValReprInfo([], List.mapSquared InferArgReprInfo vs, unnamedRetVal) + let InferArgReprInfos (vs: Val list list) = + ValReprInfo([], List.mapSquared InferArgReprInfo vs, unnamedRetVal) let HasNoArgs (ValReprInfo(n, args, _)) = n.IsEmpty && args.IsEmpty @@ -63,8 +86,7 @@ let arityOfVal (v: Val) = | Some info -> info let tryGetArityOfValForDisplay (v: Val) = - v.ValReprInfoForDisplay - |> Option.orElseWith (fun _ -> v.ValReprInfo) + v.ValReprInfoForDisplay |> Option.orElseWith (fun _ -> v.ValReprInfo) let arityOfValForDisplay (v: Val) = tryGetArityOfValForDisplay v |> Option.defaultValue ValReprInfo.emptyValData @@ -77,12 +99,12 @@ let mkTupInfo b = if b then tupInfoStruct else tupInfoRef let structnessDefault = false -let mkRawRefTupleTy tys = TType_tuple (tupInfoRef, tys) +let mkRawRefTupleTy tys = TType_tuple(tupInfoRef, tys) -let mkRawStructTupleTy tys = TType_tuple (tupInfoStruct, tys) +let mkRawStructTupleTy tys = TType_tuple(tupInfoStruct, tys) //--------------------------------------------------------------------------- -// Equality relations on locally defined things +// Equality relations on locally defined things //--------------------------------------------------------------------------- let typarEq (tp1: Typar) (tp2: Typar) = (tp1.Stamp = tp2.Stamp) @@ -94,12 +116,12 @@ let typarRefEq (tp1: Typar) (tp2: Typar) = (tp1 === tp2) let valEq (v1: Val) (v2: Val) = (v1 === v2) /// Equality on CCU references, implemented as reference equality except when unresolved -let ccuEq (ccu1: CcuThunk) (ccu2: CcuThunk) = - (ccu1 === ccu2) || - (if ccu1.IsUnresolvedReference || ccu2.IsUnresolvedReference then - ccu1.AssemblyName = ccu2.AssemblyName - else - ccu1.Contents === ccu2.Contents) +let ccuEq (ccu1: CcuThunk) (ccu2: CcuThunk) = + (ccu1 === ccu2) + || (if ccu1.IsUnresolvedReference || ccu2.IsUnresolvedReference then + ccu1.AssemblyName = ccu2.AssemblyName + else + ccu1.Contents === ccu2.Contents) /// For dereferencing in the middle of a pattern let (|ValDeref|) (vref: ValRef) = vref.Deref @@ -112,20 +134,28 @@ let mkRecdFieldRef tcref f = RecdFieldRef(tcref, f) let mkUnionCaseRef tcref c = UnionCaseRef(tcref, c) -let ERefLocal x: EntityRef = { binding=x; nlr=Unchecked.defaultof<_> } +let ERefLocal x : EntityRef = + { + binding = x + nlr = Unchecked.defaultof<_> + } -let ERefNonLocal x: EntityRef = { binding=Unchecked.defaultof<_>; nlr=x } +let ERefNonLocal x : EntityRef = + { + binding = Unchecked.defaultof<_> + nlr = x + } -let ERefNonLocalPreResolved x xref: EntityRef = { binding=x; nlr=xref } +let ERefNonLocalPreResolved x xref : EntityRef = { binding = x; nlr = xref } -let (|ERefLocal|ERefNonLocal|) (x: EntityRef) = - match box x.nlr with +let (|ERefLocal|ERefNonLocal|) (x: EntityRef) = + match box x.nlr with | null -> ERefLocal x.binding | _ -> ERefNonLocal x.nlr //-------------------------------------------------------------------------- // Construct local references -//-------------------------------------------------------------------------- +//-------------------------------------------------------------------------- let mkLocalTyconRef x = ERefLocal x @@ -134,46 +164,67 @@ let mkNonLocalEntityRef ccu mp = NonLocalEntityRef(ccu, mp) let mkNestedNonLocalEntityRef (nleref: NonLocalEntityRef) id = mkNonLocalEntityRef nleref.Ccu (Array.append nleref.Path [| id |]) -let mkNonLocalTyconRef nleref id = ERefNonLocal (mkNestedNonLocalEntityRef nleref id) +let mkNonLocalTyconRef nleref id = + ERefNonLocal(mkNestedNonLocalEntityRef nleref id) let mkNonLocalTyconRefPreResolved x nleref id = ERefNonLocalPreResolved x (mkNestedNonLocalEntityRef nleref id) -type EntityRef with +type EntityRef with - member tcref.NestedTyconRef (x: Entity) = - match tcref with + member tcref.NestedTyconRef(x: Entity) = + match tcref with | ERefLocal _ -> mkLocalTyconRef x | ERefNonLocal nlr -> mkNonLocalTyconRefPreResolved x nlr x.LogicalName - member tcref.RecdFieldRefInNestedTycon tycon (id: Ident) = RecdFieldRef (tcref.NestedTyconRef tycon, id.idText) + member tcref.RecdFieldRefInNestedTycon tycon (id: Ident) = + RecdFieldRef(tcref.NestedTyconRef tycon, id.idText) /// Make a reference to a union case for type in a module or namespace -let mkModuleUnionCaseRef (modref: ModuleOrNamespaceRef) tycon uc = +let mkModuleUnionCaseRef (modref: ModuleOrNamespaceRef) tycon uc = (modref.NestedTyconRef tycon).MakeNestedUnionCaseRef uc -let VRefLocal x: ValRef = { binding=x; nlr=Unchecked.defaultof<_> } +let VRefLocal x : ValRef = + { + binding = x + nlr = Unchecked.defaultof<_> + } -let VRefNonLocal x: ValRef = { binding=Unchecked.defaultof<_>; nlr=x } +let VRefNonLocal x : ValRef = + { + binding = Unchecked.defaultof<_> + nlr = x + } -let VRefNonLocalPreResolved x xref: ValRef = { binding=x; nlr=xref } +let VRefNonLocalPreResolved x xref : ValRef = { binding = x; nlr = xref } -let (|VRefLocal|VRefNonLocal|) (x: ValRef) = - match box x.nlr with +let (|VRefLocal|VRefNonLocal|) (x: ValRef) = + match box x.nlr with | null -> VRefLocal x.binding | _ -> VRefNonLocal x.nlr -let mkNonLocalValRef mp id = VRefNonLocal {EnclosingEntity = ERefNonLocal mp; ItemKey=id } - -let mkNonLocalValRefPreResolved x mp id = VRefNonLocalPreResolved x {EnclosingEntity = ERefNonLocal mp; ItemKey=id } - -let ccuOfValRef vref = - match vref with +let mkNonLocalValRef mp id = + VRefNonLocal + { + EnclosingEntity = ERefNonLocal mp + ItemKey = id + } + +let mkNonLocalValRefPreResolved x mp id = + VRefNonLocalPreResolved + x + { + EnclosingEntity = ERefNonLocal mp + ItemKey = id + } + +let ccuOfValRef vref = + match vref with | VRefLocal _ -> None | VRefNonLocal nlr -> Some nlr.Ccu -let ccuOfTyconRef eref = - match eref with +let ccuOfTyconRef eref = + match eref with | ERefLocal _ -> None | ERefNonLocal nlr -> Some nlr.Ccu @@ -181,7 +232,7 @@ let ccuOfTyconRef eref = // Type parameters and inference unknowns //------------------------------------------------------------------------- -let NewNullnessVar() = Nullness.Variable (NullnessVar()) // we don't known (and if we never find out then it's non-null) +let NewNullnessVar () = Nullness.Variable(NullnessVar()) // we don't known (and if we never find out then it's non-null) let KnownAmbivalentToNull = Nullness.Known NullnessInfo.AmbivalentToNull @@ -189,56 +240,74 @@ let KnownWithNull = Nullness.Known NullnessInfo.WithNull let KnownWithoutNull = Nullness.Known NullnessInfo.WithoutNull -let mkTyparTy (tp:Typar) = - match tp.Kind with +let mkTyparTy (tp: Typar) = + match tp.Kind with | TyparKind.Type -> tp.AsType KnownWithoutNull - | TyparKind.Measure -> TType_measure (Measure.Var tp) + | TyparKind.Measure -> TType_measure(Measure.Var tp) // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. -let copyTypar clearStaticReq (tp: Typar) = - let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant }) - let flags = if clearStaticReq then tp.typar_flags.WithStaticReq(TyparStaticReq.None) else tp.typar_flags - Typar.New { typar_id = tp.typar_id - typar_flags = flags - typar_stamp = newStamp() - typar_solution = tp.typar_solution - typar_astype = Unchecked.defaultof<_> - // Be careful to clone the mutable optional data too - typar_opt_data = optData } +let copyTypar clearStaticReq (tp: Typar) = + let optData = + tp.typar_opt_data + |> Option.map (fun tg -> + { + typar_il_name = tg.typar_il_name + typar_xmldoc = tg.typar_xmldoc + typar_constraints = tg.typar_constraints + typar_attribs = tg.typar_attribs + typar_is_contravariant = tg.typar_is_contravariant + }) + + let flags = + if clearStaticReq then + tp.typar_flags.WithStaticReq(TyparStaticReq.None) + else + tp.typar_flags + + Typar.New + { + typar_id = tp.typar_id + typar_flags = flags + typar_stamp = newStamp () + typar_solution = tp.typar_solution + typar_astype = Unchecked.defaultof<_> + // Be careful to clone the mutable optional data too + typar_opt_data = optData + } let copyTypars clearStaticReq tps = List.map (copyTypar clearStaticReq) tps //-------------------------------------------------------------------------- // Inference variables -//-------------------------------------------------------------------------- - -let tryShortcutSolvedUnitPar canShortcut (r: Typar) = - if r.Kind = TyparKind.Type then failwith "tryShortcutSolvedUnitPar: kind=type" +//-------------------------------------------------------------------------- + +let tryShortcutSolvedUnitPar canShortcut (r: Typar) = + if r.Kind = TyparKind.Type then + failwith "tryShortcutSolvedUnitPar: kind=type" + match r.Solution with - | Some (TType_measure unt) -> - if canShortcut then - match unt with - | Measure.Var r2 -> - match r2.Solution with - | None -> () - | Some _ as soln -> - r.typar_solution <- soln - | _ -> () + | Some(TType_measure unt) -> + if canShortcut then + match unt with + | Measure.Var r2 -> + match r2.Solution with + | None -> () + | Some _ as soln -> r.typar_solution <- soln + | _ -> () + unt - | _ -> - failwith "tryShortcutSolvedUnitPar: unsolved" - -let rec stripUnitEqnsAux canShortcut unt = - match unt with + | _ -> failwith "tryShortcutSolvedUnitPar: unsolved" + +let rec stripUnitEqnsAux canShortcut unt = + match unt with | Measure.Var r when r.IsSolved -> stripUnitEqnsAux canShortcut (tryShortcutSolvedUnitPar canShortcut r) | _ -> unt -let combineNullness (nullnessOrig: Nullness) (nullnessNew: Nullness) = +let combineNullness (nullnessOrig: Nullness) (nullnessNew: Nullness) = match nullnessOrig, nullnessNew with - | Nullness.Variable _, Nullness.Known NullnessInfo.WithoutNull -> - nullnessOrig - | _ -> + | Nullness.Variable _, Nullness.Known NullnessInfo.WithoutNull -> nullnessOrig + | _ -> match nullnessOrig.Evaluate() with | NullnessInfo.WithoutNull -> nullnessNew | NullnessInfo.AmbivalentToNull -> @@ -246,99 +315,103 @@ let combineNullness (nullnessOrig: Nullness) (nullnessNew: Nullness) = | NullnessInfo.WithoutNull -> nullnessOrig | NullnessInfo.AmbivalentToNull -> nullnessOrig | NullnessInfo.WithNull -> nullnessNew - | NullnessInfo.WithNull -> + | NullnessInfo.WithNull -> match nullnessNew.Evaluate() with | NullnessInfo.WithoutNull -> nullnessOrig | NullnessInfo.AmbivalentToNull -> nullnessNew | NullnessInfo.WithNull -> nullnessOrig -let nullnessEquiv (nullnessOrig: Nullness) (nullnessNew: Nullness) = LanguagePrimitives.PhysicalEquality nullnessOrig nullnessNew +let nullnessEquiv (nullnessOrig: Nullness) (nullnessNew: Nullness) = + LanguagePrimitives.PhysicalEquality nullnessOrig nullnessNew -let tryAddNullnessToTy nullnessNew (ty:TType) = +let tryAddNullnessToTy nullnessNew (ty: TType) = match ty with - | TType_var (tp, nullnessOrig) -> + | TType_var(tp, nullnessOrig) -> let nullnessAfter = combineNullness nullnessOrig nullnessNew + if nullnessEquiv nullnessAfter nullnessOrig then Some ty - else - Some (TType_var (tp, nullnessAfter)) - | TType_app (tcr, tinst, nullnessOrig) -> + else + Some(TType_var(tp, nullnessAfter)) + | TType_app(tcr, tinst, nullnessOrig) -> let nullnessAfter = combineNullness nullnessOrig nullnessNew + if nullnessEquiv nullnessAfter nullnessOrig then Some ty - else - Some (TType_app (tcr, tinst, nullnessAfter)) + else + Some(TType_app(tcr, tinst, nullnessAfter)) | TType_ucase _ -> None | TType_tuple _ -> None | TType_anon _ -> None - | TType_fun (d, r, nullnessOrig) -> + | TType_fun(d, r, nullnessOrig) -> let nullnessAfter = combineNullness nullnessOrig nullnessNew + if nullnessEquiv nullnessAfter nullnessOrig then Some ty - else - Some (TType_fun (d, r, nullnessAfter)) + else + Some(TType_fun(d, r, nullnessAfter)) | TType_forall _ -> None | TType_measure _ -> None -let addNullnessToTy (nullness: Nullness) (ty:TType) = +let addNullnessToTy (nullness: Nullness) (ty: TType) = match nullness with | Nullness.Known NullnessInfo.WithoutNull -> ty | Nullness.Variable nv when nv.IsFullySolved && nv.TryEvaluate() = ValueSome NullnessInfo.WithoutNull -> ty - | _ -> + | _ -> + match ty with + | TType_var(tp, nullnessOrig) -> TType_var(tp, combineNullness nullnessOrig nullness) + | TType_app(tcr, tinst, nullnessOrig) -> + let tycon = tcr.Deref + + if tycon.IsStructRecordOrUnionTycon || tycon.IsStructOrEnumTycon then + ty + else + TType_app(tcr, tinst, combineNullness nullnessOrig nullness) + | TType_fun(d, r, nullnessOrig) -> TType_fun(d, r, combineNullness nullnessOrig nullness) + | _ -> ty + +let rec stripTyparEqnsAux nullness0 canShortcut ty = match ty with - | TType_var (tp, nullnessOrig) -> TType_var (tp, combineNullness nullnessOrig nullness) - | TType_app (tcr, tinst, nullnessOrig) -> - let tycon = tcr.Deref - if tycon.IsStructRecordOrUnionTycon || tycon.IsStructOrEnumTycon then - ty - else - TType_app (tcr, tinst, combineNullness nullnessOrig nullness) - | TType_fun (d, r, nullnessOrig) -> TType_fun (d, r, combineNullness nullnessOrig nullness) - | _ -> ty - -let rec stripTyparEqnsAux nullness0 canShortcut ty = - match ty with - | TType_var (r, nullness) -> + | TType_var(r, nullness) -> match r.Solution with - | Some soln -> - if canShortcut then - match soln with + | Some soln -> + if canShortcut then + match soln with // We avoid shortcutting when there are additional constraints on the type variable we're trying to cut out // This is only because IterType likes to walk _all_ the constraints _everywhere_ in a type, including // those attached to _solved_ type variables. In an ideal world this would never be needed - see the notes // on IterType. - | TType_var (r2, nullness2) when r2.Constraints.IsEmpty -> - match nullness2.Evaluate() with - | NullnessInfo.WithoutNull -> - match r2.Solution with - | None -> () - | Some _ as soln2 -> - r.typar_solution <- soln2 - | _ -> () - | _ -> () + | TType_var(r2, nullness2) when r2.Constraints.IsEmpty -> + match nullness2.Evaluate() with + | NullnessInfo.WithoutNull -> + match r2.Solution with + | None -> () + | Some _ as soln2 -> r.typar_solution <- soln2 + | _ -> () + | _ -> () + stripTyparEqnsAux (combineNullness nullness0 nullness) canShortcut soln - | None -> - addNullnessToTy nullness0 ty - | TType_measure unt -> - TType_measure (stripUnitEqnsAux canShortcut unt) + | None -> addNullnessToTy nullness0 ty + | TType_measure unt -> TType_measure(stripUnitEqnsAux canShortcut unt) | _ -> addNullnessToTy nullness0 ty -let stripTyparEqns ty = stripTyparEqnsAux KnownWithoutNull false ty +let stripTyparEqns ty = + stripTyparEqnsAux KnownWithoutNull false ty let stripUnitEqns unt = stripUnitEqnsAux false unt -let replaceNullnessOfTy nullness (ty:TType) = +let replaceNullnessOfTy nullness (ty: TType) = match stripTyparEqns ty with - | TType_var (tp, _) -> TType_var (tp, nullness) - | TType_app (tcr, tinst, _) -> TType_app (tcr, tinst, nullness) - | TType_fun (d, r, _) -> TType_fun (d, r, nullness) + | TType_var(tp, _) -> TType_var(tp, nullness) + | TType_app(tcr, tinst, _) -> TType_app(tcr, tinst, nullness) + | TType_fun(d, r, _) -> TType_fun(d, r, nullness) | sty -> sty /// Detect a use of a nominal type, including type abbreviations. [] let (|AbbrevOrAppTy|_|) (ty: TType) = match stripTyparEqns ty with - | TType_app (tcref, tinst, _) -> ValueSome(tcref, tinst) + | TType_app(tcref, tinst, _) -> ValueSome(tcref, tinst) | _ -> ValueNone //--------------------------------------------------------------------------- @@ -350,17 +423,19 @@ let mkLocalValRef (v: Val) = VRefLocal v let mkLocalModuleRef (v: ModuleOrNamespace) = ERefLocal v let mkLocalEntityRef (v: Entity) = ERefLocal v -let mkNonLocalCcuRootEntityRef ccu (x: Entity) = mkNonLocalTyconRefPreResolved x (mkNonLocalEntityRef ccu [| |]) x.LogicalName +let mkNonLocalCcuRootEntityRef ccu (x: Entity) = + mkNonLocalTyconRefPreResolved x (mkNonLocalEntityRef ccu [||]) x.LogicalName -let mkNestedValRef (cref: EntityRef) (v: Val) : ValRef = - match cref with +let mkNestedValRef (cref: EntityRef) (v: Val) : ValRef = + match cref with | ERefLocal _ -> mkLocalValRef v - | ERefNonLocal nlr -> + | ERefNonLocal nlr -> let key = v.GetLinkageFullKey() mkNonLocalValRefPreResolved v nlr key /// From Ref_private to Ref_nonlocal when exporting data. -let rescopePubPathToParent viewedCcu (PubPath p) = NonLocalEntityRef(viewedCcu, p[0..p.Length-2]) +let rescopePubPathToParent viewedCcu (PubPath p) = + NonLocalEntityRef(viewedCcu, p[0 .. p.Length - 2]) /// From Ref_private to Ref_nonlocal when exporting data. let rescopePubPath viewedCcu (PubPath p) = NonLocalEntityRef(viewedCcu, p) @@ -369,66 +444,67 @@ let rescopePubPath viewedCcu (PubPath p) = NonLocalEntityRef(viewedCcu, p) // Equality between TAST items. //--------------------------------------------------------------------------- -let valRefInThisAssembly compilingFSharpCore (x: ValRef) = - match x with +let valRefInThisAssembly compilingFSharpCore (x: ValRef) = + match x with | VRefLocal _ -> true | VRefNonLocal _ -> compilingFSharpCore -let tyconRefUsesLocalXmlDoc compilingFSharpCore (x: TyconRef) = - match x with +let tyconRefUsesLocalXmlDoc compilingFSharpCore (x: TyconRef) = + match x with | ERefLocal _ -> true | ERefNonLocal _ -> #if !NO_TYPEPROVIDERS match x.TypeReprInfo with | TProvidedTypeRepr _ -> true - | _ -> + | _ -> #endif compilingFSharpCore - -let entityRefInThisAssembly compilingFSharpCore (x: EntityRef) = - match x with + +let entityRefInThisAssembly compilingFSharpCore (x: EntityRef) = + match x with | ERefLocal _ -> true | ERefNonLocal _ -> compilingFSharpCore let arrayPathEq (y1: string[]) (y2: string[]) = - let len1 = y1.Length - let len2 = y2.Length - (len1 = len2) && - (let rec loop i = (i >= len1) || (y1[i] = y2[i] && loop (i+1)) - loop 0) + let len1 = y1.Length + let len2 = y2.Length + + (len1 = len2) + && (let rec loop i = + (i >= len1) || (y1[i] = y2[i] && loop (i + 1)) -let nonLocalRefEq (NonLocalEntityRef(x1, y1) as smr1) (NonLocalEntityRef(x2, y2) as smr2) = + loop 0) + +let nonLocalRefEq (NonLocalEntityRef(x1, y1) as smr1) (NonLocalEntityRef(x2, y2) as smr2) = smr1 === smr2 || (ccuEq x1 x2 && arrayPathEq y1 y2) /// This predicate tests if non-local resolution paths are definitely known to resolve -/// to different entities. All references with different named paths always resolve to -/// different entities. Two references with the same named paths may resolve to the same +/// to different entities. All references with different named paths always resolve to +/// different entities. Two references with the same named paths may resolve to the same /// entities even if they reference through different CCUs, because one reference /// may be forwarded to another via a .NET TypeForwarder. -let nonLocalRefDefinitelyNotEq (NonLocalEntityRef(_, y1)) (NonLocalEntityRef(_, y2)) = - not (arrayPathEq y1 y2) +let nonLocalRefDefinitelyNotEq (NonLocalEntityRef(_, y1)) (NonLocalEntityRef(_, y2)) = not (arrayPathEq y1 y2) let pubPathEq (PubPath path1) (PubPath path2) = arrayPathEq path1 path2 -let fslibRefEq (nlr1: NonLocalEntityRef) (PubPath path2) = - arrayPathEq nlr1.Path path2 +let fslibRefEq (nlr1: NonLocalEntityRef) (PubPath path2) = arrayPathEq nlr1.Path path2 // Compare two EntityRef's for equality when compiling fslib (FSharp.Core.dll) // // Compiler-internal references to items in fslib are Ref_nonlocals even when compiling fslib. -// This breaks certain invariants that hold elsewhere, because they dereference to point to -// Entity's from signatures rather than Entity's from implementations. This means backup, alternative +// This breaks certain invariants that hold elsewhere, because they dereference to point to +// Entity's from signatures rather than Entity's from implementations. This means backup, alternative // equality comparison techniques are needed when compiling fslib itself. let fslibEntityRefEq fslibCcu (eref1: EntityRef) (eref2: EntityRef) = - match eref1, eref2 with + match eref1, eref2 with | ERefNonLocal nlr1, ERefLocal x2 | ERefLocal x2, ERefNonLocal nlr1 -> - ccuEq nlr1.Ccu fslibCcu && - match x2.PublicPath with - | Some pp2 -> fslibRefEq nlr1 pp2 - | None -> false + ccuEq nlr1.Ccu fslibCcu + && match x2.PublicPath with + | Some pp2 -> fslibRefEq nlr1 pp2 + | None -> false | ERefLocal e1, ERefLocal e2 -> - match e1.PublicPath, e2.PublicPath with + match e1.PublicPath, e2.PublicPath with | Some pp1, Some pp2 -> pubPathEq pp1 pp2 | _ -> false | _ -> false @@ -436,62 +512,71 @@ let fslibEntityRefEq fslibCcu (eref1: EntityRef) (eref2: EntityRef) = // Compare two ValRef's for equality when compiling fslib (FSharp.Core.dll) // // Compiler-internal references to items in fslib are Ref_nonlocals even when compiling fslib. -// This breaks certain invariants that hold elsewhere, because they dereference to point to -// Val's from signatures rather than Val's from implementations. This means backup, alternative +// This breaks certain invariants that hold elsewhere, because they dereference to point to +// Val's from signatures rather than Val's from implementations. This means backup, alternative // equality comparison techniques are needed when compiling fslib itself. let fslibValRefEq fslibCcu vref1 vref2 = - match vref1, vref2 with + match vref1, vref2 with | VRefNonLocal nlr1, VRefLocal x2 | VRefLocal x2, VRefNonLocal nlr1 -> - ccuEq nlr1.Ccu fslibCcu && - match x2.PublicPath with - | Some (ValPubPath(pp2, nm2)) -> - // Note: this next line is just comparing the values by name, and not even the partial linkage data - // This relies on the fact that the compiler doesn't use any references to - // entities in fslib that are overloaded, or, if they are overloaded, then value identity - // is not significant - nlr1.ItemKey.PartialKey = nm2.PartialKey && - fslibRefEq nlr1.EnclosingEntity.nlr pp2 - | _ -> - false + ccuEq nlr1.Ccu fslibCcu + && match x2.PublicPath with + | Some(ValPubPath(pp2, nm2)) -> + // Note: this next line is just comparing the values by name, and not even the partial linkage data + // This relies on the fact that the compiler doesn't use any references to + // entities in fslib that are overloaded, or, if they are overloaded, then value identity + // is not significant + nlr1.ItemKey.PartialKey = nm2.PartialKey + && fslibRefEq nlr1.EnclosingEntity.nlr pp2 + | _ -> false // Note: I suspect this private-to-private reference comparison is not needed | VRefLocal e1, VRefLocal e2 -> - match e1.PublicPath, e2.PublicPath with - | Some (ValPubPath(pp1, nm1)), Some (ValPubPath(pp2, nm2)) -> - pubPathEq pp1 pp2 && - (nm1 = nm2) + match e1.PublicPath, e2.PublicPath with + | Some(ValPubPath(pp1, nm1)), Some(ValPubPath(pp2, nm2)) -> pubPathEq pp1 pp2 && (nm1 = nm2) | _ -> false | _ -> false - + /// Primitive routine to compare two EntityRef's for equality /// This takes into account the possibility that they may have type forwarders -let primEntityRefEq compilingFSharpCore fslibCcu (x: EntityRef) (y: EntityRef) = - x === y || - +let primEntityRefEq compilingFSharpCore fslibCcu (x: EntityRef) (y: EntityRef) = + x === y + || + if x.IsResolved && y.IsResolved && not compilingFSharpCore then - x.ResolvedTarget === y.ResolvedTarget - elif not x.IsLocalRef && not y.IsLocalRef && - (// Two tcrefs with identical paths are always equal - nonLocalRefEq x.nlr y.nlr || - // The tcrefs may have forwarders. If they may possibly be equal then resolve them to get their canonical references - // and compare those using pointer equality. - (not (nonLocalRefDefinitelyNotEq x.nlr y.nlr) && - match x.TryDeref with - | ValueSome v1 -> match y.TryDeref with ValueSome v2 -> v1 === v2 | _ -> false - | _ -> match y.TryDeref with ValueNone -> true | _ -> false)) then + x.ResolvedTarget === y.ResolvedTarget + elif + not x.IsLocalRef + && not y.IsLocalRef + && ( // Two tcrefs with identical paths are always equal + nonLocalRefEq x.nlr y.nlr + || + // The tcrefs may have forwarders. If they may possibly be equal then resolve them to get their canonical references + // and compare those using pointer equality. + (not (nonLocalRefDefinitelyNotEq x.nlr y.nlr) + && match x.TryDeref with + | ValueSome v1 -> + match y.TryDeref with + | ValueSome v2 -> v1 === v2 + | _ -> false + | _ -> + match y.TryDeref with + | ValueNone -> true + | _ -> false)) + then true else - compilingFSharpCore && fslibEntityRefEq fslibCcu x y + compilingFSharpCore && fslibEntityRefEq fslibCcu x y /// Primitive routine to compare two UnionCaseRef's for equality -let primUnionCaseRefEq compilingFSharpCore fslibCcu (UnionCaseRef(tcr1, c1) as uc1) (UnionCaseRef(tcr2, c2) as uc2) = - uc1 === uc2 || (primEntityRefEq compilingFSharpCore fslibCcu tcr1 tcr2 && c1 = c2) +let primUnionCaseRefEq compilingFSharpCore fslibCcu (UnionCaseRef(tcr1, c1) as uc1) (UnionCaseRef(tcr2, c2) as uc2) = + uc1 === uc2 + || (primEntityRefEq compilingFSharpCore fslibCcu tcr1 tcr2 && c1 = c2) /// Primitive routine to compare two ValRef's for equality. On the whole value identity is not particularly /// significant in F#. However it is significant for -/// (a) Active Patterns -/// (b) detecting uses of "special known values" from FSharp.Core.dll, such as 'seq' -/// and quotation splicing +/// (a) Active Patterns +/// (b) detecting uses of "special known values" from FSharp.Core.dll, such as 'seq' +/// and quotation splicing /// /// Note this routine doesn't take type forwarding into account let primValRefEq compilingFSharpCore fslibCcu (x: ValRef) (y: ValRef) = @@ -499,60 +584,80 @@ let primValRefEq compilingFSharpCore fslibCcu (x: ValRef) (y: ValRef) = || (x.IsResolved && y.IsResolved && x.ResolvedTarget === y.ResolvedTarget) || (x.IsLocalRef && y.IsLocalRef && valEq x.ResolvedTarget y.ResolvedTarget) || // Use TryDeref to guard against the platforms/times when certain F# language features aren't available - match x.TryDeref with - | ValueSome v1 -> match y.TryDeref with ValueSome v2 -> v1 === v2 | ValueNone -> false - | ValueNone -> match y.TryDeref with ValueNone -> true | ValueSome _ -> false + match x.TryDeref with + | ValueSome v1 -> + match y.TryDeref with + | ValueSome v2 -> v1 === v2 + | ValueNone -> false + | ValueNone -> + match y.TryDeref with + | ValueNone -> true + | ValueSome _ -> false || (compilingFSharpCore && fslibValRefEq fslibCcu x y) //--------------------------------------------------------------------------- // pubpath/cpath mess //--------------------------------------------------------------------------- -let fullCompPathOfModuleOrNamespace (m: ModuleOrNamespace) = +let fullCompPathOfModuleOrNamespace (m: ModuleOrNamespace) = let (CompPath(scoref, sa, cpath)) = m.CompilationPath - CompPath(scoref, sa, cpath@[(m.LogicalName, m.ModuleOrNamespaceType.ModuleOrNamespaceKind)]) + CompPath(scoref, sa, cpath @ [ (m.LogicalName, m.ModuleOrNamespaceType.ModuleOrNamespaceKind) ]) // Can cpath2 be accessed given a right to access cpath1. That is, is cpath2 a nested type or namespace of cpath1. Note order of arguments. let inline canAccessCompPathFrom (CompPath(scoref1, _, cpath1)) (CompPath(scoref2, _, cpath2)) = - let rec loop p1 p2 = - match p1, p2 with - | (a1, k1) :: rest1, (a2, k2) :: rest2 -> (a1=a2) && (k1=k2) && loop rest1 rest2 - | [], _ -> true + let rec loop p1 p2 = + match p1, p2 with + | (a1, k1) :: rest1, (a2, k2) :: rest2 -> (a1 = a2) && (k1 = k2) && loop rest1 rest2 + | [], _ -> true | _ -> false // cpath1 is longer - loop cpath1 cpath2 && - (scoref1 = scoref2) + + loop cpath1 cpath2 && (scoref1 = scoref2) let canAccessFromOneOf cpaths cpathTest = - cpaths |> List.exists (fun cpath -> canAccessCompPathFrom cpath cpathTest) + cpaths |> List.exists (fun cpath -> canAccessCompPathFrom cpath cpathTest) -let canAccessFrom (TAccess x) cpath = +let canAccessFrom (TAccess x) cpath = x |> List.forall (fun cpath1 -> canAccessCompPathFrom cpath1 cpath) let canAccessFromEverywhere (TAccess x) = x.IsEmpty let canAccessFromSomewhere (TAccess _) = true -let isLessAccessible (TAccess aa) (TAccess bb) = - not (aa |> List.forall(fun a -> bb |> List.exists (fun b -> canAccessCompPathFrom a b))) + +let isLessAccessible (TAccess aa) (TAccess bb) = + not ( + aa + |> List.forall (fun a -> bb |> List.exists (fun b -> canAccessCompPathFrom a b)) + ) /// Given (newPath, oldPath) replace oldPath by newPath in the TAccess. let accessSubstPaths (newPath, oldPath) (TAccess paths) = - let subst cpath = if cpath=oldPath then newPath else cpath - TAccess (List.map subst paths) + let subst cpath = + if cpath = oldPath then newPath else cpath + + TAccess(List.map subst paths) + +let compPathOfCcu (ccu: CcuThunk) = + CompPath(ccu.ILScopeRef, SyntaxAccess.Unknown, []) -let compPathOfCcu (ccu: CcuThunk) = CompPath(ccu.ILScopeRef, SyntaxAccess.Unknown, []) let taccessPublic = TAccess [] let compPathInternal = CompPath(ILScopeRef.Local, SyntaxAccess.Internal, []) -let taccessInternal = TAccess [compPathInternal] -let taccessPrivate accessPath = let (CompPath(sc,_, paths)) = accessPath in TAccess [CompPath(sc, TypedTree.SyntaxAccess.Private, paths)] +let taccessInternal = TAccess [ compPathInternal ] + +let taccessPrivate accessPath = + let (CompPath(sc, _, paths)) = accessPath in TAccess [ CompPath(sc, TypedTree.SyntaxAccess.Private, paths) ] let combineAccess access1 access2 = let (TAccess a1) = access1 let (TAccess a2) = access2 + let combined = - if access1 = taccessPublic then updateSyntaxAccessForCompPath (a1@a2) TypedTree.SyntaxAccess.Public - elif access1 = taccessInternal then updateSyntaxAccessForCompPath (a1@a2) TypedTree.SyntaxAccess.Internal - else (a1@a2) + if access1 = taccessPublic then + updateSyntaxAccessForCompPath (a1 @ a2) TypedTree.SyntaxAccess.Public + elif access1 = taccessInternal then + updateSyntaxAccessForCompPath (a1 @ a2) TypedTree.SyntaxAccess.Internal + else + (a1 @ a2) + TAccess combined exception Duplicate of string * string * range exception NameClash of string * string * string * range * string * string * range - diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index b14dbd753b1..b802d714fe4 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -38,70 +38,79 @@ let AccFreeVarsStackGuardDepth = GetEnvInteger "FSHARP_AccFreeVars" 100 let RemapExprStackGuardDepth = GetEnvInteger "FSHARP_RemapExpr" 50 let FoldExprStackGuardDepth = GetEnvInteger "FSHARP_FoldExpr" 50 -let inline compareBy (x: 'T MaybeNull) (y: 'T MaybeNull) ([]func: 'T -> 'K) = - match x,y with - | null,null -> 0 - | null,_ -> -1 - | _,null -> 1 - | x,y -> compare (func !!x) (func !!y) +let inline compareBy (x: 'T MaybeNull) (y: 'T MaybeNull) ([] 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> = +type TyparMap<'T> = | TPMap of StampMap<'T> - member tm.Item - with get (tp: Typar) = + member tm.Item + with get (tp: Typar) = let (TPMap m) = tm m[tp.Stamp] - member tm.ContainsKey (tp: Typar) = + member tm.ContainsKey(tp: Typar) = let (TPMap m) = tm m.ContainsKey(tp.Stamp) - - member tm.TryGetValue (tp: Typar) = + + member tm.TryGetValue(tp: Typar) = let (TPMap m) = tm m.TryGetValue(tp.Stamp) - member tm.TryFind (tp: Typar) = + member tm.TryFind(tp: Typar) = let (TPMap m) = tm m.TryFind(tp.Stamp) - member tm.Add (tp: Typar, x) = + member tm.Add(tp: Typar, x) = let (TPMap m) = tm - TPMap (m.Add(tp.Stamp, x)) + 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 _.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 + 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) + + static member OfList vs = + (vs, TyconRefMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add x y) [] [] -type ValMap<'T>(imap: StampMap<'T>) = - +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)) + + 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) + + static member OfList vs = + (vs, ValMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add x y) //-------------------------------------------------------------------------- // renamings @@ -117,52 +126,57 @@ let emptyTyparInst = ([]: TyparInstantiation) [] type Remap = - { tpinst: TyparInstantiation + { + tpinst: TyparInstantiation - /// Values to remap - valRemap: ValRemap + /// Values to remap + valRemap: ValRemap - /// TyconRefs to remap - tyconRefRemap: TyconRefRemap + /// TyconRefs to remap + tyconRefRemap: TyconRefRemap - /// Remove existing trait solutions? - removeTraitSolutions: bool } + /// Remove existing trait solutions? + removeTraitSolutions: bool + } -let emptyRemap = - { tpinst = emptyTyparInst - tyconRefRemap = emptyTyconRefRemap - valRemap = ValMap.Empty - removeTraitSolutions = false } +let emptyRemap = + { + tpinst = emptyTyparInst + tyconRefRemap = emptyTyconRefRemap + valRemap = ValMap.Empty + removeTraitSolutions = false + } -type Remap with +type Remap with static member Empty = emptyRemap //-------------------------------------------------------------------------- -// Substitute for type variables and remap type constructors +// Substitute for type variables and remap type constructors //-------------------------------------------------------------------------- -let addTyconRefRemap tcref1 tcref2 tmenv = - { tmenv with tyconRefRemap = tmenv.tyconRefRemap.Add tcref1 tcref2 } +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 isRemapEmpty remap = + isNil remap.tpinst && remap.tyconRefRemap.IsEmpty && remap.valRemap.IsEmpty let rec instTyparRef tpinst ty tp = - match tpinst with + match tpinst with | [] -> ty - | (tpR, tyR) :: t -> - if typarEq tp tpR then tyR - else instTyparRef t ty tp + | (tpR, tyR) :: t -> if typarEq tp tpR then tyR else instTyparRef t ty tp let remapTyconRef (tcmap: TyconRefMap<_>) tcref = - match tcmap.TryFind tcref with + 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 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) @@ -171,138 +185,155 @@ 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) + 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 + 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 -> + | 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 + 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) + 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 + let slnCell = + match slnCell.Value with | None -> None | _ when tyenv.removeTraitSolutions -> None - | Some sln -> - let sln = - match sln with + | 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) + 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) + 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 + 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 + // 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. // @@ -313,109 +344,154 @@ and remapTraitInfo tyenv (TTrait(tys, nm, flags, argTys, retTy, source, 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 +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 +// 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 + 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) = +and remapValLinkage tyenv (vlink: ValLinkageFullKey) = let tyOpt = vlink.TypeForLinkage - let tyOptR = - match tyOpt with - | None -> tyOpt - | Some ty -> + + 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) + if ty === tyR then tyOpt else Some tyR -and remapNonLocalValRef tyenv (nlvref: NonLocalValOrMemberRef) = + 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 + + 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 + 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 + 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 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 = + 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 @@ -426,23 +502,27 @@ let mkTyconRefInst (tcref: TyconRef) tinst = mkTyconInst tcref.Deref tinst // 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 +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 reduceTyconRefAbbrevMeasureable (tcref: TyconRef) = let abbrev = tcref.TypeAbbrev - match abbrev with - | Some (TType_measure ms) -> ms + + 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) +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 @@ -451,110 +531,140 @@ 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? +/// 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 + 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 + | 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? +/// 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.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 + | 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? +/// 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 + | 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 +/// List the *literal* occurrences of unit variables in a unit expression, without repeats let ListMeasureVarOccs unt = - let rec gather acc 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.Prod(measure1 = unt1; measure2 = unt2) -> gather (gather acc unt1) unt2 + | Measure.RationalPower(measure = untR) -> gather acc untR | Measure.Inv untR -> gather acc untR - | _ -> acc + | _ -> 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 = + let rec gather acc unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var tp -> - if List.exists (fun (tpR, _) -> typarEq tp tpR) acc then acc - else + | 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.Prod(measure1 = unt1; measure2 = unt2) -> gather (gather acc unt1) unt2 | Measure.Inv untR -> gather acc untR - | Measure.RationalPower(measure= untR) -> gather acc untR - | _ -> acc + | 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 + 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 + | Measure.RationalPower(measure = untR) -> gather acc untR + | _ -> acc + gather [] untexpr -/// List the *literal* occurrences of unit constants in a unit expression, without repeats, +/// 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 = + 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.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 = +let MeasurePower u n = if n = 1 then u elif n = 0 then Measure.One(range0) - else Measure.RationalPower (u, intToRational n) + 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) + | _, _ -> 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 +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) + isNil (ListMeasureVarOccsWithNonZeroExponents unt) + && isNil (ListMeasureConOccsWithNonZeroExponents g true unt) | _ -> false let destUnitParMeasure g unt = @@ -562,23 +672,24 @@ let destUnitParMeasure g unt = let cs = ListMeasureConOccsWithNonZeroExponents g true unt match vs, cs with - | [(v, e)], [] when e = OneRational -> v + | [ (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 + | [ (_, 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 + | [ (v, e) ], [] when e = OneRational -> Measure.Var v | vs, cs -> List.foldBack (fun (v, e) -> @@ -589,18 +700,20 @@ let normalizeMeasure g ms = 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))) - + 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) -> + | TType_measure(Measure.Var v) -> match v.Solution with - | Some (TType_measure ms) -> - v.typar_solution <- Some (TType_measure (normalizeMeasure g ms)) + | Some(TType_measure ms) -> + v.typar_solution <- Some(TType_measure(normalizeMeasure g ms)) ty | _ -> ty | _ -> ty @@ -609,166 +722,191 @@ let tryNormalizeMeasureInType g ty = // Some basic type builders //--------------------------------------------------------------------------- -let mkNativePtrTy (g: TcGlobals) ty = +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) + TType_app(g.nativeptr_tcr, [ ty ], g.knownWithoutNull) -let mkByrefTy (g: TcGlobals) ty = +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) + TType_app(g.byref_tcr, [ ty ], g.knownWithoutNull) -let mkInByrefTy (g: TcGlobals) ty = +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) + TType_app(g.inref_tcr, [ ty ], g.knownWithoutNull) else mkByrefTy g ty -let mkOutByrefTy (g: TcGlobals) 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) + 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 mkByrefTyWithFlag g readonly ty = + if readonly then mkInByrefTy g ty else mkByrefTy g ty -let mkByref2Ty (g: TcGlobals) ty1 ty2 = +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) + TType_app(g.byref2_tcr, [ ty1; ty2 ], g.knownWithoutNull) -let mkVoidPtrTy (g: TcGlobals) = +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) + TType_app(g.voidptr_tcr, [], g.knownWithoutNull) -let mkByrefTyWithInference (g: TcGlobals) ty1 ty2 = +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) + 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) + 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) + TType_app(g.il_arr_tcr_map[rank - 1], [ ty ], nullness) //-------------------------------------------------------------------------- // Tuple compilation (types) -//------------------------------------------------------------------------ +//------------------------------------------------------------------------ let maxTuple = 8 -let goodTupleFields = maxTuple-1 +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 + 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 +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 + 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) + + 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 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 + // 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) + 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) //--------------------------------------------------------------------------- -// Remove inference equations and abbreviations from types +// Remove inference equations and abbreviations from types //--------------------------------------------------------------------------- -let applyTyconAbbrev abbrevTy tycon tyargs = - if isNil tyargs then abbrevTy - else instType (mkTyconInst tycon tyargs) abbrevTy +let applyTyconAbbrev abbrevTy tycon tyargs = + if isNil tyargs then + abbrevTy + else + instType (mkTyconInst tycon tyargs) abbrevTy -let reduceTyconAbbrev (tycon: Tycon) tyargs = +let reduceTyconAbbrev (tycon: Tycon) tyargs = let abbrev = tycon.TypeAbbrev - match abbrev with + + match abbrev with | None -> invalidArg "tycon" "this type definition is not an abbreviation" - | Some abbrevTy -> - applyTyconAbbrev abbrevTy tycon tyargs + | Some abbrevTy -> applyTyconAbbrev abbrevTy tycon tyargs -let reduceTyconRefAbbrev (tcref: TyconRef) tyargs = - reduceTyconAbbrev tcref.Deref 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 + 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 + + 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) + | TProvidedTypeRepr info when info.IsErased -> info.BaseTypeForErased(range0, g.obj_ty_withNulls) #endif - | _ -> invalidArg "tc" "this type definition is not a refinement" + | _ -> invalidArg "tc" "this type definition is not a refinement" -let reduceTyconRefMeasureableOrProvided (g: TcGlobals) (tcref: TyconRef) tyargs = +let reduceTyconRefMeasureableOrProvided (g: TcGlobals) (tcref: TyconRef) tyargs = reduceTyconMeasureableOrProvided g tcref.Deref tyargs -let rec stripTyEqnsA g canShortcut ty = - let ty = stripTyparEqnsAux KnownWithoutNull canShortcut ty - match ty with - | TType_app (tcref, tinst, nullness) -> +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 -> + + 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 + | 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 + 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. @@ -776,18 +914,17 @@ let rec stripTyEqnsA g canShortcut ty = let reducedTy = reduceTyconMeasureableOrProvided g tycon tinst let reducedTy2 = addNullnessToTy nullness reducedTy stripTyEqnsA g canShortcut reducedTy2 - else + else ty | ty -> ty let stripTyEqns g ty = stripTyEqnsA g false ty -let evalTupInfoIsStruct aexpr = - match aexpr with +let evalTupInfoIsStruct aexpr = + match aexpr with | TupInfo.Const b -> b -let evalAnonInfoIsStruct (anonInfo: AnonRecdTypeInfo) = - evalTupInfoIsStruct anonInfo.TupInfo +let evalAnonInfoIsStruct (anonInfo: AnonRecdTypeInfo) = evalTupInfoIsStruct anonInfo.TupInfo /// This erases outermost occurrences of inference equations, type abbreviations, non-generated provided types /// and measurable types (float<_>). @@ -795,170 +932,389 @@ let evalAnonInfoIsStruct (anonInfo: AnonRecdTypeInfo) = /// 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) -> + | TType_app(tcref, args, nullness) -> let tycon = tcref.Deref - if tycon.IsErased then + + 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 + elif tyconRefEq g tcref g.nativeptr_tcr && eraseFuncAndTuple then stripTyEqnsAndErase eraseFuncAndTuple g g.nativeint_ty else ty - | TType_fun(domainTy, rangeTy, nullness) when eraseFuncAndTuple -> - TType_app(g.fastFunc_tcr, [ domainTy; rangeTy ], nullness) + | 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 + | 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 stripTyEqnsAndMeasureEqns g ty = stripTyEqnsAndErase false g ty + +type Erasure = + | EraseAll + | EraseMeasures + | EraseNone -let stripTyEqnsWrtErasure erasureFlag g ty = - match erasureFlag with +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 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 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 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 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 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 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 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 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 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 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 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 isFunTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_fun _ -> true + | _ -> false) -let isForallTy g ty = ty |> stripTyEqns g |> (function TType_forall _ -> 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 isMeasureTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_measure _ -> true + | _ -> false) -let isProvenUnionCaseTy ty = match ty with TType_ucase _ -> true | _ -> false +let isProvenUnionCaseTy ty = + match ty with + | TType_ucase _ -> true + | _ -> false -let mkWoNullAppTy tcref tyargs = TType_app(tcref, tyargs, KnownWithoutNull) +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 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 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 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 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 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 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 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 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 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 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 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 (|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 (|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 (|FunTy|_|) g ty = + ty + |> stripTyEqns g + |> (function + | TType_fun(domainTy, rangeTy, _) -> ValueSome(domainTy, rangeTy) + | _ -> ValueNone) + +let tryNiceEntityRefOfTy ty = + let ty = stripTyparEqnsAux KnownWithoutNull false ty -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 + | TType_app(tcref, _, _) -> ValueSome tcref + | TType_measure(Measure.Const(tyconRef = tcref)) -> ValueSome tcref | _ -> ValueNone -let tryNiceEntityRefOfTyOption ty = - let ty = stripTyparEqnsAux KnownWithoutNull false ty +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 + | TType_app(tcref, _, _) -> Some tcref + | TType_measure(Measure.Const(tyconRef = tcref)) -> Some tcref | _ -> None - -let mkInstForAppTy g ty = + +let mkInstForAppTy g ty = match tryAppTy g ty with - | ValueSome (tcref, tinst) -> mkTyconRefInst tcref tinst + | 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 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 - + 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 = +let stripMeasuresFromTy g ty = match ty with | TType_app(tcref, tinst, nullness) -> let tinstR = tinst |> List.filter (isMeasureTy g >> not) @@ -966,192 +1322,228 @@ let stripMeasuresFromTy g ty = | _ -> ty //--------------------------------------------------------------------------- -// Equivalence of types up to alpha-equivalence +// Equivalence of types up to alpha-equivalence //--------------------------------------------------------------------------- - [] -type TypeEquivEnv = - { EquivTypars: TyparMap - EquivTycons: TyconRefRemap - NullnessMustEqual : bool} +type TypeEquivEnv = + { + EquivTypars: TyparMap + EquivTycons: TyconRefRemap + NullnessMustEqual: bool + } -let private nullnessEqual anev (n1:Nullness) (n2:Nullness) = - if anev.NullnessMustEqual then +let private nullnessEqual anev (n1: Nullness) (n2: Nullness) = + if anev.NullnessMustEqual then (n1.Evaluate() = NullnessInfo.WithNull) = (n2.Evaluate() = NullnessInfo.WithNull) - else + else true // allocate a singleton -let private typeEquivEnvEmpty = - { EquivTypars = TyparMap.Empty - EquivTycons = emptyTyconRefRemap - NullnessMustEqual = false} +let private typeEquivEnvEmpty = + { + EquivTypars = TyparMap.Empty + EquivTycons = emptyTyconRefRemap + NullnessMustEqual = false + } -let private typeEquivCheckNullness = {typeEquivEnvEmpty with NullnessMustEqual = true} +let private typeEquivCheckNullness = + { typeEquivEnvEmpty with + NullnessMustEqual = true + } -type TypeEquivEnv with +type TypeEquivEnv with static member EmptyIgnoreNulls = typeEquivEnvEmpty - static member EmptyWithNullChecks (g:TcGlobals) = if g.checkNullness then typeEquivCheckNullness else 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)) } + { 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) + aenv.BindTyparsToTypes tps1 (List.map mkTyparTy tps2) member aenv.FromTyparInst tpinst = let tps, tys = List.unzip tpinst - aenv.BindTyparsToTypes tps tys + aenv.BindTyparsToTypes tps tys - member aenv.FromEquivTypars tps1 tps2 = - aenv.BindEquivTypars tps1 tps2 + member aenv.FromEquivTypars tps1 tps2 = aenv.BindEquivTypars tps1 tps2 - member anev.ResetEquiv = - if anev.NullnessMustEqual then typeEquivCheckNullness else typeEquivEnvEmpty + 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 + 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 + 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 + 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.CoercesTo(tgtTy1, _), TyparConstraint.CoercesTo(tgtTy2, _) -> typeAEquivAux erasureFlag g aenv tgtTy1 tgtTy2 - | TyparConstraint.MayResolveMember(trait1, _), - TyparConstraint.MayResolveMember(trait2, _) -> - traitsAEquivAux erasureFlag g aenv trait1 trait2 + | TyparConstraint.MayResolveMember(trait1, _), TyparConstraint.MayResolveMember(trait2, _) -> + traitsAEquivAux erasureFlag g aenv trait1 trait2 - | TyparConstraint.DefaultsTo(_, dfltTy1, _), - TyparConstraint.DefaultsTo(_, dfltTy2, _) -> + | TyparConstraint.DefaultsTo(_, dfltTy1, _), TyparConstraint.DefaultsTo(_, dfltTy2, _) -> typeAEquivAux erasureFlag g aenv dfltTy1 dfltTy2 - | TyparConstraint.IsEnum(underlyingTy1, _), TyparConstraint.IsEnum(underlyingTy2, _) -> + | 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.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, _) -> + | 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.SupportsComparison _, TyparConstraint.SupportsComparison _ + | TyparConstraint.SupportsEquality _, TyparConstraint.SupportsEquality _ + | TyparConstraint.SupportsNull _, TyparConstraint.SupportsNull _ + | TyparConstraint.NotSupportsNull _, TyparConstraint.NotSupportsNull _ | TyparConstraint.IsNonNullableStruct _, TyparConstraint.IsNonNullableStruct _ - | TyparConstraint.IsReferenceType _, TyparConstraint.IsReferenceType _ + | 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 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 - List.forall2 (typarConstraintSetsAEquivAux erasureFlag g aenv) tps1 tps2 +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 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 +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_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), TType_var(tp2, n2) when typarEq tp1 tp2 -> nullnessEqual aenv n1 n2 - | TType_var (tp1, n1), _ -> + | 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 + | 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_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_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_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_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_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 + | 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 + ccuEq anonInfo1.Assembly anonInfo2.Assembly + && structnessAEquiv anonInfo1.TupInfo anonInfo2.TupInfo + && anonInfo1.SortedNames = anonInfo2.SortedNames and structnessAEquiv un1 un2 = - match un1, un2 with + 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 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) + 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 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 +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 @@ -1159,90 +1551,102 @@ 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 traitKeysAEquiv g aenv t1 t2 = + traitKeysAEquivAux EraseNone g aenv t1 t2 -let typarConstraintsAEquiv g aenv c1 c2 = typarConstraintsAEquivAux EraseNone g aenv c1 c2 +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 returnTypesAEquiv g aenv t1 t2 = returnTypesAEquivAux EraseNone g aenv t1 t2 +let returnTypesAEquiv g aenv t1 t2 = + returnTypesAEquivAux EraseNone g aenv t1 t2 -let measureEquiv g m1 m2 = measureAEquiv g TypeEquivEnv.EmptyIgnoreNulls m1 m2 +let measureEquiv g m1 m2 = + measureAEquiv g TypeEquivEnv.EmptyIgnoreNulls m1 m2 -// Get measure of type, float<_> or float32<_> or decimal<_> but not float=float<1> or float32=float32<1> or decimal=decimal<1> +// 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) + 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 +let isErasedType g ty = + match stripTyEqns g ty with #if !NO_TYPEPROVIDERS - | TType_app (tcref, _, _) -> tcref.IsProvidedErasedTycon + | TType_app(tcref, _, _) -> tcref.IsProvidedErasedTycon #endif - | _ -> false + | _ -> false // Return all components of this type expression that cannot be tested at runtime -let rec getErasedTypes g ty checkForNullness = +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 [] + 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_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_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] + | 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 ] //--------------------------------------------------------------------------- // Standard orderings, e.g. for order set/map keys //--------------------------------------------------------------------------- -let valOrder = { new IComparer with member _.Compare(v1, v2) = compareBy v1 v2 _.Stamp } +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 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 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 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 + } //--------------------------------------------------------------------------- // Make some common types //--------------------------------------------------------------------------- let mkFunTy (g: TcGlobals) domainTy rangeTy = - TType_fun (domainTy, rangeTy, g.knownWithoutNull) + TType_fun(domainTy, rangeTy, g.knownWithoutNull) -let mkForallTy d r = TType_forall (d, r) +let mkForallTy d r = TType_forall(d, r) let mkForallTyIfNeeded d r = if isNil d then r else mkForallTy d r @@ -1250,244 +1654,304 @@ let (+->) d r = mkForallTyIfNeeded d r let mkIteratedFunTy g dl r = List.foldBack (mkFunTy g) dl r -let mkLambdaTy g tps tys bodyTy = mkForallTyIfNeeded tps (mkIteratedFunTy g tys bodyTy) +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 +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 +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 +/// 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 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 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) + + 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 - | _ -> () + let modul = Map.find modName mtype.AllEntitiesByCompiledAndLogicalMangledNames + loop (prior_cpath @ [ (modName, Namespace true) ]) tpath tcpath modul - loop [] path cpath ccu.Contents + | _ -> () + loop [] path cpath ccu.Contents //--------------------------------------------------------------------------- // Primitive destructors //--------------------------------------------------------------------------- /// Look through the Expr.Link nodes arising from type inference -let rec stripExpr e = - match e with +let rec stripExpr e = + match e with | Expr.Link eref -> stripExpr eref.Value - | _ -> e + | _ -> e -let rec stripDebugPoints expr = +let rec stripDebugPoints expr = match stripExpr expr with - | Expr.DebugPoint (_, innerExpr) -> stripDebugPoints innerExpr + | 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.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 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] +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) -let primMkMatch(spBind, mExpr, tree, targets, mMatch, ty) = Expr.Match (spBind, mExpr, tree, targets, mMatch, ty) +type MatchBuilder(spBind, inpRange: range) = -type MatchBuilder(spBind, inpRange: range) = + let targets = ResizeArray<_>(10) - let targets = ResizeArray<_>(10) - member x.AddTarget tg = - let n = targets.Count + member x.AddTarget tg = + let n = targets.Count targets.Add tg n - member x.AddResultTarget(e) = TDSuccess([], x.AddTarget(TTarget([], e, None))) + 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) + 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) + TDSwitch(g, [ TCase(DecisionTreeTest.Const(Const.Bool true), t) ], Some e, m) -let primMkCond spBind m ty e1 e2 e3 = +let primMkCond spBind m ty e1 e2 e3 = let mbuilder = MatchBuilder(spBind, m) - let dtree = mkBoolSwitch m e1 (mbuilder.AddResultTarget(e2)) (mbuilder.AddResultTarget(e3)) + + 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 +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 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) + 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) +// 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 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 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 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 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 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) = +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) = +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 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 = +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 -> + | _ -> + 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) = +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 mkLetBind m bind body = + Expr.Let(bind, body, m, Construct.NewFreeVarsCache()) -let mkLetsBind m binds body = List.foldBack (mkLetBind m) binds body +let mkLetsBind m binds body = List.foldBack (mkLetBind m) binds body -let mkLetsFromBindings 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 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 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 mkInvisibleLets m vs xs body = + mkLetsBind m (mkInvisibleBinds vs xs) body -let mkInvisibleLetsFromBindings m vs xs body = mkLetsFromBindings 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 + body else - Expr.LetRec (binds, body, m, Construct.NewFreeVarsCache()) + 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 +// 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 = + | 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. + 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 + // 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 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 mkBool (g: TcGlobals) m b = Expr.Const(Const.Bool b, m, g.bool_ty) -let mkTrue g m = - mkBool g m true +let mkTrue g m = mkBool g m true -let mkFalse g m = - mkBool g m false +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 @@ -1495,148 +1959,182 @@ let mkLazyOr (g: TcGlobals) m e1 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 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) + Expr.Op(TOp.ILAsm(code, rettys), tinst, args, m) -let mkUnionCaseExpr(uc, tinst, args, m) = - Expr.Op (TOp.UnionCase uc, 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 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 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 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) + 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 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 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) + Expr.Op(TOp.ValFieldGet fref, tinst, [], m) -let mkStaticRecdFieldSet(fref, tinst, e, m) = - Expr.Op (TOp.ValFieldSet fref, tinst, [e], 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 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) + Expr.Op(TOp.ValFieldSet fref, tinst, [ e1; e2 ], m) let mkUnionCaseTagGetViaExprAddr (e1, cref, tinst, m) = - Expr.Op (TOp.UnionCaseTagGet cref, tinst, [e1], 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) + 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, +/// 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) + 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, +/// 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) + 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 +/// 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) + 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) + Expr.Op(TOp.UnionCaseFieldSet(cref, j), tinst, [ e1; e2 ], m) let mkExnCaseFieldGet (e1, ecref, j, m) = - Expr.Op (TOp.ExnFieldGet (ecref, j), [], [e1], 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) + Expr.Op(TOp.ExnFieldSet(ecref, j), [], [ e1; e2 ], m) -let mkDummyLambda (g: TcGlobals) (bodyExpr: Expr, bodyExprTy) = +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 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 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 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 mkDefault (m, ty) = Expr.Const(Const.Zero, m, ty) let mkValSet m vref e = - Expr.Op (TOp.LValueOp (LSet, vref), [], [e], m) + Expr.Op(TOp.LValueOp(LSet, vref), [], [ e ], m) let mkAddrSet m vref e = - Expr.Op (TOp.LValueOp (LByrefSet, vref), [], [e], m) + Expr.Op(TOp.LValueOp(LByrefSet, vref), [], [ e ], m) let mkAddrGet m vref = - Expr.Op (TOp.LValueOp (LByrefGet, vref), [], [], m) + Expr.Op(TOp.LValueOp(LByrefGet, vref), [], [], m) let mkValAddr m readonly vref = - Expr.Op (TOp.LValueOp (LAddrOf readonly, vref), [], [], m) + Expr.Op(TOp.LValueOp(LAddrOf readonly, vref), [], [], m) //-------------------------------------------------------------------------- // Maps tracking extra information for values //-------------------------------------------------------------------------- [] -type ValHash<'T> = +type ValHash<'T> = | ValHash of Dictionary - member ht.Values = + member ht.Values = let (ValHash t) = ht t.Values :> seq<'T> - member ht.TryFind (v: Val) = + 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) = + member ht.Add(v: Val, x) = let (ValHash t) = ht t[v.Stamp] <- x - static member Create() = ValHash (new Dictionary<_, 'T>(11)) + static member Create() = ValHash(new Dictionary<_, 'T>(11)) [] type ValMultiMap<'T>(contents: StampMap<'T list>) = - member _.ContainsKey (v: Val) = - contents.ContainsKey v.Stamp + member _.ContainsKey(v: Val) = contents.ContainsKey v.Stamp - member _.Find (v: Val) = + 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 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 _.Remove(v: Val) = + ValMultiMap<'T>(contents.Remove v.Stamp) member _.Contents = contents @@ -1645,66 +2143,77 @@ type ValMultiMap<'T>(contents: StampMap<'T list>) = [] type TyconRefMultiMap<'T>(contents: TyconRefMap<'T list>) = - member _.Find v = + 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)) + 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)) + static member OfList vs = + (vs, TyconRefMultiMap<'T>.Empty) + ||> List.foldBack (fun (x, y) acc -> acc.Add(x, y)) //-------------------------------------------------------------------------- // From Ref_private to Ref_nonlocal when exporting data. //-------------------------------------------------------------------------- -/// Try to create a EntityRef suitable for accessing the given Entity from another assembly +/// 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)) + 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 +/// 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)) -> + 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 entityRemap = + { entityRemap with + removeTraitSolutions = true + } + let fullLinkageKey = remapValLinkage entityRemap fullLinkageKey - let vref = + + 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 + // This stems from the days when types and namespace/modules were separated constructs in the // compiler implementation. - if vspec.IsIntrinsicMember then + if vspec.IsIntrinsicMember then mkNonLocalValRef (rescopePubPathToParent viewedCcu p) fullLinkageKey - else + 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 actualTysOfRecdFields inst rfields = + List.map (actualTyOfRecdField inst) rfields -let actualTysOfInstanceRecdFields inst (tcref: TyconRef) = tcref.AllInstanceFieldsAsList |> actualTysOfRecdFields inst +let actualTysOfInstanceRecdFields inst (tcref: TyconRef) = + tcref.AllInstanceFieldsAsList |> actualTysOfRecdFields inst -let actualTysOfUnionCaseFields inst (x: UnionCaseRef) = actualTysOfRecdFields inst x.AllFieldsAsList +let actualTysOfUnionCaseFields inst (x: UnionCaseRef) = + actualTysOfRecdFields inst x.AllFieldsAsList -let actualResultTyOfUnionCase tinst (x: UnionCaseRef) = +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 recdFieldOfExnDefRefByIdx x n = (stripExnEqns x).GetFieldByIndex n let recdFieldTysOfExnDefRef x = actualTysOfRecdFields [] (recdFieldsOfExnDefRef x) @@ -1712,98 +2221,107 @@ let recdFieldTysOfExnDefRef x = let recdFieldTyOfExnDefRefByIdx x j = actualTyOfRecdField [] (recdFieldOfExnDefRefByIdx x j) -let actualTyOfRecdFieldForTycon tycon tinst (fspec: RecdField) = +let actualTyOfRecdFieldForTycon tycon tinst (fspec: RecdField) = instType (mkTyconInst tycon tinst) fspec.FormalType -let actualTyOfRecdFieldRef (fref: RecdFieldRef) tinst = +let actualTyOfRecdFieldRef (fref: RecdFieldRef) tinst = actualTyOfRecdFieldForTycon fref.Tycon tinst fref.RecdField -let actualTyOfUnionFieldRef (fref: UnionCaseRef) n tinst = +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 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 = +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 +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 + else + [], ty -let applyForallTy g ty tyargs = +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 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 = +let applyTyArgs g ty tyargs = if isForallTy g ty then applyForallTy g ty tyargs else ty -let applyTys g funcTy (tyargs, argTys) = +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 formalApplyTys g funcTy (tyargs, args) = + reduceIteratedFunTy g (if isNil tyargs then funcTy else snd (destForallTy g funcTy)) args -let rec stripFunTyN g n ty = +let rec stripFunTyN g n ty = assert (n >= 0) - if n > 0 && isFunTy g ty then + + if n > 0 && isFunTy g ty then let d, r = destFunTy g ty - let more, retTy = stripFunTyN g (n-1) r + 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] + 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] +let tryDestRefTupleTy g ty = + if isRefTupleTy g ty then destRefTupleTy g ty else [ ty ] -type UncurriedArgInfos = (TType * ArgReprInfo) list +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 +// 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)) + if nArgInfos <> argTys.Length then + error (Error(FSComp.SR.tastInvalidMemberSignature (), m)) - let argTysl = - (curriedArgInfos, argTys) ||> List.map2 (fun argInfos argTy -> - match argInfos with + 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) + | [ argInfo ] -> [ (argTy, argInfo) ] + | _ -> List.zip (destRefTupleTy g argTy) argInfos) argTysl, retTy -let destTopForallTy g (ValReprInfo (ntps, _, _)) ty = +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 + // tps may be have been equated to other tps in equi-recursive type inference. Normalize them here let tps = NormalizeDeclaredTyparsForEquiRecursiveInference g tps tps, tau @@ -1815,161 +2333,240 @@ let GetValReprTypeInFSharpForm g (ValReprInfo(_, argInfos, retInfo) as valReprIn 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 + 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 +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) + 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" + | 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 + | 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 + | ValueSome(tcref, [ ty ]) when tyconRefEq g tcref g.list_tcr_canon -> ty | _ -> failwith "destListTy" -let tyconRefEqOpt g tcrefOpt tcref = +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 isStringTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> tyconRefEq g tcref g.system_String_tcref + | _ -> false) -let isArrayTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _, _) -> isArrayTyconRef g tcref | _ -> false) +let isListTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> tyconRefEq g tcref g.list_tcr_canon + | _ -> false) -let isArray1DTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _, _) -> tyconRefEq g tcref g.il_arr_tcr_map[0] | _ -> false) +let isArrayTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> isArrayTyconRef g tcref + | _ -> false) -let isUnitTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _, _) -> tyconRefEq g g.unit_tcr_canon tcref | _ -> false) +let isArray1DTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> tyconRefEq g tcref g.il_arr_tcr_map[0] + | _ -> false) -let isObjTyAnyNullness g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _, _) -> tyconRefEq g g.system_Object_tcref tcref | _ -> false) +let isUnitTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> tyconRefEq g g.unit_tcr_canon 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 isObjTyAnyNullness g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> 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 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 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 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 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 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 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 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 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 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) +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) +let extensionInfoOfTy g ty = + ty + |> stripTyEqns g + |> (function + | TType_app(tcref, _, _) -> tcref.TypeReprInfo + | _ -> TNoRepr) #endif -type TypeDefMetadata = - | ILTypeMetadata of TILObjectReprData - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata +type TypeDefMetadata = + | ILTypeMetadata of TILObjectReprData + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata #if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata of TProvidedTypeInfo + | ProvidedTypeMetadata of TProvidedTypeInfo #endif -let metadataOfTycon (tycon: Tycon) = +let metadataOfTycon (tycon: Tycon) = #if !NO_TYPEPROVIDERS - match tycon.TypeReprInfo with + match tycon.TypeReprInfo with | TProvidedTypeRepr info -> ProvidedTypeMetadata info - | _ -> + | _ -> #endif - if tycon.IsILTycon then - ILTypeMetadata tycon.ILTyconInfo - else - FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata - + if tycon.IsILTycon then + ILTypeMetadata tycon.ILTyconInfo + else + FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -let metadataOfTy g ty = +let metadataOfTy g ty = #if !NO_TYPEPROVIDERS - match extensionInfoOfTy g ty with + match extensionInfoOfTy g ty with | TProvidedTypeRepr info -> ProvidedTypeMetadata info - | _ -> + | _ -> #endif - if isILAppTy g ty then + if isILAppTy g ty then let tcref = tcrefOfAppTy g ty ILTypeMetadata tcref.ILTyconInfo - else - FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata - + else + FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -let isILReferenceTy g ty = - match metadataOfTy g ty with +let isILReferenceTy g ty = + match metadataOfTy g ty with #if !NO_TYPEPROVIDERS | ProvidedTypeMetadata info -> not info.IsStructOrEnum #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> not td.IsStructOrEnum + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> not td.IsStructOrEnum | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isArrayTy g ty -let isILInterfaceTycon (tycon: Tycon) = - match metadataOfTycon tycon with +let isILInterfaceTycon (tycon: Tycon) = + match metadataOfTycon tycon with #if !NO_TYPEPROVIDERS | ProvidedTypeMetadata info -> info.IsInterface #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsInterface + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsInterface | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> false -let rankOfArrayTy g ty = rankOfArrayTyconRef g (tcrefOfAppTy g ty) +let rankOfArrayTy g ty = + rankOfArrayTyconRef g (tcrefOfAppTy g ty) -let isFSharpObjModelRefTy g ty = - isFSharpObjModelTy g ty && - let tcref = tcrefOfAppTy g ty - match tcref.FSharpTyconRepresentationData.fsobjmodel_kind with - | TFSharpClass | TFSharpInterface | TFSharpDelegate _ -> true - | TFSharpUnion | TFSharpRecord | TFSharpStruct | TFSharpEnum -> false +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 @@ -1981,46 +2578,47 @@ let isFSharpStructTy g ty = | ValueSome tcref -> tcref.Deref.IsFSharpStructOrEnumTycon | _ -> false -let isFSharpInterfaceTy g ty = +let isFSharpInterfaceTy g ty = match tryTcrefOfAppTy g ty with | ValueSome tcref -> tcref.Deref.IsFSharpInterfaceTycon | _ -> false -let isDelegateTy g ty = - match metadataOfTy g ty with +let isDelegateTy g ty = + match metadataOfTy g ty with #if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata info -> info.IsDelegate () + | ProvidedTypeMetadata info -> info.IsDelegate() #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsDelegate + | 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 +let isInterfaceTy g ty = + match metadataOfTy g ty with #if !NO_TYPEPROVIDERS | ProvidedTypeMetadata info -> info.IsInterface #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsInterface + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsInterface | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpInterfaceTy g ty -let isFSharpDelegateTy g ty = isDelegateTy g ty && isFSharpObjModelTy g ty +let isFSharpDelegateTy g ty = + isDelegateTy g ty && isFSharpObjModelTy g ty -let isClassTy g ty = - match metadataOfTy g ty with +let isClassTy g ty = + match metadataOfTy g ty with #if !NO_TYPEPROVIDERS | ProvidedTypeMetadata info -> info.IsClass #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsClass + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsClass | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpClassTy g ty -let isStructOrEnumTyconTy g ty = +let isStructOrEnumTyconTy g ty = match tryTcrefOfAppTy g ty with | ValueSome tcref -> tcref.Deref.IsStructOrEnumTycon | _ -> false -let isStructRecordOrUnionTyconTy g ty = +let isStructRecordOrUnionTyconTy g ty = match tryTcrefOfAppTy g ty with | ValueSome tcref -> tcref.Deref.IsStructRecordOrUnionTycon | _ -> false @@ -2031,24 +2629,20 @@ let isStructTyconRef (tcref: TyconRef) = let isStructTy g ty = match tryTcrefOfAppTy g ty with - | ValueSome tcref -> - isStructTyconRef tcref - | _ -> - isStructAnonRecdTy g ty || isStructTupleTy g ty - -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)) - ) + | ValueSome tcref -> isStructTyconRef tcref + | _ -> isStructAnonRecdTy g ty || isStructTupleTy g ty + +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 @@ -2062,37 +2656,49 @@ let isForallFunctionTy g ty = // - 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 = + 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 + + 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 + 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 + tycon.AllInstanceFieldsAsList |> List.forall (isUnmanagedRecordField tinst) + else + false | ValueNone -> if isStructTupleTy g ty then (destStructTupleTy g ty) |> List.forall (isUnmanagedTy g) @@ -2101,54 +2707,53 @@ let rec isUnmanagedTy g ty = else false -let isInterfaceTycon x = +let isInterfaceTycon x = isILInterfaceTycon x || x.IsFSharpInterfaceTycon let isInterfaceTyconRef (tcref: TyconRef) = isInterfaceTycon tcref.Deref -let isEnumTy g ty = - match tryTcrefOfAppTy g ty with +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 + 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 + 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 + isSignedIntegerTy g ty || isUnsignedIntegerTy g ty -/// float or float32 or float<_> or float32<_> +/// 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 + typeEquivAux EraseMeasures g g.float_ty ty + || typeEquivAux EraseMeasures g g.float32_ty ty /// decimal or decimal<_> -let isDecimalTy g ty = +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 isNumericType g ty = + isNonDecimalNumericType g ty || isDecimalTy g ty -let actualReturnTyOfSlotSig parentTyInst methTyInst (TSlotSig(_, _, parentFormalTypars, methFormalTypars, _, formalRetTy)) = +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 slotSigHasVoidReturnTy (TSlotSig(_, _, _, _, _, formalRetTy)) = Option.isNone formalRetTy let returnTyOfMethod g (TObjExprMethod(TSlotSig(_, parentTy, _, _, _, _) as ss, _, methFormalTypars, _, _, _)) = let tinst = argsOfAppTy g parentTy @@ -2156,405 +2761,456 @@ let returnTyOfMethod g (TObjExprMethod(TSlotSig(_, parentTy, _, _, _, _) as ss, 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 +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 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 +let ValIsExplicitImpl g (v: Val) = + match v.MemberInfo with | Some membInfo -> MemberIsExplicitImpl g membInfo | _ -> false let ValRefIsExplicitImpl g (vref: ValRef) = ValIsExplicitImpl g vref.Deref //--------------------------------------------------------------------------- -// Find all type variables in a type, apart from those that have had +// 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 = + +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 = + +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 = + +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 = + +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 typarOrder = + { new IComparer with + member x.Compare(v1: Typar, v2: Typar) = compareBy v1 v2 _.Stamp + } let emptyFreeTypars = Zset.empty typarOrder -let unionFreeTypars s1 s2 = + +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 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 } - + { + 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 } - - + { + 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, "AccFreeVarsStackGuardDepth") - CollectTyparsAndLocalsImpl (Some stackGuard) +let CollectTyparsAndLocalsWithStackGuard () = + let stackGuard = + StackGuard(AccFreeVarsStackGuardDepth, "AccFreeVarsStackGuardDepth") -let CollectLocalsWithStackGuard() = CollectTyparsAndLocalsWithStackGuard() + CollectTyparsAndLocalsImpl(Some stackGuard) -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 CollectLocalsWithStackGuard () = CollectTyparsAndLocalsWithStackGuard() -let rec accFreeTycon opts (tcref: TyconRef) acc = +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 -> + | 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 + 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 + match tpc with | TyparConstraint.CoercesTo(ty, _) -> accFreeInType opts ty acc - | TyparConstraint.MayResolveMember (traitInfo, _) -> accFreeInTrait opts traitInfo 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.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 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 +and accFreeInTraitSln opts sln acc = + match sln with | ILMethSln(ty, _, _, minst, staticTyOpt) -> - Option.foldBack (accFreeInType opts) staticTyOpt - (accFreeInType opts ty - (accFreeInTypes opts minst acc)) + 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 + 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} + if Zset.contains v fvs.FreeTraitSolutions then + fvs + else + { fvs with + FreeTraitSolutions = Zset.add v fvs.FreeTraitSolutions + } -and accFreeValRefInTraitSln opts (vref: ValRef) fvs = +and accFreeValRefInTraitSln opts (vref: ValRef) fvs = if vref.IsLocalRef then accFreeLocalValInTraitSln opts vref.ResolvedTarget fvs else - // non-local values do not contain free variables + // 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 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) +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_anon(anonInfo, l) -> accFreeInTypes opts l (accFreeInTupInfo opts anonInfo.TupInfo acc) - | TType_app (tcref, tinst, _) -> + | 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 + + 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_ucase(UnionCaseRef(tcref, _), tinst) -> accFreeInTypes opts tinst (accFreeTycon opts tcref acc) - | TType_fun (domainTy, rangeTy, _) -> - accFreeInType opts domainTy (accFreeInType opts rangeTy acc) + | TType_fun(domainTy, rangeTy, _) -> accFreeInType opts domainTy (accFreeInType opts rangeTy acc) - | TType_var (r, _) -> - accFreeTyparRef opts r acc + | TType_var(r, _) -> accFreeTyparRef opts r acc - | TType_forall (tps, r) -> - unionFreeTyvars (boundTypars opts tps (freeInType 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 +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 + +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 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) + 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, +// 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 +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 + 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 + 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 _ + 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.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(tys, _, _, argTys, retTy, _, _)) = +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 +and accFreeTyparRefLeftToRight g cxFlag thruFlag acc (tp: Typar) = + if ListSet.contains typarEq tp acc then acc - else + else let acc = ListSet.insert typarEq tp acc - if cxFlag then + + if cxFlag then accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc tp.Constraints - else + 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 +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_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_app(_, tinst, _) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst - | TType_ucase (_, 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 + | 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_var(r, _) -> accFreeTyparRefLeftToRight g cxFlag thruFlag acc r - | TType_forall (tps, r) -> + | TType_forall(tps, r) -> let racc = accFreeInTypeLeftToRight g cxFlag thruFlag emptyFreeTyparsLeftToRight r unionFreeTyparsLeftToRight (boundTyparsLeftToRight g cxFlag thruFlag tps racc) acc @@ -2562,20 +3218,22 @@ and accFreeInTypeLeftToRight g cxFlag thruFlag acc ty = 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 +and accFreeInTupInfoLeftToRight _g _cxFlag _thruFlag acc unt = + match unt with | TupInfo.Const _ -> acc -and accFreeInTypesLeftToRight g cxFlag thruFlag acc tys = - match tys with +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 + accFreeInTypeLeftToRight g true thruFlag emptyFreeTyparsLeftToRight ty + |> List.rev let freeInTypesLeftToRight g thruFlag ty = - accFreeInTypesLeftToRight g true thruFlag emptyFreeTyparsLeftToRight ty |> List.rev + accFreeInTypesLeftToRight g true thruFlag emptyFreeTyparsLeftToRight ty + |> List.rev let freeInTypesLeftToRightSkippingConstraints g ty = accFreeInTypesLeftToRight g false true emptyFreeTyparsLeftToRight ty |> List.rev @@ -2589,33 +3247,35 @@ let valsOfBinds (binds: Bindings) = binds |> List.map (fun b -> b.Var) //-------------------------------------------------------------------------- // 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 = +// 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 + let argInfos = + if memberFlags.IsInstance then match argInfos with - | [] -> - errorR(InternalError("value does not have a valid member type", m)) + | [] -> + errorR (InternalError("value does not have a valid member type", m)) argInfos | _ :: t -> t - else argInfos + 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). +// 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)) + 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 + match retTy with | None -> g.unit_ty | Some retTy -> retTy @@ -2625,21 +3285,19 @@ type TraitConstraintInfo with member traitInfo.GetObjectType() = match traitInfo.MemberFlags.IsInstance, traitInfo.CompiledObjectAndArgumentTypes with - | true, objTy :: _ -> - Some objTy - | _ -> - None + | true, objTy :: _ -> Some objTy + | _ -> None // For static property traits: // ^T: (static member Zero: ^T) - // The inner representation is + // 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 + // The inner representation is // TraitConstraintInfo([^T], get_Zero, Member, Static, [], ^T) // and this returns // [] @@ -2666,21 +3324,19 @@ type TraitConstraintInfo with // [int] member traitInfo.GetCompiledArgumentTypes() = match traitInfo.MemberFlags.IsInstance, traitInfo.CompiledObjectAndArgumentTypes with - | true, _ :: argTys -> - argTys - | _, argTys -> - argTys + | true, _ :: argTys -> argTys + | _, argTys -> argTys // For static property traits: // ^T: (static member Zero: ^T) - // The inner representation is + // 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 + // The inner representation is // TraitConstraintInfo([^T], get_Zero, Member, Static, [], ^T) // and this returns // [unit] @@ -2707,11 +3363,12 @@ type TraitConstraintInfo with // [int] member traitInfo.GetLogicalArgumentTypes(g: TcGlobals) = match traitInfo.GetCompiledArgumentTypes(), traitInfo.MemberFlags.MemberKind with - | [], SynMemberKind.Member -> [g.unit_ty] + | [], SynMemberKind.Member -> [ g.unit_ty ] | argTys, _ -> argTys member traitInfo.MemberDisplayNameCore = let traitName0 = traitInfo.MemberLogicalName + match traitInfo.MemberFlags.MemberKind with | SynMemberKind.PropertyGet | SynMemberKind.PropertySet -> @@ -2727,73 +3384,79 @@ type TraitConstraintInfo with /// 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 - | _ -> () ] +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 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 +let CountEnclosingTyparsOfActualParentOfVal (v: Val) = + match v.ValReprInfo with | None -> 0 - | Some _ -> + | 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 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 + let paramArgInfos = + match paramArgInfos, valReprInfo.ArgInfos with // static member and module value unit argument elimination - | [[(_argType, _)]], [[]] -> - //assert isUnitTy g argType - [[]] + | [ [ (_argType, _) ] ], [ [] ] -> + //assert isUnitTy g argType + [ [] ] // instance member unit argument elimination - | [objInfo;[(_argType, _)]], [[_objArg];[]] -> - //assert isUnitTy g argType - [objInfo; []] - | _ -> - paramArgInfos + | [ 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'. +// 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 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 + let paramArgInfos = + match paramArgInfos, valReprInfo.ArgInfos with // static member and module value unit argument elimination - | [[(argTy, _)]], [[]] -> - assert isUnitTy g argTy - [[]] + | [ [ (argTy, _) ] ], [ [] ] -> + assert isUnitTy g argTy + [ [] ] // instance member unit argument elimination - | [[(argTy, _)]], [[_objArg];[]] -> - assert isUnitTy g argTy - [[]] - | _ -> - paramArgInfos + | [ [ (argTy, _) ] ], [ [ _objArg ]; [] ] -> + assert isUnitTy g argTy + [ [] ] + | _ -> paramArgInfos + let retTy = if isUnitTy g retTy then None else Some retTy (tps, witnessInfos, paramArgInfos, retTy, retInfo) @@ -2807,111 +3470,125 @@ 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 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 + + if nparentTypars <= fullTypars.Length then let memberParentTypars, memberMethodTypars = List.splitAt nparentTypars fullTypars - let memberToParentInst, tinst = mkTyparToTyparRenaming memberParentTypars parentTypars + + let memberToParentInst, tinst = + mkTyparToTyparRenaming memberParentTypars parentTypars + Some(parentTypars, memberParentTypars, memberMethodTypars, memberToParentInst, tinst) - else None + else + None -/// Match up the type variables on an member value with the type +/// 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 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 +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) = +/// 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 + + let _, _, arginfos, _, _ = + GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars v.Type v.Range + arginfos -let ArgInfosOfMember g (vref: ValRef) = - ArgInfosOfMemberVal g vref.Deref +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 ReturnTypeOfPropertyVal g (v: Val) = let membInfo, valReprInfo = checkMemberVal v.MemberInfo v.ValReprInfo v.Range - match membInfo.MemberFlags.MemberKind with + + match membInfo.MemberFlags.MemberKind with | SynMemberKind.PropertySet -> let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v - let _, _, arginfos, _, _ = GetMemberTypeInMemberForm g membInfo.MemberFlags valReprInfo numEnclosingTypars v.Type v.Range + + 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 + arginfos.Head |> List.last |> fst else - error(Error(FSComp.SR.tastValueDoesNotHaveSetterType(), v.Range)) + 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)) + 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 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 + + 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 + + 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 + arginfos.Head |> List.frontAndBack |> fst else - error(Error(FSComp.SR.tastValueDoesNotHaveSetterType(), v.Range)) - | _ -> - error(InternalError("ArgInfosOfPropertyVal", v.Range)) + 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 generalTyconRefInst (tcref: TyconRef) = generalizeTypars tcref.TyparsNoRange -let generalizeTyconRef (g: TcGlobals) tcref = +let generalizeTyconRef (g: TcGlobals) tcref = let tinst = generalTyconRefInst tcref tinst, TType_app(tcref, tinst, g.knownWithoutNull) -let generalizedTyconRef (g: TcGlobals) tcref = +let generalizedTyconRef (g: TcGlobals) tcref = let tinst = generalTyconRefInst tcref TType_app(tcref, tinst, g.knownWithoutNull) -let isTTyparCoercesToType tpc = - match tpc with - | TyparConstraint.CoercesTo _ -> true +let isTTyparCoercesToType tpc = + match tpc with + | TyparConstraint.CoercesTo _ -> true | _ -> false //-------------------------------------------------------------------------- // Print Signatures/Types - prelude -//-------------------------------------------------------------------------- +//-------------------------------------------------------------------------- let prefixOfStaticReq s = - match s with + match s with | TyparStaticReq.None -> "'" | TyparStaticReq.HeadType -> "^" -let prefixOfInferenceTypar (typar: Typar) = - if typar.Rigidity <> TyparRigidity.Rigid then "_" else "" +let prefixOfInferenceTypar (typar: Typar) = + if typar.Rigidity <> TyparRigidity.Rigid then "_" else "" //--------------------------------------------------------------------------- // Prettify: PrettyTyparNames/PrettifyTypes - make typar names human friendly @@ -2920,252 +3597,301 @@ let prefixOfInferenceTypar (typar: Typar) = 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 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 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)) + + (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 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 = + 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) = + let useThisName (nm, typeIndex, measureIndex) = choose tps (typeIndex, measureIndex) (nm :: acc) // Give up, try again with incremented indexes - let tryAgain (typeIndex, measureIndex) = + let tryAgain (typeIndex, measureIndex) = choose (tp :: tps) (typeIndex, measureIndex) acc - let tryName (nm, typeIndex, measureIndex) f = - if List.contains nm alreadyInUse then - f() + 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)) + 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 () -> + 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))) + 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 + ||> 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 + + 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 + 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 - + let niceTypars, renaming = NewPrettyTypars [] ftps names + // strip universal types for printing - let getTauStayTau ty = + let getTauStayTau ty = match ty with - | TType_forall (_, tau) -> tau + | 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) + + 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 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 + + 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 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 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 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)) + 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)) + 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)) + 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 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 - 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 + // CAREFUL! This function does NOT walk constraints let rec foldTypeButNotConstraints f z ty = - let ty = stripTyparEqns ty + let ty = stripTyparEqns ty let z = f z ty + match ty with - | TType_forall (_, bodyTy) -> - foldTypeButNotConstraints f z bodyTy + | 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_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_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 + 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 -> + // 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 + | 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 + // 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 = [] } + { + 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 = + 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 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 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 + 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 @@ -3173,196 +3899,220 @@ type GenericParameterStyle = | Suffix [] -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 - } +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) = + 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 } + { denv with + contextAccessibility = combineAccess denv.contextAccessibility access + } member denv.UseGenericParameterStyle style = - { denv with genericParameterStyle = style } + { denv with + genericParameterStyle = style + } 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 } + showInferenceTyparAnnotations = true + showHiddenMembers = true + showObsoleteMembers = true + showAttributes = true + suppressInlineKeyword = false + showDocumentation = true + shrinkOverloads = false + escapeKeywordNames = true + includeStaticParametersInTypeNames = true + } + denv.SetOpenPaths - [ FSharpLib.RootPath - FSharpLib.CorePath - CollectionsPath - ControlPath - (splitNamespace ExtraTopLevelOperatorsName) ] + [ + FSharpLib.RootPath + FSharpLib.CorePath + CollectionsPath + ControlPath + (splitNamespace ExtraTopLevelOperatorsName) + ] -let (+.+) s1 s2 = if String.IsNullOrEmpty(s1) then s2 else !!s1+"."+s2 +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 +let fullNameOfParentOfPubPath pp = + match pp with + | PubPath([| _ |]) -> ValueNone | pp -> ValueSome(textOfPath pp.EnclosingPath) -let fullNameOfParentOfPubPathAsLayout pp = - match pp with - | PubPath([| _ |]) -> ValueNone +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 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 fullNameOfParentOfNonLocalEntityRefAsLayout (nlr: NonLocalEntityRef) = + if nlr.Path.Length < 2 then + ValueNone + else + ValueSome(layoutOfPath (List.ofArray nlr.EnclosingMangledPath)) -let fullNameOfParentOfEntityRef eref = - match eref with +let fullNameOfParentOfEntityRef eref = + match eref with | ERefLocal x -> - match x.PublicPath with - | None -> ValueNone - | Some ppath -> fullNameOfParentOfPubPath ppath + match x.PublicPath with + | None -> ValueNone + | Some ppath -> fullNameOfParentOfPubPath ppath | ERefNonLocal nlr -> fullNameOfParentOfNonLocalEntityRef nlr -let fullNameOfParentOfEntityRefAsLayout eref = - match eref with +let fullNameOfParentOfEntityRefAsLayout eref = + match eref with | ERefLocal x -> - match x.PublicPath with - | None -> ValueNone - | Some ppath -> fullNameOfParentOfPubPathAsLayout ppath + 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 +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) = + 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 + 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 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 @@ -3384,17 +4134,19 @@ let fullDisplayTextOfUnionCaseRef (ucref: UnionCaseRef) = let fullDisplayTextOfRecdFieldRef (rfref: RecdFieldRef) = fullDisplayTextOfTyconRef rfref.TyconRef +.+ rfref.FieldName -let fullDisplayTextOfValRef (vref: ValRef) = - match fullNameOfParentOfValRef vref with - | ValueNone -> vref.DisplayName +let fullDisplayTextOfValRef (vref: ValRef) = + match fullNameOfParentOfValRef vref with + | ValueNone -> vref.DisplayName | ValueSome pathText -> pathText +.+ vref.DisplayName -let fullDisplayTextOfValRefAsLayout (vref: ValRef) = +let fullDisplayTextOfValRefAsLayout (vref: ValRef) = let n = match vref.MemberInfo with - | None -> - if vref.IsModuleBinding then tagModuleBinding vref.DisplayName - else tagUnknownEntity vref.DisplayName + | None -> + if vref.IsModuleBinding then + tagModuleBinding vref.DisplayName + else + tagUnknownEntity vref.DisplayName | Some memberInfo -> match memberInfo.MemberFlags.MemberKind with | SynMemberKind.PropertyGet @@ -3403,19 +4155,22 @@ let fullDisplayTextOfValRefAsLayout (vref: ValRef) = | 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) + + 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 tyconRefToFullName (tcref: TyconRef) = let namespaceParts = // we need to ensure there are no collisions between (for example) // - ``IB`` (non-generic) @@ -3425,304 +4180,411 @@ let tyconRefToFullName (tcref:TyconRef) = match fullMangledPathToTyconRef tcref with | [||] -> [| "global`" |] | ns -> ns - seq { yield! namespaceParts; yield tcref.DisplayName } |> String.concat "." -let rec qualifiedInterfaceImplementationNameAux g (x:TType) : string = + 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_app(a, [], _) -> tyconRefToFullName a + + | TType_anon(a, b) -> + let genericParameters = + b |> Seq.map (qualifiedInterfaceImplementationNameAux g) |> String.concat ", " - | 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 ", " + | TType_app(a, b, _) -> + let genericParameters = + b |> Seq.map (qualifiedInterfaceImplementationNameAux g) |> String.concat ", " + sprintf "%s<%s>" (tyconRefToFullName a) genericParameters - | TType_var (v, _) -> - "'" + v.Name + | TType_var(v, _) -> "'" + v.Name - | _ -> - failwithf "unexpected: expected TType_app but got %O" (x.GetType()) + | _ -> 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 qualifiedMangledNameOfTyconRef tcref nm = + String.concat + "-" + (Array.toList (fullMangledPathToTyconRef tcref) + @ [ tcref.LogicalName + "-" + nm ]) -let rec firstEq p1 p2 = +let rec firstEq p1 p2 = match p1 with - | [] -> true - | h1 :: t1 -> - match p2 with + | [] -> true + | h1 :: t1 -> + match p2 with | h2 :: t2 -> h1 = h2 && firstEq t1 t2 - | _ -> false + | _ -> false -let rec firstRem p1 p2 = - match p1 with [] -> p2 | _ :: t1 -> firstRem t1 (List.tail p2) +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 findOpenedNamespace openedPath = + if firstEq openedPath path then let t2 = firstRem openedPath path - if t2 <> [] then Some(textOfPath t2 + ".") - else Some("") - else None + 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 +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 -> + tcref + |> Array.unfold (fun tcref -> match tcref.TypeContents.tcaug_super with - | Some (TType_app(sup, _, _)) -> Some(sup, sup) + | Some(TType_app(sup, _, _)) -> Some(sup, sup) | _ -> None) //---------------------------------------------------------------------------- // 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) +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) = +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) +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) +// 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 TryFindFSharpAttributeOpt g tref attrs = match tref with None -> None | Some tref -> List.tryFind (IsMatchingFSharpAttribute g tref) attrs -let HasFSharpAttributeOpt g trefOpt attrs = match trefOpt with Some tref -> List.exists (IsMatchingFSharpAttribute g tref) attrs | _ -> false -let IsMatchingFSharpAttributeOpt g attrOpt (Attrib(tcref2, _, _, _, _, _, _)) = match attrOpt with Some (AttribInfo(_, tcref)) -> tyconRefEq g tcref tcref2 | _ -> false +let HasFSharpAttribute g tref attrs = + List.exists (IsMatchingFSharpAttribute g tref) attrs + +let TryFindFSharpAttribute g tref attrs = + List.tryFind (IsMatchingFSharpAttribute g tref) attrs + +let TryFindFSharpAttributeOpt g tref attrs = + match tref with + | None -> None + | Some tref -> List.tryFind (IsMatchingFSharpAttribute g tref) attrs + +let HasFSharpAttributeOpt g trefOpt attrs = + match trefOpt with + | Some tref -> List.exists (IsMatchingFSharpAttribute g tref) attrs + | _ -> false + +let IsMatchingFSharpAttributeOpt g attrOpt (Attrib(tcref2, _, _, _, _, _, _)) = + match attrOpt with + | Some(AttribInfo(_, tcref)) -> tyconRefEq g tcref tcref2 + | _ -> false [] -let (|ExtractAttribNamedArg|_|) nm args = - args |> List.tryPick (function AttribNamedArg(nm2, _, _, v) when nm = nm2 -> Some v | _ -> None) |> ValueOption.ofOption +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 (|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 (|StringExpr|_|) = + function + | Expr.Const(Const.String n, _, _) -> ValueSome n + | _ -> ValueNone [] -let (|AttribInt32Arg|_|) = function AttribExpr(_, Expr.Const (Const.Int32 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 (|AttribInt16Arg|_|) = + function + | AttribExpr(_, Expr.Const(Const.Int16 n, _, _)) -> ValueSome n + | _ -> ValueNone [] -let (|AttribBoolArg|_|) = function AttribExpr(_, Expr.Const (Const.Bool 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 (|AttribStringArg|_|) = + function + | AttribExpr(_, Expr.Const(Const.String n, _, _)) -> ValueSome n + | _ -> ValueNone -let (|AttribElemStringArg|_|) = function ILAttribElem.String(n) -> n | _ -> None +let (|AttribElemStringArg|_|) = + function + | ILAttribElem.String(n) -> n + | _ -> None -let TryFindFSharpBoolAttributeWithDefault dflt g nm attrs = +let TryFindFSharpBoolAttributeWithDefault dflt g nm attrs = match TryFindFSharpAttribute g nm attrs with - | Some(Attrib(_, _, [ ], _, _, _, _)) -> Some dflt + | Some(Attrib(_, _, [], _, _, _, _)) -> Some dflt | Some(Attrib(_, _, [ AttribBoolArg b ], _, _, _, _)) -> Some b | _ -> None -let TryFindFSharpBoolAttribute g nm attrs = TryFindFSharpBoolAttributeWithDefault true g nm attrs -let TryFindFSharpBoolAttributeAssumeFalse g nm attrs = TryFindFSharpBoolAttributeWithDefault false g nm attrs +let TryFindFSharpBoolAttribute g nm attrs = + TryFindFSharpBoolAttributeWithDefault true g nm attrs + +let TryFindFSharpBoolAttributeAssumeFalse g nm attrs = + TryFindFSharpBoolAttributeWithDefault false g nm attrs -let TryFindFSharpInt32Attribute g nm attrs = +let TryFindFSharpInt32Attribute g nm attrs = match TryFindFSharpAttribute g nm attrs with | Some(Attrib(_, _, [ AttribInt32Arg b ], _, _, _, _)) -> Some b | _ -> None - -let TryFindFSharpStringAttribute g nm attrs = + +let TryFindFSharpStringAttribute g nm attrs = match TryFindFSharpAttribute g nm attrs with | Some(Attrib(_, _, [ AttribStringArg b ], _, _, _, _)) -> Some b | _ -> None -let TryFindLocalizedFSharpStringAttribute g nm attrs = +let TryFindLocalizedFSharpStringAttribute g nm attrs = match TryFindFSharpAttribute g nm attrs with - | Some(Attrib(_, _, [ AttribStringArg b ], namedArgs, _, _, _)) -> - match namedArgs with + | Some(Attrib(_, _, [ AttribStringArg b ], namedArgs, _, _, _)) -> + match namedArgs with | ExtractAttribNamedArg "Localize" (AttribBoolArg true) -> FSComp.SR.GetTextOpt(b) | _ -> Some b | _ -> None - -let TryFindILAttribute (AttribInfo (atref, _)) attrs = - HasILAttribute atref attrs -let TryFindILAttributeOpt attr attrs = +let TryFindILAttribute (AttribInfo(atref, _)) attrs = HasILAttribute atref attrs + +let TryFindILAttributeOpt attr attrs = match attr with - | Some (AttribInfo (atref, _)) -> HasILAttribute atref attrs + | Some(AttribInfo(atref, _)) -> HasILAttribute atref attrs | _ -> false -let IsILAttrib (AttribInfo (builtInAttrRef, _)) attr = isILAttrib builtInAttrRef attr - +let IsILAttrib (AttribInfo(builtInAttrRef, _)) attr = isILAttrib builtInAttrRef attr /// 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) (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 +let TryBindTyconRefAttribute + g + (m: range) + (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 + | 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 TryDecodeILAttribute atref tdef.CustomAttrs with + | ILTypeMetadata(TILObjectReprData(_, _, tdef)) -> + match TryDecodeILAttribute atref tdef.CustomAttrs with | Some attr -> f1 attr | _ -> None - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - match TryFindFSharpAttribute g args tcref.Attribs with + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + match TryFindFSharpAttribute g args tcref.Attribs with | Some attr -> f2 attr | _ -> None 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) + 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 |] + [| 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)) - ) + 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) + 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) /// 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 + TryBindTyconRefAttribute g m attribSpec tcref (fun _ -> Some()) (fun _ -> Some()) (fun _ -> Some()) + |> Option.isSome let HasDefaultAugmentationAttribute g (tcref: TyconRef) = match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with | Some(Attrib(_, _, [ AttribBoolArg b ], _, _, _, _)) -> b - | Some (Attrib(_, _, _, _, _, _, m)) -> - errorR(Error(FSComp.SR.ilDefaultAugmentationAttributeCouldNotBeDecoded(), m)) + | Some(Attrib(_, _, _, _, _, _, m)) -> + errorR (Error(FSComp.SR.ilDefaultAugmentationAttributeCouldNotBeDecoded (), m)) true | _ -> true /// Check if a type definition has an attribute with a specific full name -let TyconRefHasAttributeByName (m: range) attrFullName (tcref: TyconRef) = +let TyconRefHasAttributeByName (m: range) attrFullName (tcref: TyconRef) = ignore m - match metadataOfTycon tcref.Deref with + + 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 + | 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)) -> + | 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.ILAsmNamed(typeRef, _, _) -> typeRef.Enclosing.IsEmpty && typeRef.Name = attrFullName | CompiledTypeRepr.ILAsmOpen _ -> false) -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 +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 // See RFC FS-1053.md -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 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) + 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 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) + isByrefLikeTy g m ty && not (isByrefTy g ty) let isSpanTyconRef g m tcref = - isByrefLikeTyconRef g m tcref && - tcref.CompiledRepresentationForNamedType.BasicQualifiedName = "System.Span`1" + 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) + 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) + | ValueSome(tcref, [ ty ]) when isSpanTyconRef g m tcref -> Some(tcref, ty) | _ -> None let destSpanTy g m ty = @@ -3731,488 +4593,553 @@ let destSpanTy g m ty = | _ -> failwith "destSpanTy" let isReadOnlySpanTyconRef g m tcref = - isByrefLikeTyconRef g m tcref && - tcref.CompiledRepresentationForNamedType.BasicQualifiedName = "System.ReadOnlySpan`1" + 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) + 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) + | 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" + | _ -> failwith "destReadOnlySpanTy" //------------------------------------------------------------------------- // List and reference types... -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let destByrefTy g ty = +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 + | 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 = +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 + 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 + | 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 +let isRefCellTy g ty = + match tryTcrefOfAppTy g ty with | ValueNone -> false | ValueSome tcref -> tyconRefEq g g.refcell_tcr_canon tcref -let destRefCellTy g ty = +let destRefCellTy g ty = match ty |> stripTyEqns g with - | TType_app(tcref, [x], _) when tyconRefEq g g.refcell_tcr_canon tcref -> x + | 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 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 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 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 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 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 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 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 mkListTy (g: TcGlobals) ty = + TType_app(g.list_tcr_nice, [ ty ], g.knownWithoutNull) -let isBoolTy (g: TcGlobals) ty = - match tryTcrefOfAppTy g ty with +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 + | 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 +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 +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 +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 + 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 +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 +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 +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 +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 +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 +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 +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 +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 + 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 +let (|StripNullableTy|) g ty = + match tryDestNullableTy g ty with | ValueSome tyarg -> tyarg | _ -> ty -let isLinqExpressionTy g ty = - match tryTcrefOfAppTy g ty with +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 +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 +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 mkNoneCase (g: TcGlobals) = + mkUnionCaseRef g.option_tcr_canon "None" -let mkSomeCase (g: TcGlobals) = mkUnionCaseRef g.option_tcr_canon "Some" +let mkSomeCase (g: TcGlobals) = + mkUnionCaseRef g.option_tcr_canon "Some" -let mkSome g ty arg m = mkUnionCaseExpr(mkSomeCase g, [ty], [arg], m) +let mkSome g ty arg m = + mkUnionCaseExpr (mkSomeCase g, [ ty ], [ arg ], m) -let mkNone g ty m = mkUnionCaseExpr(mkNoneCase g, [ty], [], m) +let mkNone g ty m = + mkUnionCaseExpr (mkNoneCase g, [ ty ], [], m) -let mkValueNoneCase (g: TcGlobals) = mkUnionCaseRef g.valueoption_tcr_canon "ValueNone" +let mkValueNoneCase (g: TcGlobals) = + mkUnionCaseRef g.valueoption_tcr_canon "ValueNone" -let mkValueSomeCase (g: TcGlobals) = mkUnionCaseRef g.valueoption_tcr_canon "ValueSome" +let mkValueSomeCase (g: TcGlobals) = + mkUnionCaseRef g.valueoption_tcr_canon "ValueSome" -let mkAnySomeCase g isStruct = (if isStruct then mkValueSomeCase g else mkSomeCase g) +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 mkValueSome g ty arg m = + mkUnionCaseExpr (mkValueSomeCase g, [ ty ], [ arg ], m) -let mkValueNone g ty m = mkUnionCaseExpr(mkValueNoneCase g, [ty], [], m) +let mkValueNone g ty m = + mkUnionCaseExpr (mkValueNoneCase g, [ ty ], [], m) -type ValRef with - member vref.IsDispatchSlot = - match vref.MemberInfo with - | Some membInfo -> membInfo.MemberFlags.IsDispatchSlot +type ValRef with + member vref.IsDispatchSlot = + match vref.MemberInfo with + | Some membInfo -> membInfo.MemberFlags.IsDispatchSlot | None -> false [] -let (|UnopExpr|_|) _g expr = - match expr with - | Expr.App (Expr.Val (vref, _, _), _, _, [arg1], _) -> ValueSome (vref, arg1) +let (|UnopExpr|_|) _g expr = + match expr with + | Expr.App(Expr.Val(vref, _, _), _, _, [ arg1 ], _) -> ValueSome(vref, arg1) | _ -> ValueNone [] -let (|BinopExpr|_|) _g expr = - match expr with - | Expr.App (Expr.Val (vref, _, _), _, _, [arg1;arg2], _) -> ValueSome (vref, arg1, arg2) +let (|BinopExpr|_|) _g expr = + match expr with + | Expr.App(Expr.Val(vref, _, _), _, _, [ arg1; arg2 ], _) -> ValueSome(vref, arg1, arg2) | _ -> ValueNone [] -let (|SpecificUnopExpr|_|) g vrefReqd expr = - match expr with +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 () + | 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 () + | 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 () + | 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) +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 = +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 (|BitwiseOrExpr|_|) g expr = + (|SpecificBinopExpr|_|) g g.bitwise_or_vref expr [] -let (|AttribBitwiseOrExpr|_|) g expr = - match expr with +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 + // 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) + | Expr.App(Expr.Lambda _, _, _, [ arg1; arg2 ], _) when g.compilingFSharpCore -> ValueSome(arg1, arg2) | _ -> ValueNone -let isUncheckedDefaultOfValRef g vref = - valRefEq g vref g.unchecked_defaultof_vref +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") + || (g.compilingFSharpCore && vref.LogicalName = "defaultof") -let isTypeOfValRef g vref = - valRefEq g vref g.typeof_vref +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") + || (g.compilingFSharpCore && vref.LogicalName = "typeof") -let isSizeOfValRef g vref = - valRefEq g vref g.sizeof_vref +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") + || (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 +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") + || (g.compilingFSharpCore && vref.LogicalName = "typedefof") [] -let (|UncheckedDefaultOfExpr|_|) g expr = - match expr with - | Expr.App (Expr.Val (vref, _, _), _, [ty], [], _) when isUncheckedDefaultOfValRef g vref -> ValueSome ty +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 +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 +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 +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 +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() +let (|SeqExpr|_|) g expr = + match expr with + | Expr.App(Expr.Val(vref, _, _), _, _, _, _) when valRefEq g vref g.seq_vref -> ValueSome() | _ -> ValueNone //-------------------------------------------------------------------------- // DEBUG layout //--------------------------------------------------------------------------- -module DebugPrint = +module DebugPrint = 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 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 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 + 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 angleBracketL l = + leftL (tagText "<") ^^ l ^^ rightL (tagText ">") - let angleBracketListL l = angleBracketL (sepListL (sepL (tagText ",")) l) + 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 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 + 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 stampL (n: Stamp) w = + if layoutStamps then + w ^^ wordL (tagText ("#" + string n)) + else + w - let layoutTyconRef (tcref: TyconRef) = + 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) = + 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 + 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_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_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_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_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 - | TType_fun (domainTy, rangeTy, nullness) -> - let coreL = ((auxTypeAtomL env domainTy ^^ wordL (tagText "->")) --- auxTypeL env rangeTy) |> wrap - auxAddNullness coreL nullness + auxAddNullness coreL nullness - | TType_var (typar, nullness) -> - let coreL = auxTyparWrapL env isAtomic typar - 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_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 "}") + 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 "") + unt |> ignore + wordL (tagText "") #endif and auxTyparWrapL (env: SimplifyTypes.TypeSimplificationInfo) isAtomic (typar: Typar) = - let tpText = - prefixOfStaticReq typar.StaticReq - + prefixOfInferenceTypar typar - + typar.DisplayName + let tpText = + prefixOfStaticReq typar.StaticReq + + prefixOfInferenceTypar typar + + typar.DisplayName - let tpL = wordL (tagText tpText) + let tpL = wordL (tagText tpText) - let varL = tpL |> stampL typar.Stamp + 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 + // 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 + else + (varL ^^ sepL (tagText ":>") ^^ auxTyparConstraintTypL env typarConstraintTy) + |> bracketIfL isAtomic + | _ -> varL and auxTypar2L env typar = auxTyparWrapL env false typar @@ -4220,86 +5147,97 @@ module DebugPrint = and auxTraitL env (ttrait: TraitConstraintInfo) = #if DEBUG - let (TTrait(tys, nm, memFlags, argTys, retTy, _, _)) = ttrait + let (TTrait(tys, nm, memFlags, argTys, retTy, _, _)) = ttrait + match global_g with | None -> wordL (tagText "") - | Some g -> + | 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)) + + 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") + wordL (tagText "trait") #endif - and auxTyparConstraintL env (tp, tpc) = - let constraintPrefix l = auxTypar2L env tp ^^ wordL (tagText ":") ^^ l + 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 + 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 + 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 + 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 + bracketL (sepListL (sepL (tagText "|")) (List.map (auxTypeL env) tys)) + |> constraintPrefix | TyparConstraint.RequiresDefaultConstructor _ -> - bracketL (wordL (tagText "new : unit -> ") ^^ (auxTypar2L env tp)) |> constraintPrefix + bracketL (wordL (tagText "new : unit -> ") ^^ (auxTypar2L env tp)) + |> constraintPrefix - and auxTyparConstraintsL env x = - match x with + 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 typarL tp = + auxTypar2L SimplifyTypes.typeSimplificationInfo0 tp and typeAtomL tau = let tau, cxs = tau, [] - let env = SimplifyTypes.CollectInfo false [tau] cxs + 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 + let env = SimplifyTypes.CollectInfo false [ tau ] cxs + match env.postfixConstraints with - | [] -> auxTypeL env tau - | _ -> (auxTypeL env tau --- auxTyparConstraintsL env env.postfixConstraints) + | [] -> 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 + let env = SimplifyTypes.CollectInfo false [ tau ] cxs + match env.postfixConstraints with - | [] -> auxTypeL env tau - | _ -> (auxTypeL env tau --- auxTyparConstraintsL env env.postfixConstraints) + | [] -> auxTypeL env tau + | _ -> (auxTypeL env tau --- auxTyparConstraintsL env env.postfixConstraints) + and layoutTyparDecls tps = match tps with | [] -> emptyL - | _ -> angleBracketListL (List.map typarDeclL tps) + | _ -> angleBracketListL (List.map typarDeclL tps) let rangeL m = wordL (tagText (stringOfRange m)) @@ -4311,471 +5249,604 @@ module DebugPrint = else emptyL - let valRefL (vr: ValRef) = - wordL (tagText vr.LogicalName) |> stampL vr.Stamp + 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 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 layoutAttribs attribs = + aboveListL (List.map layoutAttrib attribs) - let valReprInfoL (ValReprInfo (tpNames, _, _) as tvd) = + let valReprInfoL (ValReprInfo(tpNames, _, _) as tvd) = let ns = tvd.AritiesOfArgs - leftL (tagText "<") ^^ intL tpNames.Length ^^ sepL (tagText ">[") ^^ commaListL (List.map intL ns) ^^ rightL (tagText "]") + + 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 = + 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 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) + (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 + let (TSlotSig(nm, ty, tps1, tps2, pms, retTy)) = slotsig + match global_g with - | None -> wordL(tagText "") - | Some g -> + | 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) + + (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") + 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 v.IsMutable then wordL (tagText "mutable") ++ vL else vL) + let vL = if layoutTypes then - vL ^^ wordL(tagText ":") ^^ typeL v.Type + vL ^^ wordL (tagText ":") ^^ typeL v.Type else vL + let vL = match v.ValReprInfo with - | Some info when layoutValReprInfo -> vL ^^ wordL(tagText "!") ^^ valReprInfoL info + | 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 + // Note: We need nice printing of constants in order to print literals and attributes let constL c = - let str = + 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.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 -> + | 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 -> System.Char.IsDigit c || c = '-') s - then s + ".0" - else s) + "f" - | Const.Double d -> + + if String.forall (fun c -> System.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 -> System.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" + + if String.forall (fun c -> System.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) + wordL (tagText str) - let layoutUnionCaseArgTypes argTys = sepListL (wordL(tagText "*")) (List.map typeL argTys) + 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 + | argTys -> (prefixL ^^ nmL ^^ wordL (tagText "of")) --- layoutUnionCaseArgTypes argTys let layoutUnionCases ucases = - let prefixL = if not (isNilOrSingleton ucases) then wordL(tagText "|") else emptyL + 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 + + 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 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 = + let start = match r.fsobjmodel_kind with - | TFSharpClass -> "class" - | TFSharpInterface -> "interface" - | TFSharpStruct -> "struct" - | TFSharpEnum -> "enum" + | TFSharpClass -> "class" + | TFSharpInterface -> "interface" + | TFSharpStruct -> "struct" + | TFSharpEnum -> "enum" | _ -> failwith "???" - let inherits = + let inherits = match r.fsobjmodel_kind, tycon.TypeContents.tcaug_super with - | TFSharpClass, Some super -> [wordL(tagText "inherit") ^^ (typeL super)] - | TFSharpInterface, _ -> + | 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)) + |> 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 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 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 + let emptyMeasure = + match tycon.TypeOrMeasureKind with + | TyparKind.Measure -> isNil alldecls + | _ -> false - if emptyMeasure then emptyL else (wordL (tagText start) @@-- aboveListL alldecls) @@ wordL(tagText "end") + if emptyMeasure then + emptyL + else + (wordL (tagText start) @@-- aboveListL alldecls) @@ wordL (tagText "end") - | TAsmRepr _ -> wordL(tagText "(# ... #)") + | TAsmRepr _ -> wordL (tagText "(# ... #)") | TMeasureableRepr ty -> typeL ty - | TILObjectRepr (TILObjectReprData(_, _, td)) -> wordL (tagText td.Name) + | TILObjectRepr(TILObjectReprData(_, _, td)) -> wordL (tagText td.Name) | _ -> failwith "unreachable" let rec bindingL (TBind(v, repr, _)) = - (valAtBindL v ^^ wordL(tagText "=")) @@-- exprL repr + (valAtBindL v ^^ wordL (tagText "=")) @@-- exprL repr - and exprL expr = - exprWrapL false expr + and exprL expr = exprWrapL false expr and atomL expr = - // true means bracket if needed to be atomic expr + // true means bracket if needed to be atomic expr exprWrapL true expr - and letRecL binds bodyL = - let eqnsL = + 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) + |> List.mapHeadTail (fun bind -> wordL (tagText "rec") ^^ bindingL bind ^^ wordL (tagText "in")) (fun bind -> + wordL (tagText "and") ^^ bindingL bind ^^ wordL (tagText "in")) - and letL bind bodyL = - let eqnL = wordL(tagText "let") ^^ bindingL bind - (eqnL @@ bodyL) + (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 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 - ] + | 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, _, _) -> + | Expr.Lambda(_, _, baseValOpt, argvs, body, _, _) -> let formalsL = spaceListL (List.map valAtBindL argvs) - let bindingL = + + 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 "->") + | 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.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.TyChoose(tps, body, _) -> + ((wordL (tagText "CHOOSE") ^^ layoutTyparDecls tps ^^ wordL (tagText "->")) + ++ exprL body) + |> wrap - | Expr.App (f, _, tys, argTys, _) -> + | Expr.App(f, _, tys, argTys, _) -> let flayout = atomL f appL flayout tys argTys |> wrap - | Expr.LetRec (binds, body, _, _) -> - letRecL binds (exprL body) |> wrap + | Expr.LetRec(binds, body, _, _) -> letRecL binds (exprL body) |> wrap - | Expr.Let (bind, body, _, _) -> - letL bind (exprL body) |> wrap + | Expr.Let(bind, body, _, _) -> letL bind (exprL body) |> wrap - | Expr.Link rX -> - exprL rX.Value |> 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.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.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.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.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.Tuple _, _, xs, _) -> tupleL (List.map exprL xs) - | Expr.Op (TOp.Recd (ctor, tcref), _, 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 = + + 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 + | 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, _, [ 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.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, _, [ rx ], _) -> atomL rx ^^ rightL (tagText ".#") ^^ recdFieldRefL rf - | Expr.Op (TOp.ValFieldGet rf, _, [], _) -> - 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, _), _, [ rx ], _) -> + leftL (tagText "&") + ^^ bracketL (atomL rx ^^ rightL (tagText ".!") ^^ recdFieldRefL rf) - | Expr.Op (TOp.ValFieldGetAddr (rf, _), _, [], _) -> - leftL(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.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.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.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.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.TupleFieldGet(_, i), _, [ x ], _) -> wordL (tagText ("#" + string i)) --- atomL x - | Expr.Op (TOp.Coerce, [ty;_], [x], _) -> - atomL x --- (wordL(tagText ":>") ^^ typeL ty) + | Expr.Op(TOp.Coerce, [ ty; _ ], [ x ], _) -> atomL x --- (wordL (tagText ":>") ^^ typeL ty) - | Expr.Op (TOp.Reraise, [_], [], _) -> - wordL(tagText "Reraise") + | 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 "#)") + | 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 + + 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.LValueOp(lvop, vr), _, args, _) -> + (lvalopL lvop ^^ valRefL vr --- bracketL (commaListL (List.map atomL args))) + |> wrap - | Expr.Op (TOp.ILCall (_, _, _, _, _, _, _, ilMethRef, _enclTypeInst, _methInst, _), _tyargs, args, _) -> + | 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 - + + (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.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") + | 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") + | 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 + | 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 "}") + 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 + | 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 - ] + 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) + + 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 + 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 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 + (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) + 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 = + 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) -> [] + + 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) + // 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 + + (wordL (tagText "with") @@-- aboveListL (iimplsLs @ adhocLs)) + @@ wordL (tagText "end") + + let reprL = + match tycon.TypeReprInfo with #if !NO_TYPEPROVIDERS | TProvidedTypeRepr _ | TProvidedNamespaceRepr _ #endif - | TNoRepr -> + | TNoRepr -> match tycon.TypeAbbrev with | None -> lhsL @@-- memberLs - | Some a -> (lhsL ^^ wordL(tagText "=")) --- (typeL a @@ memberLs) - | a -> + | Some a -> (lhsL ^^ wordL (tagText "=")) --- (typeL a @@ memberLs) + | a -> let rhsL = tyconReprL (a, tycon) @@ memberLs - (lhsL ^^ wordL(tagText "=")) @@-- rhsL + (lhsL ^^ wordL (tagText "=")) @@-- rhsL + reprL and entityL (entity: Entity) = @@ -4786,11 +5857,17 @@ module DebugPrint = and mexprL mtyp defs = let resL = mdefL defs - let resL = if layoutTypes then resL @@- (wordL(tagText ":") @@- moduleOrNamespaceTypeL mtyp) else resL + + 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) + wordL (tagText "Module Defs") @@-- aboveListL (List.map mdefL defs) and mdefL x = match x with @@ -4801,25 +5878,34 @@ module DebugPrint = | 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 + 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] + 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 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 implFileL (CheckedImplFile(signature = implFileTy; contents = implFileContents)) = + aboveListL + [ + (wordL (tagText "top implementation ")) @@-- mexprL implFileTy implFileContents + ] + let implFilesL implFiles = aboveListL (List.map implFileL implFiles) @@ -4827,7 +5913,8 @@ module DebugPrint = let showExpr x = showL (exprL x) - let traitL x = auxTraitL SimplifyTypes.typeSimplificationInfo0 x + let traitL x = + auxTraitL SimplifyTypes.typeSimplificationInfo0 x let typarsL x = layoutTyparDecls x @@ -4835,218 +5922,323 @@ module DebugPrint = // Helpers related to type checking modules & namespaces //-------------------------------------------------------------------------- -let wrapModuleOrNamespaceType id cpath mtyp = +let wrapModuleOrNamespaceType id cpath mtyp = Construct.NewModuleOrNamespace (Some cpath) taccessPublic id XmlDoc.Empty [] (MaybeLazy.Strict mtyp) -let wrapModuleOrNamespaceTypeInNamespace id cpath 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) + 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 } +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 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. + + 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. + | _ -> + // 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 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. + | _ -> + // 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 with + HiddenUnionCases = Zset.add ucref mhi.HiddenUnionCases + }) + mhi - (mrpi, 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 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 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 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 + + 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 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 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 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 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 + + 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 +/// 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 +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 = +and accEntityRemapFromModuleOrNamespaceDefs msigty mdefs acc = List.foldBack (accEntityRemapFromModuleOrNamespace msigty) mdefs acc -and accEntityRemapFromModuleOrNamespaceBind msigty x acc = - match x with +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 + 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 +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) + 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 -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 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 + + let valAndEntityRemap = + accValRemapFromModuleOrNamespace g aenv msigty mdef entityRemap + valAndEntityRemap //-------------------------------------------------------------------------- @@ -5054,66 +6246,97 @@ let ComputeRemappingFromImplementationToSignature g mdef msigty = //-------------------------------------------------------------------------- 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 + 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 + + { 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 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 +// 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 + 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 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 -let ComputeSignatureHidingInfoAtAssemblyBoundary mty acc = + acc + +let ComputeSignatureHidingInfoAtAssemblyBoundary mty acc = accModuleOrNamespaceHidingInfoAtAssemblyBoundary mty acc -let rec accImplHidingInfoAtAssemblyBoundary mdef acc = - match mdef with - | TMDefRec(_isRec, _opens, tycons, mbinds, _m) -> +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 -> + (mbinds, acc) + ||> List.foldBack (fun mbind acc -> match mbind with - | ModuleOrNamespaceBinding.Binding bind -> - accValHidingInfoAtAssemblyBoundary bind.Var acc - | ModuleOrNamespaceBinding.Module(_mspec, def) -> - accImplHidingInfoAtAssemblyBoundary def acc) + | ModuleOrNamespaceBinding.Binding bind -> accValHidingInfoAtAssemblyBoundary bind.Var acc + | ModuleOrNamespaceBinding.Module(_mspec, def) -> accImplHidingInfoAtAssemblyBoundary def acc) + acc - | TMDefOpens _openDecls -> acc + | TMDefOpens _openDecls -> acc | TMDefLet(bind, _m) -> accValHidingInfoAtAssemblyBoundary bind.Var acc @@ -5121,75 +6344,110 @@ let rec accImplHidingInfoAtAssemblyBoundary mdef acc = | TMDefs defs -> List.foldBack accImplHidingInfoAtAssemblyBoundary defs acc -let ComputeImplementationHidingInfoAtAssemblyBoundary mty acc = +let ComputeImplementationHidingInfoAtAssemblyBoundary mty acc = accImplHidingInfoAtAssemblyBoundary mty acc -let DoRemap setF remapF = +let DoRemap setF remapF = let rec remap mrmi x = match mrmi with - | [] -> x - | (rpi, mhi) :: rest -> + | [] -> 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 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 +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 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)) + 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 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 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 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 +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 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 [] +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 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 = +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 @@ -5201,12 +6459,12 @@ let freeVarsAllPublic fvs = // // 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 + Zset.forall isPublicVal fvs.FreeLocals + && Zset.forall isPublicUnionCase fvs.FreeUnionCases + && Zset.forall isPublicRecdField fvs.FreeRecdFields + && Zset.forall isPublicTycon fvs.FreeTyvars.FreeTycons -let freeTyvarsAllPublic tyvars = +let freeTyvarsAllPublic tyvars = Zset.forall isPublicTycon tyvars.FreeTycons /// Detect the subset of match expressions we process in a linear way (i.e. using tailcalls, rather than @@ -5215,494 +6473,575 @@ let freeTyvarsAllPublic tyvars = /// -- 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) +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) + +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 (|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) + ValueSome(op, tinst, argsFront, argLast, m) | _ -> ValueNone - -let rebuildLinearOpExpr (op, tinst, argsFront, argLast, m) = - Expr.Op (op, tinst, argsFront@[argLast], m) + +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 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' } + 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 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 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} + 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 + 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 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 + 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 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 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 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 + 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 + 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} + + { fvs with + FreeLocals = Zset.add v fvs.FreeLocals + } let accFreeInValFlags opts flag acc = - let isMethLocal = - match flag with - | VSlotDirectCall - | CtorValUsedAsSelfInit - | CtorValUsedAsSuperInit -> true + let isMethLocal = + match flag with + | VSlotDirectCall + | CtorValUsedAsSelfInit + | CtorValUsedAsSuperInit -> true | PossibleConstrainedCall _ | NormalValUse -> false + let acc = accUsesFunctionLocalConstructs isMethLocal acc - match flag with + + 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 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 = + +and accFreeInSwitchCase opts (TCase(discrim, dtree)) acc = accFreeInDecisionTree opts dtree (accFreeInTest opts discrim acc) -and accFreeInTest (opts: FreeVarOptions) discrim acc = - match discrim with +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 + | 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 + 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 + | 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 + 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 +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 + { 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 } + 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 +and accFreeValRef opts (vref: ValRef) fvs = + match vref.IsLocalRef with | true -> accFreeLocalVal opts vref.ResolvedTarget fvs - // non-local values do not contain free variables + // 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) + accFreeInSlotSig + opts + slotsig + (unionFreeVars (accFreeTyvars opts boundTypars tps (List.foldBack (boundLocalVals opts) tmvs (freeInExpr opts e))) acc) -and accFreeInMethods opts methods acc = +and accFreeInMethods opts methods acc = List.foldBack (accFreeInMethod opts) methods acc -and accFreeInInterfaceImpl opts (ty, overrides) acc = +and accFreeInInterfaceImpl opts (ty, overrides) acc = accFreeVarsInTy opts ty (accFreeInMethods opts overrides acc) -and accFreeInExpr (opts: FreeVarOptions) x 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 + +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) -> + | 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 - )) - | _ -> + 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) + | 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))))) + | 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) -> + | 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.TyChoose(vs, bodyExpr, _) -> unionFreeVars (accFreeTyvars opts boundTypars vs (freeInExpr opts bodyExpr)) acc - | Expr.Let _ -> - failwith "unreachable - linear expr" + | 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.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 + | 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 + // NON-BINDING CONSTRUCTS | Expr.Const _ -> acc - | Expr.Val (lvr, flags, _) -> - accFreeInValFlags opts flags (accFreeValRef opts lvr 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))) + | 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) + | 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.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.Link eref -> accFreeInExpr opts eref.Value acc - | Expr.Sequential (expr1, expr2, _, _) -> + | Expr.Sequential(expr1, expr2, _, _) -> let acc = accFreeInExpr opts expr1 acc // tail-call - linear expression - accFreeInExpr opts expr2 acc + accFreeInExpr opts expr2 acc - | Expr.StaticOptimization (_, expr2, expr3, _) -> - accFreeInExpr opts expr2 (accFreeInExpr opts expr3 acc) + | Expr.StaticOptimization(_, expr2, expr3, _) -> accFreeInExpr opts expr2 (accFreeInExpr opts expr3 acc) - | Expr.Match (_, _, dtree, targets, _, _) -> - match x with + | 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 + 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.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.WitnessArg(traitInfo, _) -> accFreeVarsInTraitInfo opts traitInfo acc - | Expr.DebugPoint (_, innerExpr) -> - accFreeInExpr opts innerExpr 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.Bytes _ + | TOp.UInt16s _ | TOp.TryWith _ - | TOp.TryFinally _ - | TOp.IntegerForLoop _ - | TOp.Coerce + | TOp.TryFinally _ + | TOp.IntegerForLoop _ + | TOp.Coerce | TOp.RefAddrGet _ - | TOp.Array + | TOp.Array | TOp.While _ - | TOp.Goto _ | TOp.Label _ | TOp.Return + | TOp.Goto _ + | TOp.Label _ + | TOp.Return | TOp.TupleFieldGet _ -> acc - | TOp.Tuple tupInfo -> - accFreeTyvars opts accFreeInTupInfo tupInfo 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 - | 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 + | 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.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.ValFieldGet fref + | TOp.ValFieldGetAddr(fref, _) + | TOp.ValFieldSet fref -> accFreeRecdFieldRef opts fref acc - | TOp.Recd (kind, tcref) -> + | 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 = + (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 +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) + | 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 accFreeInFlatExprs opts (exprs: Exprs) acc = + List.foldBack (accFreeInExpr opts) exprs acc -and accFreeInExprs opts (exprs: Exprs) acc = - match exprs with - | [] -> acc - | [h]-> +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 -> + | 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 = +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 +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 +// 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 +and accFreeInModuleOrNamespaceBind opts mbind acc = + match mbind with | ModuleOrNamespaceBinding.Binding bind -> accBindRhs opts bind acc - | ModuleOrNamespaceBinding.Module (_, def) -> accFreeInModuleOrNamespace opts def acc + | ModuleOrNamespaceBinding.Module(_, def) -> accFreeInModuleOrNamespace opts def acc -and accFreeInModuleOrNamespaces opts mexprs acc = +and accFreeInModuleOrNamespaces opts mexprs acc = List.foldBack (accFreeInModuleOrNamespace opts) mexprs acc -let freeInBindingRhs opts bind = - accBindRhs opts bind emptyFreeVars +let freeInBindingRhs opts bind = accBindRhs opts bind emptyFreeVars -let freeInModuleOrNamespace opts mdef = +let freeInModuleOrNamespace opts mdef = accFreeInModuleOrNamespace opts mdef emptyFreeVars //--------------------------------------------------------------------------- // 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 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') + (v :: vs', bodyExpr', bodyTy') | _ -> ([], expr, ty) -let rec stripLambdaN n expr = +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) + + 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 = +let tryStripLambdaN n expr = match expr with - | Expr.Lambda (_, None, None, _, _, _, _) -> + | Expr.Lambda(_, None, None, _, _, _, _) -> let argvsl, bodyExpr, remaining = stripLambdaN n expr - if remaining = 0 then Some (argvsl, bodyExpr) - else None + 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.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, _, _) -> +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 + (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 + | Expr.TyLambda(_, tps, b, _, _) -> tps, b | _ -> [], e + let vs, body = stripLambda_notypes taue tps, vs, body @@ -5711,29 +7050,61 @@ let InferValReprInfoOfExpr g allowTypeDirectedDetupling ty partialArgAttribsL re 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 = + (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 = attribs; OtherRange = None }: ArgReprInfo )) - - let retInfo: ArgReprInfo = { Attribs = 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 = + | 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 = attribs + OtherRange = None + } + : ArgReprInfo)) + + let retInfo: ArgReprInfo = + { + Attribs = 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 @@ -5741,19 +7112,21 @@ let InferValReprInfoOfBinding g allowTypeDirectedDetupling (v: Val) expr = //------------------------------------------------------------------------- // Check if constraints are satisfied that allow us to use more optimized // implementations -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let underlyingTypeOfEnumTy (g: TcGlobals) ty = - assert(isEnumTy g ty) - match metadataOfTy g ty with +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)) -> + | ILTypeMetadata(TILObjectReprData(_, _, tdef)) -> let info = computeILEnumInfo (tdef.Name, tdef.Fields) let ilTy = getTyOfILEnumInfo info - match ilTy.TypeSpec.Name with + + match ilTy.TypeSpec.Name with | "System.Byte" -> g.byte_ty | "System.SByte" -> g.sbyte_ty | "System.Int16" -> g.int16_ty @@ -5769,21 +7142,24 @@ let underlyingTypeOfEnumTy (g: TcGlobals) ty = | _ -> g.int32_ty | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> let tycon = (tcrefOfAppTy g ty).Deref - match tycon.GetFieldByName "value__" with + + match tycon.GetFieldByName "value__" with | Some rf -> rf.FormalType - | None -> error(InternalError("no 'value__' field found for enumeration type " + tycon.LogicalName, tycon.Range)) + | None -> error (InternalError("no 'value__' field found for enumeration type " + tycon.LogicalName, tycon.Range)) -// CLEANUP NOTE: Get rid of this mutation. -let ClearValReprInfo (f: Val) = - f.SetValReprInfo None; f +// CLEANUP NOTE: Get rid of this mutation. +let ClearValReprInfo (f: Val) = + f.SetValReprInfo None + f //-------------------------------------------------------------------------- // Resolve static optimization constraints //-------------------------------------------------------------------------- -let normalizeEnumTy g ty = (if isEnumTy g ty then underlyingTypeOfEnumTy g ty else ty) +let normalizeEnumTy g ty = + (if isEnumTy g ty then underlyingTypeOfEnumTy g ty else ty) -type StaticOptimizationAnswer = +type StaticOptimizationAnswer = | Yes = 1y | No = -1y | Unknown = 0y @@ -5795,11 +7171,11 @@ type StaticOptimizationAnswer = // These decide negatively if ^T is nominal and different to tycon. // // The "special" static optimization conditionals -// ^T : ^T -// 'T : 'T +// ^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 +// '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. @@ -5810,121 +7186,164 @@ type StaticOptimizationAnswer = // '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) -> +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 -> + | 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) -> + | 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 + 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 -> + | 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) = + 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) + else Expr.StaticOptimization(cs, e1, e2, m) //-------------------------------------------------------------------------- // Copy expressions, including new names for locally bound values. // Used to inline expressions. //-------------------------------------------------------------------------- -type ValCopyFlag = +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 +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') } + { 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 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 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 +let remapAttribKind tmenv k = + match k with | ILAttrib _ as x -> x | FSAttrib vref -> FSAttrib(remapValRef tmenv vref) -let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps = +let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps = let tps', tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tmenv tps - let tmenvinner = tyenvinner + let tmenvinner = tyenvinner tps', tmenvinner type RemapContext = - { g: TcGlobals - stackGuard: StackGuard } + { g: TcGlobals; stackGuard: StackGuard } -let rec remapAttribImpl ctxt tmenv (Attrib (tcref, kind, args, props, isGetOrSetAttr, targets, m)) = +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, + 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)) = +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 @@ -5932,7 +7351,11 @@ and remapPossibleForallTyImpl ctxt tmenv ty = remapTypeFull (remapAttribs ctxt tmenv) tmenv ty and remapArgData ctxt tmenv (argInfo: ArgReprInfo) : ArgReprInfo = - { Attribs = remapAttribs ctxt tmenv argInfo.Attribs; Name = argInfo.Name; OtherRange = argInfo.OtherRange } + { + Attribs = remapAttribs ctxt tmenv argInfo.Attribs + 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) @@ -5943,303 +7366,392 @@ and remapValData ctxt tmenv (d: ValData) = 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 memberInfoR = + d.MemberInfo + |> Option.map (remapMemberInfo ctxt d.val_range valReprInfo ty tyR tmenv) + let attribsR = d.Attribs |> remapAttribs ctxt tmenv - { d with + + { 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 = attribsR } - | None -> None } + Some + { dd with + val_declaring_entity = declaringEntityR + val_repr_info = reprInfoR + val_member_info = memberInfoR + val_attribs = attribsR + } + | None -> None + } and remapParentRef tyenv p = - match p with + match p with | ParentNone -> ParentNone - | Parent x -> Parent (x |> remapTyconRef tyenv.tyconRefRemap) + | Parent x -> Parent(x |> remapTyconRef tyenv.tyconRefRemap) -and mapImmediateValsAndTycons ft fv (x: ModuleOrNamespaceType) = +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 +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 + 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 = + +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 = +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 () -> + ctxt.stackGuard.Guard + <| fun () -> - match expr with + 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 - // 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) + 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 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) + 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 doData (typeDefs, argTypes, argExprs, res) = + (typeDefs, remapTypesAux tmenv argTypes, remapExprs ctxt compgen tmenv argExprs, res) + let data' = - match dataCell.Value with + 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 + | 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) + 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) + 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 + 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 + match expr with - | Expr.Let (bind, bodyExpr, m, _) -> + | 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 + | 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) -> + 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 + 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 + 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) -> +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) + + 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) + match x with + | PossibleConstrainedCall ty -> PossibleConstrainedCall(remapType tmenv ty) | _ -> x -and remapExprs ctxt compgen tmenv es = List.mapq (remapExprImpl ctxt compgen tmenv) es +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 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) -> + 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) + 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.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) + | TDSuccess(es, n) -> TDSuccess(remapFlatExprs ctxt compgen tmenv es, n) - | TDBind (bind, rest) -> + | TDBind(bind, rest) -> let bindR, tmenvinner = copyAndRemapAndBindBinding ctxt compgen tmenv bind - TDBind (bindR, remapDecisionTree ctxt compgen tmenvinner rest) - + 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 = +and copyAndRemapAndBindBindings ctxt compgen tmenv binds = let vsR, tmenvinner = copyAndRemapAndBindVals ctxt compgen tmenv (valsOfBinds binds) remapAndRenameBinds ctxt compgen tmenvinner binds vsR, tmenvinner @@ -6252,209 +7764,262 @@ and remapAndRenameBind ctxt compgen tmenvinner (TBind(_, repr, letSeqPtOpt)) vR 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 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 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 } + 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 + x.UnionCasesAsList + |> List.map (remapUnionCase ctxt tmenv) + |> Construct.MakeUnionCases -and remapFsObjData ctxt tmenv x = - { +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_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 } + fsobjmodel_rfields = x.fsobjmodel_rfields |> remapRecdFields ctxt tmenv + } -and remapTyconRepr ctxt tmenv repr = - match repr with - | TFSharpTyconRepr x -> TFSharpTyconRepr (remapFsObjData ctxt tmenv x) +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)) } + | 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)) } + | 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 + 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 + + 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 = +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 = +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 + 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 +and renameVal tmenv x = + match tmenv.valRemap.TryFind x with | Some v -> v.Deref | None -> x -and copyTycon compgen (tycon: Tycon) = - match compgen with +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 = +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. + + // 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. + // "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)) + 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 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)) + 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 -> + (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)) + + let tpsR, tmenvinner2 = + tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenvinner) tmenvinner (tcd.entity_typars.Force(tcd.entity_range)) + tcdR.entity_typars <- LazyWithContext.NotLazy tpsR tcdR.entity_attribs <- tcd.entity_attribs |> 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) + 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 } - | _ -> + | 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 + tyconsR, vsR, tmenvinner and allTyconsOfTycon (tycon: Tycon) = - seq { yield tycon - for nestedTycon in tycon.ModuleOrNamespaceType.AllEntities do - yield! allTyconsOfTycon nestedTycon } + 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 + 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 + | ModuleOrNamespaceBinding.Module(mspec, def) -> + yield mspec + yield! allEntitiesOfModDef def + | TMDefLet _ -> () + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allEntitiesOfModDef def } -and allValsOfModDef mdef = - seq { match mdef with - | TMDefRec(_, _, tycons, mbinds, _) -> - yield! abstractSlotValsOfTycons tycons - for mbind in mbinds do - match mbind with +and allValsOfModDef 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) -> yield! allValsOfModDef def - | TMDefLet(bind, _) -> - yield bind.Var - | TMDefDo _ -> () - | TMDefOpens _ -> () - | TMDefs defs -> - for def in defs do - yield! allValsOfModDef def + | TMDefLet(bind, _) -> yield bind.Var + | TMDefDo _ -> () + | TMDefOpens _ -> () + | TMDefs defs -> + for def in defs do + yield! allValsOfModDef def } and copyAndRemapModDef ctxt compgen tmenv mdef = @@ -6463,20 +8028,21 @@ and copyAndRemapModDef ctxt compgen tmenv mdef = 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 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) + 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. + 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) @@ -6491,13 +8057,13 @@ and remapAndRenameModDef ctxt compgen tmenv mdef = | TMDefOpens opens -> let opens = remapOpenDeclarations tmenv opens TMDefOpens opens - | TMDefs defs -> + | TMDefs defs -> let defs = remapAndRenameModDefs ctxt compgen tmenv defs TMDefs defs -and remapAndRenameModBind ctxt compgen tmenv x = - match x with - | ModuleOrNamespaceBinding.Binding bind -> +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 @@ -6506,41 +8072,81 @@ and remapAndRenameModBind ctxt compgen tmenv x = 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 +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) + + 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, "RemapExprStackGuardDepth") } +let remapAttrib g tmenv attrib = + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + remapAttribImpl ctxt tmenv attrib let remapExpr g (compgen: ValCopyFlag) (tmenv: Remap) expr = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + remapExprImpl ctxt compgen tmenv expr let remapPossibleForallTy g tmenv ty = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + remapPossibleForallTyImpl ctxt tmenv ty let copyModuleOrNamespaceType g compgen mtyp = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + copyAndRemapAndBindModTy ctxt compgen Remap.Empty mtyp |> fst let copyExpr g compgen e = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } - remapExprImpl ctxt compgen Remap.Empty e + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + + remapExprImpl ctxt compgen Remap.Empty e let copyImplFile g compgen e = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + remapImplFile ctxt compgen Remap.Empty e |> fst let instExpr g tpinst e = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + remapExprImpl ctxt CloneAll (mkInstRemap tpinst) e //-------------------------------------------------------------------------- @@ -6550,101 +8156,101 @@ let instExpr g tpinst e = 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.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.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.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.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.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)) - | 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.Val(x, valUseFlags, _) -> Expr.Val(x, valUseFlags, m) - | Expr.Quote (a, conv, isFromQueryExpression, _, ty) -> - Expr.Quote (remarkExpr m a, conv, isFromQueryExpression, m, ty) + | 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.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, _) -> + | 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) + 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 -> + 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.App(e1, e1ty, tyargs, args, _) -> Expr.App(remarkExpr m e1, e1ty, tyargs, remarkExprs m args, m) - | Expr.Sequential (e1, e2, dir, _) -> + | Expr.Sequential(e1, e2, dir, _) -> let e1R = remarkExpr m e1 let e2R = remarkExpr m e2 - Expr.Sequential (e1R, e2R, dir, m) + Expr.Sequential(e1R, e2R, dir, m) - | Expr.StaticOptimization (eqns, e2, e3, _) -> - Expr.StaticOptimization (eqns, remarkExpr m e2, remarkExpr m e3, 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.Const(c, _, ty) -> Expr.Const(c, m, ty) - | Expr.DebugPoint (_, innerExpr) -> - remarkExpr m innerExpr + | Expr.WitnessArg(witnessInfo, _) -> Expr.WitnessArg(witnessInfo, m) -and remarkObjExprMethod m (TObjExprMethod(slotsig, attribs, tps, vs, e, _)) = + | 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) = +and remarkInterfaceImpl m (ty, overrides) = (ty, List.map (remarkObjExprMethod m) overrides) -and remarkExprs m es = es |> List.map (remarkExpr m) +and remarkExprs m es = es |> List.map (remarkExpr m) and remarkDecisionTree m x = - match x with + 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 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) + | 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, _)) = +// 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) //-------------------------------------------------------------------------- @@ -6653,76 +8259,95 @@ and remarkBind m (TBind(v, repr, _)) = let isRecdOrStructFieldDefinitelyMutable (f: RecdField) = not f.IsStatic && f.IsMutable -let isUnionCaseDefinitelyMutable (uc: UnionCase) = uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldDefinitelyMutable +let isUnionCaseDefinitelyMutable (uc: UnionCase) = + uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldDefinitelyMutable + +let isUnionCaseRefDefinitelyMutable (uc: UnionCaseRef) = + uc.UnionCase |> isUnionCaseDefinitelyMutable -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 isRecdOrUnionOrStructTyconRefDefinitelyMutable (tcref: TyconRef) = let tycon = tcref.Deref - if tycon.IsUnionTycon then + + if tycon.IsUnionTycon then tycon.UnionCasesArray |> Array.exists isUnionCaseDefinitelyMutable - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + 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)) + +// 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 -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 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 +let ComputeFieldName tycon f = + if useGenuineField tycon f then + f.rfield_id.idText + else + CompilerGeneratedName f.rfield_id.idText //------------------------------------------------------------------------- // Helpers for building code contained in the initial environment -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let isQuotedExprTy g ty = match tryAppTy g ty with ValueSome (tcref, _) -> tyconRefEq g tcref g.expr_tcr | _ -> false +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 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 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 mkRawQuotedExprTy (g: TcGlobals) = + TType_app(g.raw_expr_tcr, [], g.knownWithoutNull) -let mkAnyTupledTy (g: TcGlobals) tupInfo tys = - match tys with - | [] -> g.unit_ty - | [h] -> h +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 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 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 mkArrayType (g: TcGlobals) ty = + TType_app(g.array_tcr_nice, [ ty ], g.knownWithoutNull) let mkByteArrayTy (g: TcGlobals) = mkArrayType g g.byte_ty @@ -6732,17 +8357,21 @@ let mkByteArrayTy (g: TcGlobals) = mkArrayType g g.byte_ty 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 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 retTy = + match traitInfo.ReturnType with + | None -> g.unit_ty + | Some ty -> ty + let argTysl = GenWitnessArgTys g traitInfo - mkMethodTy g argTysl retTy + mkMethodTy g argTysl retTy let GenWitnessTys (g: TcGlobals) (cxs: TraitWitnessInfos) = - if g.generateWitnesses then + if g.generateWitnesses then cxs |> List.map (GenWitnessTy g) else [] @@ -6750,59 +8379,91 @@ let GenWitnessTys (g: TcGlobals) (cxs: TraitWitnessInfos) = //-------------------------------------------------------------------------- // 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 + +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.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.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.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.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 -> + | 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) -> + | Expr.WitnessArg(traitInfo, _m) -> let witnessInfo = traitInfo.GetWitnessInfo() GenWitnessTy g witnessInfo @@ -6810,182 +8471,200 @@ let rec tyOfExpr g expr = // Make applications //--------------------------------------------------------------------------- -let primMkApp (f, fty) tyargs argsl m = - Expr.App (f, fty, tyargs, argsl, m) +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 +// 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) - (not (isFunTy g fty1) || - let rec loop fty xs = - match xs with - | [] -> false - | _ :: t -> not (isFunTy g fty) || loop (rangeOfFunTy g fty) t - loop fty1 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 + 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) - - | _ -> + 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)) + 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 - + 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 mkTyAppExpr m (f, fty) tyargs = + match tyargs with + | [] -> f + | _ -> primMkApp (f, fty) tyargs [] m //-------------------------------------------------------------------------- // Decision tree reduction //-------------------------------------------------------------------------- let rec accTargetsOfDecisionTree tree acc = - match tree with - | TDSwitch (_, cases, dflt, _) -> - List.foldBack (fun (c: DecisionTreeCase) -> accTargetsOfDecisionTree c.CaseTree) cases + 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 + | 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) + 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) + 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) +and mapTargetsOfDecisionTreeCase f (TCase(x, t)) = TCase(x, mapTargetsOfDecisionTree f t) -// Dead target elimination -let eliminateDeadTargetsFromMatch tree (targets:_[]) = +// 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 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]) + + 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 + else tree, targets - + let rec targetOfSuccessDecisionTree tree = - match tree with + match tree with | TDSwitch _ -> None - | TDSuccess (_, i) -> Some i + | 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 + 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) + | 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". +// 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 + // 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 + 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 + + 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 + | 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] + 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 + 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) -> + | _ -> + 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) + TDSwitch(e, casesR, dfltR, m) | TDSuccess _ -> tree | TDBind _ -> tree - and rebuildDecisionTreeEdge (TCase(x, t)) = - TCase(x, rebuildDecisionTree t) + 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) -> + 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. @@ -6994,73 +8673,90 @@ let foldLinearBindingTargetsOfMatch tree (targets: _[]) = 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 ) - + 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" +// 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) + + 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 + 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 = + | _ -> 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 - | _ -> + + 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 //------------------------------------------------------------------------- // mkExprAddrOfExprAux -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- + +type Mutates = + | AddressOfOp + | DefinitelyMutates + | PossiblyMutates + | NeverMutates -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 + (tcref.CanDeref && not (isRecdOrUnionOrStructTyconRefDefinitelyMutable tcref)) + || tyconRefEq g tcref g.decimal_tcr + || tyconRefEq g tcref g.date_tcr let isTyconRefReadOnly g m (tcref: TyconRef) = - tcref.CanDeref && - if - match tcref.TryIsReadOnly with - | ValueSome res -> res - | _ -> - let res = TyconRefHasAttribute g m g.attrib_IsReadOnlyAttribute tcref - tcref.SetIsReadOnly res - res - then true - else tcref.IsEnumTycon + tcref.CanDeref + && if + match tcref.TryIsReadOnly with + | ValueSome res -> res + | _ -> + let res = TyconRefHasAttribute g m g.attrib_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 + 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 @@ -7072,7 +8768,7 @@ let isRecdOrStructTyconRefReadOnly g m tcref = isRecdOrStructTyconRefReadOnlyAux g m false tcref let isRecdOrStructTyReadOnlyAux (g: TcGlobals) m isInref ty = - match tryTcrefOfAppTy g ty with + match tryTcrefOfAppTy g ty with | ValueNone -> false | ValueSome tcref -> isRecdOrStructTyconRefReadOnlyAux g m isInref tcref @@ -7080,8 +8776,8 @@ let isRecdOrStructTyReadOnly g m ty = isRecdOrStructTyReadOnlyAux g m false ty let CanTakeAddressOf g m isInref ty mut = - match mut with - | NeverMutates -> true + 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 @@ -7093,67 +8789,70 @@ let CanTakeAddressOf g m isInref ty mut = // // 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 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 +// 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 && + // 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". + // 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 && +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) = +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 CanTakeAddressOfByrefGet (g: TcGlobals) (vref: ValRef) mut = + isInByrefTy g vref.Type + && CanTakeAddressOf g vref.Range true (destByrefTy g vref.Type) mut -let MustTakeAddressOfRecdField (rfref: RecdField) = +let MustTakeAddressOfRecdField (rfref: RecdField) = // Static mutable fields must be private, hence we don't have to take their address - not rfref.IsStatic && - rfref.IsMutable + not rfref.IsStatic && rfref.IsMutable -let MustTakeAddressOfRecdFieldRef (rfref: RecdFieldRef) = MustTakeAddressOfRecdField rfref.RecdField +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 + 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 - not rfref.IsMutable && - CanTakeAddressOf g m false (actualTyOfUnionFieldRef uref cidx tinst) mut + 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 +/// 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 = + if mustTakeAddress then + let isNativePtr = match addrExprVal with | Some vf -> valRefEq g vf g.addrof2_vref | _ -> false @@ -7161,131 +8860,174 @@ let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress // 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)) + error (Error(FSComp.SR.tastValueMustBeMutable (), m)) - match expr with + 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 -> + | 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 -> + | 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 -> + // 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 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 + 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 -> + // 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 + 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 -> + // 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 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 + 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) -> + // 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 + 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) -> + // 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 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 + 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) -> - // 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 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 + + 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) -> + | 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)) + | 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)) + | 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)) - + | 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)) - - | _ -> + | Expr.Val _ when mut = DefinitelyMutates -> error (Error(FSComp.SR.tastValueMustBeMutable (), m)) + + | _ -> let ty = tyOfExpr g expr - if isStructTy g ty then - match mut with + + if isStructTy g ty then + match mut with | NeverMutates | AddressOfOp -> () - | DefinitelyMutates -> + | DefinitelyMutates -> // Give a nice error message for mutating something we can't take the address of - errorR(Error(FSComp.SR.tastInvalidMutationOfConstant(), m)) - | PossiblyMutates -> + 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)) + warning (DefensiveCopyWarning(FSComp.SR.tastValueHasBeenCopied (), m)) match mut with | NeverMutates | DefinitelyMutates | PossiblyMutates -> () - | AddressOfOp -> + | AddressOfOp -> // we get an inref - errorR(Error(FSComp.SR.tastCantTakeAddressOfExpression(), m)) + errorR (Error(FSComp.SR.tastCantTakeAddressOfExpression (), m)) // Take a defensive copy - let tmp, _ = - match mut with + let tmp, _ = + match mut with | NeverMutates -> mkCompGenLocal m WellKnownNames.CopyOfStruct ty | _ -> mkMutableCompGenLocal m WellKnownNames.CopyOfStruct ty @@ -7294,131 +9036,177 @@ let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress let readonly = true let writeonly = false - Some (tmp, expr), (mkValAddr m readonly (mkLocalValRef tmp)), readonly, writeonly + 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 + 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 + | 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 mkTupleFieldGet g (tupInfo, e, tinst, i, m) = + let wrap, eR, _readonly, _writeonly = + mkExprAddrOfExpr g (evalTupInfoIsStruct tupInfo) false NeverMutates e None 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)) + wrap (mkTupleFieldGetViaExprAddr (tupInfo, eR, tinst, i, m)) -let mkRecdFieldGet g (e, fref: RecdFieldRef, tinst, 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 + + 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) = +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 + + let wrap, eR, _readonly, _writeonly = + mkExprAddrOfExpr g cref.Tycon.IsStructOrEnumTycon false NeverMutates e None m + wrap (mkUnionCaseFieldGetUnprovenViaExprAddr (eR, cref, tinst, j, m)) -let mkArray (argTy, args, m) = Expr.Op (TOp.Array, [argTy], args, m) +let mkArray (argTy, args, m) = Expr.Op(TOp.Array, [ argTy ], args, m) //--------------------------------------------------------------------------- // 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 +// 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. +// [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 rec IterateRecursiveFixups g (selfv: Val option) rvs (access: Expr, set) exprToFix = let exprToFix = stripExpr exprToFix - match exprToFix with + + 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.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 + | 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 -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 +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) } + { + 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 @@ -7427,92 +9215,86 @@ let ExprFolder0 = /// 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>) = +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, "FoldExprStackGuardDepth") - let rec exprsF z xs = - List.fold exprFClosure z xs + 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 + stackGuard.Guard + <| fun () -> folders.exprIntercept exprFClosure exprNoInterceptFClosure z x - and exprNoInterceptF (z: 'State) (x: Expr) = + and exprNoInterceptF (z: 'State) (x: Expr) = match x with - + | Expr.Const _ -> z | Expr.Val _ -> z - | LinearOpExpr (_op, _tyargs, argsHead, argLast, _m) -> + | LinearOpExpr(_op, _tyargs, argsHead, argLast, _m) -> let z = exprsF z argsHead - // tailcall + // tailcall exprF z argLast - - | Expr.Op (_c, _tyargs, args, _) -> - exprsF z args - | Expr.Sequential (x0, x1, _dir, _) -> + | 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.Lambda(_lambdaId, _ctorThisValOpt, _baseValOpt, _argvs, body, _m, _rty) -> exprF z body - | Expr.TyLambda (_lambdaId, _tps, body, _m, _rty) -> - exprF z body + | Expr.TyLambda(_lambdaId, _tps, body, _m, _rty) -> exprF z body - | Expr.TyChoose (_, body, _) -> - exprF z body + | Expr.TyChoose(_, body, _) -> exprF z body - | Expr.App (f, _fty, _tys, argTys, _) -> + | Expr.App(f, _fty, _tys, argTys, _) -> let z = exprF z f exprsF z argTys - - | Expr.LetRec (binds, body, _, _) -> + + | Expr.LetRec(binds, body, _, _) -> let z = valBindsF false z binds exprF z body - - | Expr.Let (bind, 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.DebugPoint(_, innerExpr) -> exprF z innerExpr - | Expr.Match (_spBind, _exprm, dtree, targets, _m, _ty) -> + | Expr.Match(_spBind, _exprm, dtree, targets, _m, _ty) -> let z = dtreeF z dtree - let z = Array.fold targetF z targets[0..targets.Length - 2] + let z = Array.fold targetF z targets[0 .. targets.Length - 2] // tailcall targetF z targets[targets.Length - 1] - - | Expr.Quote (e, dataCell, _, _, _) -> + + | Expr.Quote(e, dataCell, _, _, _) -> let z = exprF z e - match dataCell.Value with + + match dataCell.Value with | None -> z - | Some ((_typeDefs, _argTypes, argExprs, _), _) -> exprsF z argExprs + | Some((_typeDefs, _argTypes, argExprs, _), _) -> exprsF z argExprs - | Expr.Obj (_n, _typ, _basev, basecall, overrides, iimpls, _m) -> + | 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.StaticOptimization(_tcs, csx, x, _) -> exprsF z [ csx; x ] - | Expr.WitnessArg (_witnessInfo, _m) -> - z + | Expr.WitnessArg(_witnessInfo, _m) -> z and valBindF dtree z bind = let z = folders.nonRecBindingsIntercept z bind - bindF dtree z bind + bindF dtree z bind and valBindsF dtree z binds = let z = folders.recBindingsIntercept z binds - List.fold (bindF dtree) z binds + List.fold (bindF dtree) z binds and bindF dtree z (bind: Binding) = let z = folders.valBindingSiteIntercept z (dtree, bind.Var) @@ -7520,52 +9302,53 @@ type ExprFolders<'State> (folders: ExprFolder<'State>) = and dtreeF z dtree = let z = folders.dtreeIntercept z dtree + match dtree with - | TDBind (bind, rest) -> + | TDBind(bind, rest) -> let z = valBindF true z bind dtreeF z rest - | TDSuccess (args, _) -> exprsF z args - | TDSwitch (test, dcases, dflt, _) -> + | 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 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 + 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 + 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 = + and mdefF z x = match x with - | TMDefRec(_, _, _, mbinds, _) -> + | 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 + | TMDefs defs -> List.fold mdefF z defs - and mbindF z x = - match x with + 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 + 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 @@ -7574,9 +9357,11 @@ type ExprFolders<'State> (folders: ExprFolder<'State>) = member x.FoldImplFile = implF -let FoldExpr folders state expr = ExprFolders(folders).FoldExpr state expr +let FoldExpr folders state expr = + ExprFolders(folders).FoldExpr state expr -let FoldImplFile folders state implFile = ExprFolders(folders).FoldImplFile state implFile +let FoldImplFile folders state implFile = + ExprFolders(folders).FoldImplFile state implFile #if DEBUG //------------------------------------------------------------------------- @@ -7584,25 +9369,36 @@ let FoldImplFile folders state implFile = ExprFolders(folders).FoldImplFile stat //------------------------------------------------------------------------- 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" + 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 - + //------------------------------------------------------------------------- // Make expressions -//------------------------------------------------------------------------- +//------------------------------------------------------------------------- -let mkString (g: TcGlobals) m n = Expr.Const (Const.String n, m, g.string_ty) +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 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 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 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 mkInt32 (g: TcGlobals) m n = + Expr.Const(Const.Int32 n, m, g.int32_ty) let mkInt g m n = mkInt32 g m n @@ -7615,134 +9411,181 @@ 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)) + 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 destInt32 = function Expr.Const (Const.Int32 n, _, _) -> Some n | _ -> None + 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 destInt32 = + function + | Expr.Const(Const.Int32 n, _, _) -> Some n + | _ -> None 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 +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" + else + failwith "destIDelegateEventType: not an IDelegateEvent type" -let mkIEventType (g: TcGlobals) ty1 ty2 = TType_app (g.fslib_IEvent2_tcr, [ty1;ty2], 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 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 mkIObserverType (g: TcGlobals) ty1 = + TType_app(g.tcref_IObserver, [ ty1 ], g.knownWithoutNull) -let mkRefCellContentsRef (g: TcGlobals) = mkRecdFieldRef g.refcell_tcr_canon "contents" +let mkRefCellContentsRef (g: TcGlobals) = + mkRecdFieldRef g.refcell_tcr_canon "contents" -let mkSequential m e1 e2 = Expr.Sequential (e1, e2, NormalSeq, m) +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 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) +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) +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 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 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) +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 + + 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 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 + +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 +// 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 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 ] + let lifted = + [ + for i in 0 .. sigma.Length - 1 do + let iR = sigma[i] - if lifted.IsEmpty then 0 else List.max lifted + 1 + 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 liftLim = liftAllBefore sigma let rewrite rbinds (i, expri: Expr) = if i < liftLim then @@ -7751,471 +9594,660 @@ let permuteExprList (sigma: int[]) (exprs: Expr list) (ty: TType list) (names: s 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 + +/// 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 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) + + 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) + + 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 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) - + + 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) + + 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 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 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 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 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 mkCons (g: TcGlobals) ty h t = + mkUnionCaseExpr (g.cons_ucref, [ ty ], [ h; t ], unionRanges h.Range t.Range) -let mkCompGenLocalAndInvisibleBind g nm m e = +let mkCompGenLocalAndInvisibleBind g nm m e = let locv, loce = mkCompGenLocal m nm (tyOfExpr g e) - locv, loce, mkInvisibleBind locv e + locv, loce, mkInvisibleBind locv e //---------------------------------------------------------------------------- // Make some fragments of code //---------------------------------------------------------------------------- -let box = I_box (mkILTyvarTy 0us) +let box = I_box(mkILTyvarTy 0us) -let isinst = I_isinst (mkILTyvarTy 0us) +let isinst = I_isinst(mkILTyvarTy 0us) -let unbox = I_unbox_any (mkILTyvarTy 0us) +let unbox = I_unbox_any(mkILTyvarTy 0us) -let mkUnbox ty e m = mkAsmExpr ([ unbox ], [ty], [e], [ ty ], m) +let mkUnbox ty e m = + mkAsmExpr ([ unbox ], [ ty ], [ e ], [ ty ], m) -let mkBox ty e m = mkAsmExpr ([box], [], [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 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_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_Length (g: TcGlobals) = + mkILNonGenericInstanceMethSpecInTy (g.ilg.typ_String, "get_Length", [], g.ilg.typ_Int32) -let mspec_String_Concat2 (g: TcGlobals) = +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_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_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) = +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 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 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 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 -let mkCallGetGenericComparer (g: TcGlobals) m = typedExprForIntrinsic g m g.get_generic_comparer_info |> fst +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 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 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 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 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 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 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 mkCallTypeDefOf (g: TcGlobals) m ty = + mkApps g (typedExprForIntrinsic g m g.typedefof_info, [ [ ty ] ], [], m) -let mkCallSeq (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.seq_info, [[ty]], [ e1 ], m) +let mkCallDispose (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.dispose_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 mkCallSeq (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.seq_info, [ [ ty ] ], [ e1 ], 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 mkCallCreateInstance (g: TcGlobals) m ty = + mkApps g (typedExprForIntrinsic g m g.create_instance_info, [ [ ty ] ], [ 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 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 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 mkCallNewQuerySource (g: TcGlobals) m ty1 ty2 e1 = + mkApps g (typedExprForIntrinsic g m g.new_query_source_info, [ [ ty1; ty2 ] ], [ e1 ], 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 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 mkCallGenericEqualityEROuter (g: TcGlobals) m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.generic_equality_er_outer_info, [[ty]], [ e1;e2 ], 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 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 mkCallGenericEqualityEROuter (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.generic_equality_er_outer_info, [ [ ty ] ], [ 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 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 mkCallEqualsOperator (g: TcGlobals) m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.equals_operator_info, [[ty]], [ 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 mkCallNotEqualsOperator (g: TcGlobals) m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.not_equals_operator, [[ty]], [ e1;e2 ], m) +let mkCallEqualsOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.equals_operator_info, [ [ 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 mkCallNotEqualsOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.not_equals_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 mkCallLessThanOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.less_than_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 mkCallLessThanOrEqualsOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.less_than_or_equals_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 mkCallGreaterThanOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.greater_than_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 mkCallGreaterThanOrEqualsOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.greater_than_or_equals_operator, [ [ 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 mkCallAdditionOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.unchecked_addition_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 mkCallSubtractionOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.unchecked_subtraction_info, [ [ ty; ty; ty ] ], [ 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 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 mkCallModulusOperator (g: TcGlobals) m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.unchecked_modulus_info, [[ty; ty; ty]], [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 mkCallDefaultOf (g: TcGlobals) m ty = mkApps g (typedExprForIntrinsic g m g.unchecked_defaultof_info, [[ty]], [], 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 mkCallBitwiseAndOperator (g: TcGlobals) m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.bitwise_and_info, [[ty]], [e1;e2], m) +let mkCallDefaultOf (g: TcGlobals) m ty = + mkApps g (typedExprForIntrinsic g m g.unchecked_defaultof_info, [ [ ty ] ], [], m) -let mkCallBitwiseOrOperator (g: TcGlobals) m ty e1 e2 = mkApps g (typedExprForIntrinsic g m g.bitwise_or_info, [[ty]], [e1;e2], m) +let mkCallBitwiseAndOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.bitwise_and_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 mkCallBitwiseOrOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.bitwise_or_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 mkCallBitwiseXorOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.bitwise_xor_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 mkCallShiftLeftOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.bitwise_shift_left_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 mkCallShiftRightOperator (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.bitwise_shift_right_info, [ [ ty ] ], [ e1; e2 ], m) -let mkCallUnaryNotOperator (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.bitwise_unary_not_info, [[ty]], [e1], m) +let mkCallUnaryNegOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.unchecked_unary_minus_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 mkCallUnaryNotOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.bitwise_unary_not_info, [ [ ty ] ], [ e1 ], 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 mkCallAdditionChecked (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.checked_addition_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 mkCallSubtractionChecked (g: TcGlobals) m ty e1 e2 = + mkApps g (typedExprForIntrinsic g m g.checked_subtraction_info, [ [ ty; ty; ty ] ], [ e1; e2 ], m) -let mkCallUnaryNegChecked (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.checked_unary_minus_info, [[ty]], [e1], 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 mkCallToByteChecked (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.byte_checked_info, [[ty]], [e1], m) +let mkCallUnaryNegChecked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.checked_unary_minus_info, [ [ ty ] ], [ e1 ], m) -let mkCallToSByteChecked (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.sbyte_checked_info, [[ty]], [e1], m) +let mkCallToByteChecked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.byte_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 mkCallToSByteChecked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.sbyte_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 mkCallToInt16Checked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int16_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 mkCallToUInt16Checked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.uint16_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 mkCallToIntChecked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int_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 mkCallToInt32Checked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int32_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 mkCallToUInt32Checked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.uint32_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 mkCallToInt64Checked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int64_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 mkCallToUInt64Checked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.uint64_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 mkCallToIntPtrChecked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.nativeint_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 mkCallToUIntPtrChecked (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.unativeint_checked_info, [ [ ty ] ], [ e1 ], m) -let mkCallToSByteOperator (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.sbyte_operator_info, [[ty]], [e1], m) +let mkCallToByteOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.byte_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 mkCallToSByteOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.sbyte_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 mkCallToInt16Operator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int16_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 mkCallToUInt16Operator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.uint16_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 mkCallToInt32Operator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int32_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 mkCallToUInt32Operator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.uint32_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 mkCallToInt64Operator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.int64_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 mkCallToUInt64Operator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.uint64_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 mkCallToSingleOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.float32_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 mkCallToDoubleOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.float_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 mkCallToIntPtrOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.nativeint_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 mkCallToUIntPtrOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.unativeint_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 mkCallToCharOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.char_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 mkCallToEnumOperator (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.enum_operator_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 mkCallArrayLength (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.array_length_info, [ [ ty ] ], [ e1 ], 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 mkCallArrayGet (g: TcGlobals) m ty e1 idx1 = + mkApps g (typedExprForIntrinsic g m g.array_get_info, [ [ ty ] ], [ e1; idx1 ], 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 mkCallArray2DGet (g: TcGlobals) m ty e1 idx1 idx2 = + mkApps g (typedExprForIntrinsic g m g.array2D_get_info, [ [ ty ] ], [ e1; idx1; idx2 ], 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 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 mkCallArraySet (g: TcGlobals) m ty e1 idx1 v = mkApps g (typedExprForIntrinsic g m g.array_set_info, [[ty]], [ e1 ; idx1; v ], 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 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 mkCallArraySet (g: TcGlobals) m ty e1 idx1 v = + mkApps g (typedExprForIntrinsic g m g.array_set_info, [ [ ty ] ], [ e1; idx1; 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 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 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 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 mkCallHash (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.hash_info, [[ty]], [ e1 ], 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 mkCallBox (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.box_info, [[ty]], [ e1 ], m) +let mkCallHash (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.hash_info, [ [ ty ] ], [ e1 ], m) -let mkCallIsNull (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.isnull_info, [[ty]], [ e1 ], m) +let mkCallBox (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.box_info, [ [ ty ] ], [ e1 ], m) -let mkCallRaise (g: TcGlobals) m ty e1 = mkApps g (typedExprForIntrinsic g m g.raise_info, [[ty]], [ e1 ], m) +let mkCallIsNull (g: TcGlobals) m ty e1 = + mkApps g (typedExprForIntrinsic g m g.isnull_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 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) + 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 -> + | ValueSome v -> let f = exprForValRef m vref - mkApps g ((f, v.Type), [tinst], argExprs, m) |> Some - | ValueNone -> - None + 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 -> + | 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 System.Decimal.GetBits d with - | [| lo;med;hi; signExp |] -> + mkApps g ((f, v.Type), [ tyargs ], argExprs, m) |> Some + | ValueNone -> None + +let TryEliminateDesugaredConstants g m c = + match c with + | Const.Decimal d -> + match System.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) ) + 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 + | _ -> None -let mkSeqTy (g: TcGlobals) ty = mkWoNullAppTy g.seq_tcr [ty] - -let mkIEnumeratorTy (g: TcGlobals) ty = mkWoNullAppTy g.tcref_System_Collections_Generic_IEnumerator [ty] - -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 mkSeqTy (g: TcGlobals) ty = mkWoNullAppTy g.seq_tcr [ ty ] + +let mkIEnumeratorTy (g: TcGlobals) ty = + mkWoNullAppTy g.tcref_System_Collections_Generic_IEnumerator [ ty ] + +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 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 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 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 +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 + 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 = +let mkCallLiftValueWithDefn g m qty e1 = assert isQuotedExprTy g qty let ty = destQuotedExprTy g qty - let vref = ValRefForIntrinsic g.lift_value_with_defn_info + 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 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 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 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 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 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 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 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 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 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 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) + + 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) + + 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) + + 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) + + 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) + + 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. +// 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) +// 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) +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) +// +// 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) +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 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) +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 mkNull m ty = Expr.Const(Const.Zero, m, ty) -let mkThrow m ty e = mkAsmExpr ([ I_throw ], [], [e], [ty], m) +let mkThrow m ty e = + mkAsmExpr ([ I_throw ], [], [ e ], [ ty ], m) -let destThrow = function - | Expr.Op (TOp.ILAsm ([I_throw], [ty2]), [], [e], m) -> Some (m, ty2, e) +let destThrow = + function + | Expr.Op(TOp.ILAsm([ I_throw ], [ ty2 ]), [], [ e ], m) -> Some(m, ty2, e) | _ -> None let isThrow x = Option.isSome (destThrow x) @@ -8223,51 +10255,74 @@ let isThrow x = Option.isSome (destThrow x) // 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) + Expr.App(ve, vt, [ ty ], [ mkUnit g m ], m) -let mkReraise m returnTy = Expr.Op (TOp.Reraise, [returnTy], [], m) (* could suppress unitArg *) +let mkReraise m returnTy = + Expr.Op(TOp.Reraise, [ returnTy ], [], m) (* could suppress unitArg *) //---------------------------------------------------------------------------- // CompilationMappingAttribute, SourceConstructFlags //---------------------------------------------------------------------------- -let tnameCompilationSourceNameAttr = FSharpLib.Core + ".CompilationSourceNameAttribute" -let tnameCompilationArgumentCountsAttr = FSharpLib.Core + ".CompilationArgumentCountsAttribute" +let tnameCompilationSourceNameAttr = + FSharpLib.Core + ".CompilationSourceNameAttribute" + +let tnameCompilationArgumentCountsAttr = + FSharpLib.Core + ".CompilationArgumentCountsAttribute" + let tnameCompilationMappingAttr = FSharpLib.Core + ".CompilationMappingAttribute" let tnameSourceConstructFlags = FSharpLib.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 tref_CompilationArgumentCountsAttr (g: TcGlobals) = + mkILTyRef (g.fslibCcu.ILScopeRef, tnameCompilationArgumentCountsAttr) -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 tref_CompilationMappingAttr (g: TcGlobals) = + mkILTyRef (g.fslibCcu.ILScopeRef, tnameCompilationMappingAttr) -let mkCompilationMappingAttr g kind = mkCompilationMappingAttrPrim g kind [] +let tref_CompilationSourceNameAttr (g: TcGlobals) = + mkILTyRef (g.fslibCcu.ILScopeRef, tnameCompilationSourceNameAttr) + +let tref_SourceConstructFlags (g: TcGlobals) = + mkILTyRef (g.fslibCcu.ILScopeRef, tnameSourceConstructFlags) -let mkCompilationMappingAttrWithSeqNum g kind seqNum = mkCompilationMappingAttrPrim g kind [seqNum] +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 mkCompilationMappingAttrWithVariantNumAndSeqNum g kind varNum seqNum = mkCompilationMappingAttrPrim g kind [varNum;seqNum] +let mkCompilationMappingAttrWithSeqNum g kind seqNum = + mkCompilationMappingAttrPrim g kind [ 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 mkCompilationMappingAttrWithVariantNumAndSeqNum g kind varNum seqNum = + mkCompilationMappingAttrPrim g kind [ varNum; seqNum ] -let mkCompilationSourceNameAttr (g: TcGlobals) n = - mkILCustomAttribute (tref_CompilationSourceNameAttr g, [ g.ilg.typ_String ], - [ILAttribElem.String(Some n)], - []) +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 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) ]) ], - []) +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 @@ -8275,14 +10330,15 @@ let mkCompilationMappingAttrForQuotationResource (g: TcGlobals) (nm, tys: ILType #if !NO_TYPEPROVIDERS -let isTypeProviderAssemblyAttr (cattr: ILAttribute) = - cattr.Method.DeclaringType.BasicQualifiedName = !! typeof.FullName +let isTypeProviderAssemblyAttr (cattr: ILAttribute) = + cattr.Method.DeclaringType.BasicQualifiedName = !!typeof.FullName + +let TryDecodeTypeProviderAssemblyAttr (cattr: ILAttribute) : string MaybeNull option = + if isTypeProviderAssemblyAttr cattr then + let params_, _args = decodeILAttribData cattr -let TryDecodeTypeProviderAssemblyAttr (cattr: ILAttribute) : string MaybeNull 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(Some assemblyName) :: _ -> Some assemblyName | ILAttribElem.String None :: _ -> Some null | [] -> Some null | _ -> None @@ -8295,52 +10351,61 @@ let TryDecodeTypeProviderAssemblyAttr (cattr: ILAttribute) : string MaybeNull op // FSharpInterfaceDataVersionAttribute //---------------------------------------------------------------------------- -let tname_SignatureDataVersionAttr = FSharpLib.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 tname_SignatureDataVersionAttr = + FSharpLib.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 tname_AutoOpenAttr = FSharpLib.Core + ".AutoOpenAttribute" -let IsSignatureDataVersionAttr cattr = isILAttribByName ([], tname_SignatureDataVersionAttr) cattr +let IsSignatureDataVersionAttr cattr = + isILAttribByName ([], tname_SignatureDataVersionAttr) cattr -let TryFindAutoOpenAttr cattr = - if isILAttribByName ([], tname_AutoOpenAttr) cattr then - match decodeILAttribData cattr with - | [ILAttribElem.String s], _ -> s +let TryFindAutoOpenAttr cattr = + if isILAttribByName ([], tname_AutoOpenAttr) cattr then + match decodeILAttribData cattr with + | [ ILAttribElem.String s ], _ -> s | [], _ -> None - | _ -> - warning(Failure(FSComp.SR.tastUnexpectedDecodeOfAutoOpenAttribute())) + | _ -> + warning (Failure(FSComp.SR.tastUnexpectedDecodeOfAutoOpenAttribute ())) None else None - -let TryFindInternalsVisibleToAttr cattr = - if isILAttribByName ([], tname_InternalsVisibleToAttribute) cattr then - match decodeILAttribData cattr with - | [ILAttribElem.String s], _ -> s + +let TryFindInternalsVisibleToAttr cattr = + if isILAttribByName ([], tname_InternalsVisibleToAttribute) cattr then + match decodeILAttribData cattr with + | [ ILAttribElem.String s ], _ -> s | [], _ -> None - | _ -> - warning(Failure(FSComp.SR.tastUnexpectedDecodeOfInternalsVisibleToAttribute())) + | _ -> + 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 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 //-------------------------------------------------------------------------- // tupled lambda --> method/function with a given valReprInfo specification. @@ -8354,183 +10419,204 @@ 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 + + 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 = + 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 + + 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 + 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 + + 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 + else let tupledv, untupler = untupledToRefTupled g vs - [tupledv], untupler body + [ tupledv ], untupler body -let MultiLambdaToTupledLambda g vs body = - match vs with +let MultiLambdaToTupledLambda g vs body = + match vs with | [] -> failwith "MultiLambdaToTupledLambda: expected some arguments" - | [v] -> v, body - | vs -> + | [ v ] -> v, body + | vs -> let tupledv, untupler = untupledToRefTupled g vs - tupledv, untupler body + tupledv, untupler body [] -let (|RefTuple|_|) expr = +let (|RefTuple|_|) expr = match expr with - | Expr.Op (TOp.Tuple (TupInfo.Const false), _, args, _) -> ValueSome args + | Expr.Op(TOp.Tuple(TupInfo.Const false), _, args, _) -> ValueSome args | _ -> ValueNone -let MultiLambdaToTupledLambdaIfNeeded g (vs, arg) body = - match vs, arg with +let MultiLambdaToTupledLambdaIfNeeded g (vs, arg) body = + match vs, arg with | [], _ -> failwith "MultiLambdaToTupledLambda: expected some arguments" - | [v], _ -> [(v, arg)], body + | [ v ], _ -> [ (v, arg) ], body | vs, RefTuple args when args.Length = vs.Length -> List.zip vs args, body - | vs, _ -> + | vs, _ -> let tupledv, untupler = untupledToRefTupled g vs - [(tupledv, arg)], untupler body + [ (tupledv, arg) ], untupler body //-------------------------------------------------------------------------- -// Beta reduction via let-bindings. Reduce immediate apps. of lambdas to let bindings. +// 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) + 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))) + | 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) + | 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) + | 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) + | 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) + | 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, _) -> + 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) - + 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 m argTysl tpenv = - argTysl |> List.mapi (fun i argTys -> - argTys |> List.mapi (fun j (argTy, argInfo: ArgReprInfo) -> + 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 + + 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 = @@ -8541,50 +10627,47 @@ let AdjustValForExpectedValReprInfo g m (vref: ValRef) flags valReprInfo = 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... + + 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 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 + 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 + if typeEquiv g tgtTy srcTy then expr - else - mkCoerceExpr(expr, tgtTy, expr.Range, srcTy) + else + mkCoerceExpr (expr, tgtTy, expr.Range, srcTy) -let mkCompGenLetIn m nm ty e f = +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 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 +/// 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 +/// return /// (fun b1 b2 -> E (b1 :> A) (b2 :> A)) /// /// - Use good names for the closure arguments if available @@ -8595,56 +10678,58 @@ let mkCompGenLetMutableIn m nm ty e f = /// 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 +/// 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 = +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 + 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)) - + 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, + // 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 + // 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 + + 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 = @@ -8652,21 +10737,20 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex /// 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 + 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) + /// 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, + // 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 + // 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, + /// 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) @@ -8675,224 +10759,242 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex 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, + /// 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, + + 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 - + 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 + + 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 + // 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 = + + let expr = match actualTys, argTys with - | [actualTy], [argTy] -> mkCoerceIfNeeded g actualTy argTy ve + | [ 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 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 - - 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) + // In this case there is a tuple mismatch. + // f p + // // - // for + // 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. + // 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] + 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 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 = + + 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) + 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, + 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 + 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 + 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) + 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 + // 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 + // 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 + 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) + 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 = + | _ -> 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) - - + 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 +// 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, +// 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) +// 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.SetValReprInfo(Some valData) tmp.SetDeclaringEntity parent tmp.SetIsMemberOrModuleBinding() @@ -8904,175 +11006,209 @@ let AdjustValToHaveValReprInfo (tmp: Val) parent valData = /// and vN = #N tmp /// rhs /// Motivation: -/// - For top-level let bindings with possibly failing matches, +/// - 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 + 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 + | [ _ ] -> 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 (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 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 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)) + // 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) + + 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 - +let LinearizeTopMatch g parent = + function + | Expr.Match(spBind, m, tree, targets, m2, ty) -> LinearizeTopMatchAux g parent (spBind, m, tree, targets, m2, ty) + | x -> x //--------------------------------------------------------------------------- // XmlDoc signatures //--------------------------------------------------------------------------- let commaEncs strs = String.concat "," strs -let angleEnc str = "{" + str + "}" +let angleEnc str = "{" + str + "}" + let ticksAndArgCountTextOfTyconRef (tcref: TyconRef) = - // Generic type names are (name + "`" + digits) where name does not contain "`". - let path = Array.toList (fullMangledPathToTyconRef tcref) @ [tcref.CompiledName] - textOfPath path - + // Generic type names are (name + "`" + digits) where name does not contain "`". + let path = Array.toList (fullMangledPathToTyconRef tcref) @ [ tcref.CompiledName ] + textOfPath path + let typarEnc _g (gtpsType, gtpsMethod) typar = match List.tryFindIndex (typarEq typar) gtpsType with | Some idx -> "`" + string idx // single-tick-index for typar from type | None -> match List.tryFindIndex (typarEq typar) gtpsMethod with - | Some idx -> - "``" + string idx // double-tick-index for typar from method + | Some idx -> "``" + string idx // double-tick-index for typar from method | None -> - warning(InternalError("Typar not found during XmlDoc generation", typar.Range)) + 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 -> + 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 -> + | _ 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 + | 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:") + "]" + 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 = + | TType_ucase(_, tinst) + | TType_app(_, tinst, _) -> + let tyName = let ty = stripTyEqnsAndMeasureEqns g ty + match ty with - | TType_app (tcref, _tinst, _nullness) -> + | 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] + 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_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_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_fun(domainTy, rangeTy, _nullness) -> + "Microsoft.FSharp.Core.FSharpFunc" + + tyargsEnc g (gtpsType, gtpsMethod) [ domainTy; rangeTy ] - | TType_var (typar, _nullness) -> - typarEnc g (gtpsType, gtpsMethod) typar + | TType_var(typar, _nullness) -> typarEnc g (gtpsType, gtpsMethod) typar | TType_measure _ -> "?" -and tyargsEnc g (gtpsType, gtpsMethod) args = - match args with +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)) + | [ 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) + ")" + 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 - System.String.Join(".", ap) + System.String.Join(".", ap) | None -> "Extension Type" -let prependPath path name = if String.IsNullOrEmpty(path) then name else !!path + "." + name +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 = + let parentTypars, methTypars, cxs, argInfos, retTy, prefix, path, name = - // CLEANUP: this is one of several code paths that treat module values and members + // 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 -> + + 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 + 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.PropertyGetSet | SynMemberKind.PropertySet | SynMemberKind.PropertyGet -> "P:", v.PropertyName - let path = if v.HasDeclaringEntity then prependPath path v.DeclaringEntity.CompiledName else path + let path = + if v.HasDeclaringEntity then + prependPath path v.DeclaringEntity.CompiledName + else + path - let parentTypars, methTypars = + let parentTypars, methTypars = match PartitionValTypars g v with | Some(_, memberParentTypars, memberMethodTypars, _, _) -> memberParentTypars, memberMethodTypars | None -> [], tps @@ -9080,24 +11216,32 @@ let XmlDocSigOfVal g full path (v: Val) = parentTypars, methTypars, witnessInfos, argInfos, retTy, prefix, path, name | _ -> - // Regular F# values and extension members + // 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 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:" + 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 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 + 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 @@ -9112,95 +11256,104 @@ let XmlDocSigOfTycon path = BuildXmlDocSig "T:" path let XmlDocSigOfSubModul path = BuildXmlDocSig "T:" path let XmlDocSigOfEntity (eref: EntityRef) = - XmlDocSigOfTycon [(buildAccessPath eref.CompilationPathOpt); eref.Deref.CompiledName] + XmlDocSigOfTycon [ (buildAccessPath eref.CompilationPathOpt); eref.Deref.CompiledName ] //-------------------------------------------------------------------------- -// Some unions have null as representations +// Some unions have null as representations //-------------------------------------------------------------------------- - let enum_CompilationRepresentationAttribute_Static = 0b0000000000000001 let enum_CompilationRepresentationAttribute_Instance = 0b0000000000000010 let enum_CompilationRepresentationAttribute_ModuleSuffix = 0b0000000000000100 let enum_CompilationRepresentationAttribute_PermitNull = 0b0000000000001000 let HasUseNullAsTrueValueAttribute g attribs = - match TryFindFSharpInt32Attribute g g.attrib_CompilationRepresentationAttribute attribs with - | Some flags -> ((flags &&& enum_CompilationRepresentationAttribute_PermitNull) <> 0) - | _ -> false + match TryFindFSharpInt32Attribute g g.attrib_CompilationRepresentationAttribute attribs with + | Some flags -> ((flags &&& enum_CompilationRepresentationAttribute_PermitNull) <> 0) + | _ -> false -let TyconHasUseNullAsTrueValueAttribute g (tycon: Tycon) = HasUseNullAsTrueValueAttribute g tycon.Attribs +let TyconHasUseNullAsTrueValueAttribute g (tycon: Tycon) = + HasUseNullAsTrueValueAttribute g tycon.Attribs // WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs let CanHaveUseNullAsTrueValueAttribute (_g: TcGlobals) (tycon: Tycon) = - (tycon.IsUnionTycon && - let ucs = tycon.UnionCasesArray - (ucs.Length = 0 || - (ucs |> Array.existsOne (fun uc -> uc.IsNullary) && - ucs |> Array.exists (fun uc -> not uc.IsNullary)))) + (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 - (ucs.Length = 0 || - (TyconHasUseNullAsTrueValueAttribute g tycon && - ucs |> Array.existsOne (fun uc -> uc.IsNullary) && - ucs |> Array.exists (fun uc -> not uc.IsNullary)))) + (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 inline HasConstraint ([] predicate) (tp:Typar) = - tp.Constraints |> List.exists predicate +let TcrefCompilesInstanceMembersAsStatic g (tcref: TyconRef) = + TyconCompilesInstanceMembersAsStatic g tcref.Deref -let inline tryGetTyparTyWithConstraint g ([] predicate) ty = - match tryDestTyparTy g ty with +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 +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 +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 IsReferenceTyparTy g ty = + ty + |> IsTyparTyWithConstraint g (fun tc -> tc.IsIsReferenceType || tc.IsSupportsNull) -let GetTyparTyIfSupportsNull g ty = ty |> tryGetTyparTyWithConstraint g _.IsSupportsNull +let GetTyparTyIfSupportsNull g ty = + ty |> tryGetTyparTyWithConstraint g _.IsSupportsNull -let TypeNullNever g ty = +let TypeNullNever g ty = let underlyingTy = stripTyEqnsAndMeasureEqns g ty - isStructTy g underlyingTy || - isByrefTy g underlyingTy || - IsNonNullableStructTyparTy 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 ty = +let TypeNullIsExtraValue g m ty = if isILReferenceTy g ty || isDelegateTy g ty then - match tryTcrefOfAppTy g ty with - | ValueSome tcref -> - // Putting AllowNullLiteralAttribute(false) on an IL or provided + 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 - TryFindTyconRefBoolAttribute g m g.attrib_AllowNullLiteralAttribute tcref <> Some false - | _ -> + TryFindTyconRefBoolAttribute g m g.attrib_AllowNullLiteralAttribute tcref + <> Some false + | _ -> // In pre-nullness, other IL reference types (e.g. arrays) always support null true - elif TypeNullNever g ty then + elif TypeNullNever g ty then false - else + 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 + match tryTcrefOfAppTy g ty with | ValueSome tcref -> TryFindTyconRefBoolAttribute g m g.attrib_AllowNullLiteralAttribute tcref = Some true - | ValueNone -> + | ValueNone -> - // Consider type parameters - (GetTyparTyIfSupportsNull g ty).IsSome + // 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) = @@ -9214,22 +11367,23 @@ let nullnessOfTy g ty = |> 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 + | 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()) + | Nullness.Known NullnessInfo.AmbivalentToNull + | Nullness.Known NullnessInfo.WithNull when g.checkNullness -> reqTy |> replaceNullnessOfTy (NewNullnessVar()) | _ -> reqTy | true -> reqTy @@ -9238,77 +11392,80 @@ let changeWithNullReqTyToVariable g reqTy = 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 + | ValueSome t when t.IsCompilerGenerated && not (t |> HasConstraint _.IsSupportsNull) -> changeWithNullReqTyToVariable g reqTy | _ -> reqTy - -let GetDisallowedNullness (g:TcGlobals) (ty:TType) = +let GetDisallowedNullness (g: TcGlobals) (ty: TType) = if g.checkNullness then - let rec hasWithNullAnyWhere ty alreadyWrappedInOuterWithNull = + let rec hasWithNullAnyWhere ty alreadyWrappedInOuterWithNull = match ty with - | TType_var (tp, n) -> - let withNull = alreadyWrappedInOuterWithNull || n.TryEvaluate() = (ValueSome NullnessInfo.WithNull) + | 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, _) -> + | 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 -> + | true, _ when tcr.IsMeasureableReprTycon -> match tcr.TypeReprInfo with | TMeasureableRepr realType -> if hasWithNullAnyWhere realType true |> List.isEmpty then [] - else [ty] + else + [ ty ] | _ -> [] | true, Some tAbbrev -> (hasWithNullAnyWhere tAbbrev true) @ tyArgs | _ -> tyArgs - | TType_tuple (_,tupTypes) -> + | TType_tuple(_, tupTypes) -> let inner = tupTypes |> List.collect (fun t -> hasWithNullAnyWhere t false) if alreadyWrappedInOuterWithNull then ty :: inner else inner - | TType_anon (tys=tys) -> + | 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_fun(d, r, _) -> (hasWithNullAnyWhere d false) @ (hasWithNullAnyWhere r false) | TType_forall _ -> [] | TType_ucase _ -> [] | TType_measure m -> - if alreadyWrappedInOuterWithNull then - let measuresInside = - ListMeasureVarOccs m + if alreadyWrappedInOuterWithNull then + let measuresInside = + ListMeasureVarOccs m |> List.choose (fun x -> x.Solution) |> List.collect (fun x -> hasWithNullAnyWhere x true) + ty :: measuresInside - else [] + else + [] hasWithNullAnyWhere ty false else [] -let TypeHasAllowNull (tcref:TyconRef) g m = - not tcref.IsStructOrEnumTycon && - not (isByrefLikeTyconRef g m tcref) && - (TryFindTyconRefBoolAttribute g m g.attrib_AllowNullLiteralAttribute tcref = Some true) +let TypeHasAllowNull (tcref: TyconRef) g m = + not tcref.IsStructOrEnumTycon + && not (isByrefLikeTyconRef g m tcref) + && (TryFindTyconRefBoolAttribute g m g.attrib_AllowNullLiteralAttribute tcref = Some true) /// The new logic about whether a type admits the use of 'null' as a value. -let TypeNullIsExtraValueNew g m ty = +let TypeNullIsExtraValueNew g m ty = let sty = stripTyparEqns ty - + // Check if the type has AllowNullLiteral - (match tryTcrefOfAppTy g sty with + (match tryTcrefOfAppTy g sty with | ValueSome tcref -> TypeHasAllowNull tcref g m - | _ -> false) + | _ -> false) || // Check if the type has a nullness annotation - (match (nullnessOfTy g sty).Evaluate() with + (match (nullnessOfTy g sty).Evaluate() with | NullnessInfo.AmbivalentToNull -> false | NullnessInfo.WithoutNull -> false | NullnessInfo.WithNull -> true) @@ -9320,92 +11477,105 @@ let TypeNullIsExtraValueNew g m ty = let TypeNullIsTrueValue g ty = (match tryTcrefOfAppTy g ty with | ValueSome tcref -> IsUnionTypeWithNullAsTrueValue g tcref.Deref - | _ -> false) + | _ -> 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 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 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 -> TryFindFSharpBoolAttribute g g.attrib_DefaultValueAttribute fld.FieldAttribs <> Some false) - flds |> List.forall (actualTyOfRecdField (mkTyconRefInst tcref tinst) >> TypeHasDefaultValueAux isNew g m) + (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 -> + TryFindFSharpBoolAttribute g g.attrib_DefaultValueAttribute fld.FieldAttribs + <> Some false) + + 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) - + 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) + 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) + // 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 TypeHasDefaultValue (g: TcGlobals) m ty = TypeHasDefaultValueAux false g m ty -let TypeHasDefaultValueNew g m ty = TypeHasDefaultValueAux true g m ty +let TypeHasDefaultValueNew g m ty = TypeHasDefaultValueAux true g m ty /// 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 (|SpecialComparableHeadType|_|) g ty = + if isAnyTupleTy g ty then let _tupInfo, elemTys = destAnyTupleTy g ty - ValueSome elemTys - elif isAnonRecdTy g ty then + ValueSome elemTys + elif isAnonRecdTy g ty then match tryDestAnonRecdTy g ty with | ValueNone -> ValueSome [] - | ValueSome (_anonInfo, elemTys) -> ValueSome elemTys + | 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 + | 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 + | _ -> ValueNone [] let (|SpecialEquatableHeadType|_|) g ty = (|SpecialComparableHeadType|_|) g ty [] -let (|SpecialNotEquatableHeadType|_|) g ty = +let (|SpecialNotEquatableHeadType|_|) g ty = if isFunTy g ty then ValueSome() else ValueNone -let (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|) (ty,g) = +let (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRefType|UnresolvedRefType|) (ty, g) = let sty = ty |> stripTyEqns g - if isTyparTy g sty then + + if isTyparTy g sty then if (nullnessOfTy g sty).TryEvaluate() = ValueSome NullnessInfo.WithNull then NullableTypar else TyparTy - elif isStructTy g sty then + elif isStructTy g sty then StructTy elif TypeNullIsTrueValue g sty then NullTrueValue @@ -9415,46 +11585,58 @@ let (|TyparTy|NullableTypar|StructTy|NullTrueValue|NullableRefType|WithoutNullRe | ValueSome NullnessInfo.WithoutNull -> WithoutNullRefType | _ -> UnresolvedRefType -// 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) - +// 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 +// Nullness tests and pokes //-------------------------------------------------------------------------- // Generates the logical equivalent of -// match inp with :? ty as v -> e2[v] | _ -> e3 +// 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 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 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 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 dtree = + TDSwitch(vinputExpr, [ TCase(DecisionTreeTest.IsInst(tyOfExpr g vinputExpr, tgtTy), tg2) ], Some tg3, m) + let expr = mbuilder.Close(dtree, m, tyOfExpr g e2) expr @@ -9463,7 +11645,10 @@ let mkUnionCaseTest (g: TcGlobals) (e1, cref: UnionCaseRef, tinst, m) = let mbuilder = new 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 dtree = + TDSwitch(e1, [ TCase(DecisionTreeTest.UnionCase(cref, tinst), tg2) ], Some tg3, m) + let expr = mbuilder.Close(dtree, m, g.bool_ty) expr @@ -9477,13 +11662,13 @@ let mkUnionCaseTest (g: TcGlobals) (e1, cref: UnionCaseRef, tinst, m) = 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 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 + expr let mkNonNullTest (g: TcGlobals) m e = - mkAsmExpr ([ AI_ldnull ; AI_cgt_un ], [], [e], [g.bool_ty], m) + 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. @@ -9498,355 +11683,426 @@ let mkIfThen (g: TcGlobals) m e1 e2 = let ModuleNameIsMangled g attrs = match TryFindFSharpInt32Attribute g g.attrib_CompilationRepresentationAttribute attrs with | Some flags -> ((flags &&& enum_CompilationRepresentationAttribute_ModuleSuffix) <> 0) - | _ -> false + | _ -> false -let CompileAsEvent g attrs = HasFSharpAttribute g g.attrib_CLIEventAttribute attrs +let CompileAsEvent g attrs = + HasFSharpAttribute g g.attrib_CLIEventAttribute attrs 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 + elif + membInfo.MemberFlags.IsDispatchSlot + || membInfo.MemberFlags.IsOverrideOrExplicitImpl + || not (isNil membInfo.ImplementedSlotSigs) + then membInfo.MemberFlags.IsInstance - else + else // Otherwise check attributes to see if there is an explicit instance or explicit static flag - let explicitInstance, explicitStatic = + let explicitInstance, explicitStatic = match TryFindFSharpInt32Attribute g g.attrib_CompilationRepresentationAttribute attrs with - | Some flags -> - ((flags &&& enum_CompilationRepresentationAttribute_Instance) <> 0), - ((flags &&& enum_CompilationRepresentationAttribute_Static) <> 0) + | Some flags -> + ((flags &&& enum_CompilationRepresentationAttribute_Instance) <> 0), + ((flags &&& enum_CompilationRepresentationAttribute_Static) <> 0) | _ -> false, false - explicitInstance || - (membInfo.MemberFlags.IsInstance && - not explicitStatic && - not (TcrefCompilesInstanceMembersAsStatic g parent)) + explicitInstance + || (membInfo.MemberFlags.IsInstance + && not explicitStatic + && not (TcrefCompilesInstanceMembersAsStatic g parent)) let isSealedTy g ty = let ty = stripTyEqnsAndMeasureEqns g ty - not (isRefTy g ty) || - isUnitTy g ty || - isArrayTy g ty || - match metadataOfTy g ty with + 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 + | ILTypeMetadata(TILObjectReprData(_, _, td)) -> td.IsSealed | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - if (isFSharpInterfaceTy g ty || isFSharpClassTy g ty) then - let tcref = tcrefOfAppTy g ty - TryFindFSharpBoolAttribute g g.attrib_SealedAttribute tcref.Attribs = Some true - else - // All other F# types, array, byref, tuple types are sealed - true - + if (isFSharpInterfaceTy g ty || isFSharpClassTy g ty) then + let tcref = tcrefOfAppTy g ty + TryFindFSharpBoolAttribute g g.attrib_SealedAttribute tcref.Attribs = Some true + else + // All other F# types, array, byref, tuple types are sealed + true + let isComInteropTy g ty = let tcref = tcrefOfAppTy g ty + match g.attrib_ComImportAttribute with | None -> false | Some attr -> TryFindFSharpBoolAttribute g attr tcref.Attribs = Some true - + 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 + 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 ValRefIsCompiledAsInstanceMember g (vref: ValRef) = + ValSpecIsCompiledAsInstance g vref.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 +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 //--------------------------------------------------------------------------- // Active pattern name helpers //--------------------------------------------------------------------------- -let TryGetActivePatternInfo (vref: ValRef) = +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 = + 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 -> + | 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)) + + 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 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)) + +//--------------------------------------------------------------------------- +// RewriteExpr: rewrite bottom up with interceptors +//--------------------------------------------------------------------------- + +[] +type ExprRewritingEnv = + { + PreIntercept: ((Expr -> Expr) -> Expr -> Expr option) option + PostTransform: Expr -> Expr option + PreInterceptBinding: ((Expr -> Expr) -> Binding -> Binding option) option + RewriteQuotations: bool + StackGuard: StackGuard + } + +let rec rewriteBind env bind = + match env.PreInterceptBinding with + | Some f -> + match f (RewriteExpr env) bind with + | Some res -> res + | None -> rewriteBindStructure env bind + | None -> rewriteBindStructure env bind + +and rewriteBindStructure env (TBind(v, e, letSeqPtOpt)) = + TBind(v, RewriteExpr env e, letSeqPtOpt) + +and rewriteBinds env binds = List.map (rewriteBind env) binds + +and RewriteExpr env expr = + env.StackGuard.Guard + <| fun () -> + match expr with + | LinearOpExpr _ + | LinearMatchExpr _ + | Expr.Let _ + | Expr.Sequential _ + | Expr.DebugPoint _ -> rewriteLinearExpr env expr id + | _ -> + let expr = + match preRewriteExpr env expr with + | Some expr -> expr + | None -> rewriteExprStructure env expr + + postRewriteExpr env expr + +and preRewriteExpr env expr = + match env.PreIntercept with + | Some f -> f (RewriteExpr env) expr + | None -> None + +and postRewriteExpr env expr = + match env.PostTransform expr with + | None -> expr + | Some expr2 -> expr2 + +and rewriteExprStructure env expr = + match expr with + | Expr.Const _ + | Expr.Val _ -> expr + + | Expr.App(f0, f0ty, tyargs, args, m) -> + let f0R = RewriteExpr env f0 + let argsR = rewriteExprs env args + + if f0 === f0R && args === argsR then + expr + else + Expr.App(f0R, f0ty, tyargs, argsR, m) + + | Expr.Quote(ast, dataCell, isFromQueryExpression, m, ty) -> + let data = + match dataCell.Value with + | None -> None + | Some(data1, data2) -> Some(map3Of4 (rewriteExprs env) data1, map3Of4 (rewriteExprs env) data2) + + Expr.Quote((if env.RewriteQuotations then RewriteExpr env ast else ast), ref data, isFromQueryExpression, m, ty) + + | Expr.Obj(_, ty, basev, basecall, overrides, iimpls, m) -> + let overridesR = List.map (rewriteObjExprOverride env) overrides + let basecallR = RewriteExpr env basecall + let iimplsR = List.map (rewriteObjExprInterfaceImpl env) iimpls + mkObjExpr (ty, basev, basecallR, overridesR, iimplsR, 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 + | Expr.Link eref -> RewriteExpr env eref.Value -let mkChoiceCaseRef g m n i = - mkUnionCaseRef (mkChoiceTyconRef g m n) ("Choice"+string (i+1)+"Of"+string n) + | Expr.DebugPoint _ -> failwith "unreachable - linear debug point" + + | Expr.Op(c, tyargs, args, m) -> + let argsR = rewriteExprs env args + + if args === argsR then + expr + else + Expr.Op(c, tyargs, argsR, m) -type ActivePatternInfo with + | Expr.Lambda(_lambdaId, ctorThisValOpt, baseValOpt, argvs, body, m, bodyTy) -> + let bodyR = RewriteExpr env body + rebuildLambda m ctorThisValOpt baseValOpt argvs (bodyR, bodyTy) - member x.DisplayNameCoreByIdx idx = x.ActiveTags[idx] + | Expr.TyLambda(_lambdaId, tps, body, m, bodyTy) -> + let bodyR = RewriteExpr env body + mkTypeLambda m tps (bodyR, bodyTy) - member x.DisplayNameByIdx idx = x.ActiveTags[idx] |> ConvertLogicalNameToDisplayName + | Expr.Match(spBind, mExpr, dtree, targets, m, ty) -> + let dtreeR = RewriteDecisionTree env dtree + let targetsR = rewriteTargets env targets + mkAndSimplifyMatch spBind mExpr m ty dtreeR targetsR - 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) + | Expr.LetRec(binds, e, m, _) -> + let bindsR = rewriteBinds env binds + let eR = RewriteExpr env e + Expr.LetRec(bindsR, eR, m, Construct.NewFreeVarsCache()) -//--------------------------------------------------------------------------- -// 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)) + | Expr.Let _ -> failwith "unreachable - linear let" -//--------------------------------------------------------------------------- -// RewriteExpr: rewrite bottom up with interceptors -//--------------------------------------------------------------------------- + | Expr.Sequential _ -> failwith "unreachable - linear seq" -[] -type ExprRewritingEnv = - { PreIntercept: ((Expr -> Expr) -> Expr -> Expr option) option - PostTransform: Expr -> Expr option - PreInterceptBinding: ((Expr -> Expr) -> Binding -> Binding option) option - RewriteQuotations: bool - StackGuard: StackGuard } - -let rec rewriteBind env bind = - match env.PreInterceptBinding with - | Some f -> - match f (RewriteExpr env) bind with - | Some res -> res - | None -> rewriteBindStructure env bind - | None -> rewriteBindStructure env bind - -and rewriteBindStructure env (TBind(v, e, letSeqPtOpt)) = - TBind(v, RewriteExpr env e, letSeqPtOpt) + | Expr.StaticOptimization(constraints, e2, e3, m) -> + let e2R = RewriteExpr env e2 + let e3R = RewriteExpr env e3 + Expr.StaticOptimization(constraints, e2R, e3R, m) -and rewriteBinds env binds = List.map (rewriteBind env) binds + | Expr.TyChoose(a, b, m) -> Expr.TyChoose(a, RewriteExpr env b, m) -and RewriteExpr env expr = - env.StackGuard.Guard <| fun () -> - match expr with - | LinearOpExpr _ - | LinearMatchExpr _ - | Expr.Let _ - | Expr.Sequential _ - | Expr.DebugPoint _ -> - rewriteLinearExpr env expr id - | _ -> - let expr = - match preRewriteExpr env expr with - | Some expr -> expr - | None -> rewriteExprStructure env expr - postRewriteExpr env expr - -and preRewriteExpr env expr = - match env.PreIntercept with - | Some f -> f (RewriteExpr env) expr - | None -> None - -and postRewriteExpr env expr = - match env.PostTransform expr with - | None -> expr - | Some expr2 -> expr2 - -and rewriteExprStructure env expr = - match expr with - | Expr.Const _ - | Expr.Val _ -> expr - - | Expr.App (f0, f0ty, tyargs, args, m) -> - let f0R = RewriteExpr env f0 - let argsR = rewriteExprs env args - if f0 === f0R && args === argsR then expr - else Expr.App (f0R, f0ty, tyargs, argsR, m) - - | Expr.Quote (ast, dataCell, isFromQueryExpression, m, ty) -> - let data = - match dataCell.Value with - | None -> None - | Some (data1, data2) -> Some(map3Of4 (rewriteExprs env) data1, map3Of4 (rewriteExprs env) data2) - Expr.Quote ((if env.RewriteQuotations then RewriteExpr env ast else ast), ref data, isFromQueryExpression, m, ty) - - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> - let overridesR = List.map (rewriteObjExprOverride env) overrides - let basecallR = RewriteExpr env basecall - let iimplsR = List.map (rewriteObjExprInterfaceImpl env) iimpls - mkObjExpr(ty, basev, basecallR, overridesR, iimplsR, m) - - | Expr.Link eref -> - RewriteExpr env eref.Value - - | Expr.DebugPoint _ -> - failwith "unreachable - linear debug point" - - | Expr.Op (c, tyargs, args, m) -> - let argsR = rewriteExprs env args - if args === argsR then expr - else Expr.Op (c, tyargs, argsR, m) - - | Expr.Lambda (_lambdaId, ctorThisValOpt, baseValOpt, argvs, body, m, bodyTy) -> - let bodyR = RewriteExpr env body - rebuildLambda m ctorThisValOpt baseValOpt argvs (bodyR, bodyTy) - - | Expr.TyLambda (_lambdaId, tps, body, m, bodyTy) -> - let bodyR = RewriteExpr env body - mkTypeLambda m tps (bodyR, bodyTy) - - | Expr.Match (spBind, mExpr, dtree, targets, m, ty) -> - let dtreeR = RewriteDecisionTree env dtree - let targetsR = rewriteTargets env targets - mkAndSimplifyMatch spBind mExpr m ty dtreeR targetsR - - | Expr.LetRec (binds, e, m, _) -> - let bindsR = rewriteBinds env binds - let eR = RewriteExpr env e - Expr.LetRec (bindsR, eR, m, Construct.NewFreeVarsCache()) - - | Expr.Let _ -> failwith "unreachable - linear let" - - | Expr.Sequential _ -> failwith "unreachable - linear seq" - - | Expr.StaticOptimization (constraints, e2, e3, m) -> - let e2R = RewriteExpr env e2 - let e3R = RewriteExpr env e3 - Expr.StaticOptimization (constraints, e2R, e3R, m) - - | Expr.TyChoose (a, b, m) -> - Expr.TyChoose (a, RewriteExpr env b, m) - - | Expr.WitnessArg (witnessInfo, m) -> - Expr.WitnessArg (witnessInfo, m) + | Expr.WitnessArg(witnessInfo, m) -> Expr.WitnessArg(witnessInfo, m) and rewriteLinearExpr env expr contf = - // schedule a rewrite on the way back up by adding to the continuation + // schedule a rewrite on the way back up by adding to the continuation let contf = contf << postRewriteExpr env - match preRewriteExpr env expr with + + match preRewriteExpr env expr with | Some expr -> contf expr - | None -> - match expr with - | Expr.Let (bind, bodyExpr, m, _) -> + | None -> + match expr with + | Expr.Let(bind, bodyExpr, m, _) -> let bind = rewriteBind env bind // tailcall - rewriteLinearExpr env bodyExpr (contf << (fun bodyExprR -> - mkLetBind m bind bodyExprR)) - - | Expr.Sequential (expr1, expr2, dir, m) -> + rewriteLinearExpr env bodyExpr (contf << (fun bodyExprR -> mkLetBind m bind bodyExprR)) + + | Expr.Sequential(expr1, expr2, dir, m) -> let expr1R = RewriteExpr env expr1 // tailcall - rewriteLinearExpr env expr2 (contf << (fun expr2R -> - if expr1 === expr1R && expr2 === expr2R then expr - else Expr.Sequential (expr1R, expr2R, dir, m))) - - | LinearOpExpr (op, tyargs, argsFront, argLast, m) -> + rewriteLinearExpr + env + expr2 + (contf + << (fun expr2R -> + if expr1 === expr1R && expr2 === expr2R then + expr + else + Expr.Sequential(expr1R, expr2R, dir, m))) + + | LinearOpExpr(op, tyargs, argsFront, argLast, m) -> let argsFrontR = rewriteExprs env argsFront // tailcall - rewriteLinearExpr env argLast (contf << (fun argLastR -> - if argsFront === argsFrontR && argLast === argLastR then expr - else rebuildLinearOpExpr (op, tyargs, argsFrontR, argLastR, m))) - - | LinearMatchExpr (spBind, mExpr, dtree, tg1, expr2, m2, ty) -> + rewriteLinearExpr + env + argLast + (contf + << (fun argLastR -> + if argsFront === argsFrontR && argLast === argLastR then + expr + else + rebuildLinearOpExpr (op, tyargs, argsFrontR, argLastR, m))) + + | LinearMatchExpr(spBind, mExpr, dtree, tg1, expr2, m2, ty) -> let dtree = RewriteDecisionTree env dtree let tg1R = rewriteTarget env tg1 // tailcall - rewriteLinearExpr env expr2 (contf << (fun expr2R -> - rebuildLinearMatchExpr (spBind, mExpr, dtree, tg1R, expr2R, m2, ty))) - - | Expr.DebugPoint (dpm, innerExpr) -> - rewriteLinearExpr env innerExpr (contf << (fun innerExprR -> - Expr.DebugPoint (dpm, innerExprR))) - - | _ -> + rewriteLinearExpr + env + expr2 + (contf + << (fun expr2R -> rebuildLinearMatchExpr (spBind, mExpr, dtree, tg1R, expr2R, m2, ty))) + + | Expr.DebugPoint(dpm, innerExpr) -> rewriteLinearExpr env innerExpr (contf << (fun innerExprR -> Expr.DebugPoint(dpm, innerExprR))) + + | _ -> // no longer linear, no tailcall - contf (RewriteExpr env expr) + contf (RewriteExpr env expr) and rewriteExprs env exprs = List.mapq (RewriteExpr env) exprs and rewriteFlatExprs env exprs = List.mapq (RewriteExpr env) exprs and RewriteDecisionTree env x = - match x with - | TDSuccess (es, n) -> - let esR = rewriteFlatExprs env es - if LanguagePrimitives.PhysicalEquality es esR then x - else TDSuccess(esR, n) - - | TDSwitch (e, cases, dflt, m) -> - let eR = RewriteExpr env e - let casesR = List.map (fun (TCase(discrim, e)) -> TCase(discrim, RewriteDecisionTree env e)) cases - let dfltR = Option.map (RewriteDecisionTree env) dflt - TDSwitch (eR, casesR, dfltR, m) - - | TDBind (bind, body) -> - let bindR = rewriteBind env bind - let bodyR = RewriteDecisionTree env body - TDBind (bindR, bodyR) + match x with + | TDSuccess(es, n) -> + let esR = rewriteFlatExprs env es + + if LanguagePrimitives.PhysicalEquality es esR then + x + else + TDSuccess(esR, n) + + | TDSwitch(e, cases, dflt, m) -> + let eR = RewriteExpr env e + + let casesR = + List.map (fun (TCase(discrim, e)) -> TCase(discrim, RewriteDecisionTree env e)) cases + + let dfltR = Option.map (RewriteDecisionTree env) dflt + TDSwitch(eR, casesR, dfltR, m) + + | TDBind(bind, body) -> + let bindR = rewriteBind env bind + let bodyR = RewriteDecisionTree env body + TDBind(bindR, bodyR) and rewriteTarget env (TTarget(vs, e, flags)) = let eR = RewriteExpr env e @@ -9858,57 +12114,60 @@ and rewriteTargets env targets = and rewriteObjExprOverride env (TObjExprMethod(slotsig, attribs, tps, vs, e, m)) = TObjExprMethod(slotsig, attribs, tps, vs, RewriteExpr env e, m) -and rewriteObjExprInterfaceImpl env (ty, overrides) = +and rewriteObjExprInterfaceImpl env (ty, overrides) = (ty, List.map (rewriteObjExprOverride env) overrides) - -and rewriteModuleOrNamespaceContents env x = - match x with + +and rewriteModuleOrNamespaceContents env x = + match x with | TMDefRec(isRec, opens, tycons, mbinds, m) -> TMDefRec(isRec, opens, tycons, rewriteModuleOrNamespaceBindings env mbinds, m) | TMDefLet(bind, m) -> TMDefLet(rewriteBind env bind, m) | TMDefDo(e, m) -> TMDefDo(RewriteExpr env e, m) | TMDefOpens _ -> x | TMDefs defs -> TMDefs(List.map (rewriteModuleOrNamespaceContents env) defs) -and rewriteModuleOrNamespaceBinding env x = - match x with - | ModuleOrNamespaceBinding.Binding bind -> - ModuleOrNamespaceBinding.Binding (rewriteBind env bind) - | ModuleOrNamespaceBinding.Module(nm, rhs) -> - ModuleOrNamespaceBinding.Module(nm, rewriteModuleOrNamespaceContents env rhs) +and rewriteModuleOrNamespaceBinding env x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> ModuleOrNamespaceBinding.Binding(rewriteBind env bind) + | ModuleOrNamespaceBinding.Module(nm, rhs) -> ModuleOrNamespaceBinding.Module(nm, rewriteModuleOrNamespaceContents env rhs) and rewriteModuleOrNamespaceBindings env mbinds = List.map (rewriteModuleOrNamespaceBinding env) mbinds and RewriteImplFile env implFile = - let (CheckedImplFile (fragName, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = implFile + let (CheckedImplFile(fragName, signature, contents, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode)) = + implFile + let contentsR = rewriteModuleOrNamespaceContents env contents - let implFileR = CheckedImplFile (fragName, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + + let implFileR = + CheckedImplFile(fragName, signature, contentsR, hasExplicitEntryPoint, isScript, anonRecdTypes, namedDebugPointsForInlinedCode) + implFileR //-------------------------------------------------------------------------- -// Build a Remap that converts all "local" references to "public" things +// Build a Remap that converts all "local" references to "public" things // accessed via non local references. //-------------------------------------------------------------------------- -let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) = +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 + 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)) + error (InternalError("Unexpected entity without a pubpath when remapping assembly data", entity.Range)) - let accValRemap (vspec: Val) acc = + 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)) + 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 @@ -9921,259 +12180,294 @@ let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) = //-------------------------------------------------------------------------- // Apply a "local to nonlocal" renaming to a module type. This can't use // remap_mspec since the remapping we want isn't to newly created nodes -// but rather to remap to the nonlocal references. This is deliberately +// but rather to remap to the nonlocal references. This is deliberately // "breaking" the binding structure implicit in the module type, which is // the whole point - one things are rewritten to use non local references then // the elements can be copied at will, e.g. when inlining during optimization. -//------------------------------------------------------------------------ +//------------------------------------------------------------------------ +let rec remapEntityDataToNonLocal ctxt tmenv (d: Entity) = + let tpsR, tmenvinner = + tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv (d.entity_typars.Force(d.entity_range)) -let rec remapEntityDataToNonLocal ctxt tmenv (d: Entity) = - let tpsR, tmenvinner = tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv (d.entity_typars.Force(d.entity_range)) let typarsR = LazyWithContext.NotLazy tpsR let attribsR = d.entity_attribs |> remapAttribs ctxt tmenvinner let tyconReprR = d.entity_tycon_repr |> remapTyconRepr ctxt tmenvinner let tyconAbbrevR = d.TypeAbbrev |> Option.map (remapType tmenvinner) let tyconTcaugR = d.entity_tycon_tcaug |> remapTyconAug tmenvinner - let modulContentsR = - MaybeLazy.Strict (d.entity_modul_type.Value - |> mapImmediateValsAndTycons (remapTyconToNonLocal ctxt tmenv) (remapValToNonLocal ctxt tmenv)) + + let modulContentsR = + MaybeLazy.Strict( + d.entity_modul_type.Value + |> mapImmediateValsAndTycons (remapTyconToNonLocal ctxt tmenv) (remapValToNonLocal ctxt tmenv) + ) + let exnInfoR = d.ExceptionInfo |> remapTyconExnInfo ctxt tmenvinner - { d with - entity_typars = typarsR - entity_attribs = attribsR - entity_tycon_repr = tyconReprR - entity_tycon_tcaug = tyconTcaugR - entity_modul_type = modulContentsR - entity_opt_data = + + { d with + entity_typars = typarsR + entity_attribs = attribsR + entity_tycon_repr = tyconReprR + entity_tycon_tcaug = tyconTcaugR + entity_modul_type = modulContentsR + entity_opt_data = match d.entity_opt_data with | Some dd -> - Some { dd with entity_tycon_abbrev = tyconAbbrevR; entity_exn_info = exnInfoR } - | _ -> None } + Some + { dd with + entity_tycon_abbrev = tyconAbbrevR + entity_exn_info = exnInfoR + } + | _ -> None + } -and remapTyconToNonLocal ctxt tmenv x = - x |> Construct.NewModifiedTycon (remapEntityDataToNonLocal ctxt tmenv) +and remapTyconToNonLocal ctxt tmenv x = + x |> Construct.NewModifiedTycon(remapEntityDataToNonLocal ctxt tmenv) -and remapValToNonLocal ctxt tmenv inp = +and remapValToNonLocal ctxt tmenv inp = // creates a new stamp - inp |> Construct.NewModifiedVal (remapValData ctxt tmenv) + inp |> Construct.NewModifiedVal(remapValData ctxt tmenv) let ApplyExportRemappingToEntity g tmenv x = - let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } + let ctxt = + { + g = g + stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") + } + remapTyconToNonLocal ctxt tmenv x (* Which constraints actually get compiled to .NET constraints? *) -let isCompiledOrWitnessPassingConstraint (g: TcGlobals) cx = - match cx with - | TyparConstraint.SupportsNull _ // this implies the 'class' constraint - | TyparConstraint.IsReferenceType _ // this is the 'class' constraint - | TyparConstraint.IsNonNullableStruct _ - | TyparConstraint.IsReferenceType _ - | TyparConstraint.RequiresDefaultConstructor _ - | TyparConstraint.CoercesTo _ -> true - | TyparConstraint.MayResolveMember _ when g.langVersion.SupportsFeature LanguageFeature.WitnessPassing -> true - | _ -> false - -// Is a value a first-class polymorphic value with .NET constraints, or witness-passing constraints? +let isCompiledOrWitnessPassingConstraint (g: TcGlobals) cx = + match cx with + | TyparConstraint.SupportsNull _ // this implies the 'class' constraint + | TyparConstraint.IsReferenceType _ // this is the 'class' constraint + | TyparConstraint.IsNonNullableStruct _ + | TyparConstraint.IsReferenceType _ + | TyparConstraint.RequiresDefaultConstructor _ + | TyparConstraint.CoercesTo _ -> true + | TyparConstraint.MayResolveMember _ when g.langVersion.SupportsFeature LanguageFeature.WitnessPassing -> true + | _ -> false + +// Is a value a first-class polymorphic value with .NET constraints, or witness-passing constraints? // Used to turn off TLR and method splitting and do not compile to // FSharpTypeFunc, but rather bake a "local type function" for each TyLambda abstraction. -let IsGenericValWithGenericConstraints g (v: Val) = - isForallTy g v.Type && - v.Type |> destForallTy g |> fst |> List.exists (fun tp -> HasConstraint (isCompiledOrWitnessPassingConstraint g) tp) - -// Does a type support a given interface? -type Entity with - member tycon.HasInterface g ty = - tycon.TypeContents.tcaug_interfaces |> List.exists (fun (x, _, _) -> typeEquiv g ty x) - - // Does a type have an override matching the given name and argument types? - // Used to detect the presence of 'Equals' and 'GetHashCode' in type checking - member tycon.HasOverride g nm argTys = - tycon.TypeContents.tcaug_adhoc +let IsGenericValWithGenericConstraints g (v: Val) = + isForallTy g v.Type + && v.Type + |> destForallTy g + |> fst + |> List.exists (fun tp -> HasConstraint (isCompiledOrWitnessPassingConstraint g) tp) + +// Does a type support a given interface? +type Entity with + member tycon.HasInterface g ty = + tycon.TypeContents.tcaug_interfaces + |> List.exists (fun (x, _, _) -> typeEquiv g ty x) + + // Does a type have an override matching the given name and argument types? + // Used to detect the presence of 'Equals' and 'GetHashCode' in type checking + member tycon.HasOverride g nm argTys = + tycon.TypeContents.tcaug_adhoc |> NameMultiMap.find nm - |> List.exists (fun vref -> - match vref.MemberInfo with - | None -> false + |> List.exists (fun vref -> + match vref.MemberInfo with + | None -> false | Some membInfo -> - - let argInfos = ArgInfosOfMember g vref - match argInfos with - | [argInfos] -> - List.lengthsEqAndForall2 (typeEquiv g) (List.map fst argInfos) argTys && - membInfo.MemberFlags.IsOverrideOrExplicitImpl - | _ -> false) - member tycon.TryGetMember g nm argTys = - tycon.TypeContents.tcaug_adhoc + let argInfos = ArgInfosOfMember g vref + + match argInfos with + | [ argInfos ] -> + List.lengthsEqAndForall2 (typeEquiv g) (List.map fst argInfos) argTys + && membInfo.MemberFlags.IsOverrideOrExplicitImpl + | _ -> false) + + member tycon.TryGetMember g nm argTys = + tycon.TypeContents.tcaug_adhoc |> NameMultiMap.find nm - |> List.tryFind (fun vref -> - match vref.MemberInfo with - | None -> false + |> List.tryFind (fun vref -> + match vref.MemberInfo with + | None -> false | _ -> - let argInfos = ArgInfosOfMember g vref - match argInfos with - | [argInfos] -> List.lengthsEqAndForall2 (typeEquiv g) (List.map fst argInfos) argTys - | _ -> false) - + let argInfos = ArgInfosOfMember g vref + + match argInfos with + | [ argInfos ] -> List.lengthsEqAndForall2 (typeEquiv g) (List.map fst argInfos) argTys + | _ -> false) + member tycon.HasMember g nm argTys = (tycon.TryGetMember g nm argTys).IsSome -type EntityRef with +type EntityRef with member tcref.HasInterface g ty = tcref.Deref.HasInterface g ty member tcref.HasOverride g nm argTys = tcref.Deref.HasOverride g nm argTys member tcref.HasMember g nm argTys = tcref.Deref.HasMember g nm argTys let mkFastForLoop g (spFor, spTo, m, idv: Val, start, dir, finish, body) = - let dir = if dir then FSharpForLoopUp else FSharpForLoopDown + let dir = if dir then FSharpForLoopUp else FSharpForLoopDown mkIntegerForLoop g (spFor, spTo, idv, start, dir, finish, body, m) /// Accessing a binding of the form "let x = 1" or "let x = e" for any "e" satisfying the predicate /// below does not cause an initialization trigger, i.e. does not get compiled as a static field. -let IsSimpleSyntacticConstantExpr g inputExpr = - let rec checkExpr (vrefs: Set) x = - match stripExpr x with - | Expr.Op (TOp.Coerce, _, [arg], _) - -> checkExpr vrefs arg - | UnopExpr g (vref, arg) - when (valRefEq g vref g.unchecked_unary_minus_vref || - valRefEq g vref g.unchecked_unary_plus_vref || - valRefEq g vref g.unchecked_unary_not_vref || - valRefEq g vref g.bitwise_unary_not_vref || - valRefEq g vref g.enum_vref) - -> checkExpr vrefs arg +let IsSimpleSyntacticConstantExpr g inputExpr = + let rec checkExpr (vrefs: Set) x = + match stripExpr x with + | Expr.Op(TOp.Coerce, _, [ arg ], _) -> checkExpr vrefs arg + | UnopExpr g (vref, arg) when + (valRefEq g vref g.unchecked_unary_minus_vref + || valRefEq g vref g.unchecked_unary_plus_vref + || valRefEq g vref g.unchecked_unary_not_vref + || valRefEq g vref g.bitwise_unary_not_vref + || valRefEq g vref g.enum_vref) + -> + checkExpr vrefs arg // compare, =, <>, +, -, <, >, <=, >=, <<<, >>>, &&&, |||, ^^^ - | BinopExpr g (vref, arg1, arg2) - when (valRefEq g vref g.equals_operator_vref || - valRefEq g vref g.compare_operator_vref || - valRefEq g vref g.unchecked_addition_vref || - valRefEq g vref g.less_than_operator_vref || - valRefEq g vref g.less_than_or_equals_operator_vref || - valRefEq g vref g.greater_than_operator_vref || - valRefEq g vref g.greater_than_or_equals_operator_vref || - valRefEq g vref g.not_equals_operator_vref || - valRefEq g vref g.unchecked_addition_vref || - valRefEq g vref g.unchecked_multiply_vref || - valRefEq g vref g.unchecked_subtraction_vref || - // Note: division and modulus can raise exceptions, so are not included - valRefEq g vref g.bitwise_shift_left_vref || - valRefEq g vref g.bitwise_shift_right_vref || - valRefEq g vref g.bitwise_xor_vref || - valRefEq g vref g.bitwise_and_vref || - valRefEq g vref g.bitwise_or_vref || - valRefEq g vref g.exponentiation_vref) && - (not (typeEquiv g (tyOfExpr g arg1) g.string_ty) && not (typeEquiv g (tyOfExpr g arg1) g.decimal_ty) ) - -> checkExpr vrefs arg1 && checkExpr vrefs arg2 - | Expr.Val (vref, _, _) -> vref.Deref.IsCompiledAsStaticPropertyWithoutField || vrefs.Contains vref.Stamp - | Expr.Match (_, _, dtree, targets, _, _) -> checkDecisionTree vrefs dtree && targets |> Array.forall (checkDecisionTreeTarget vrefs) - | Expr.Let (b, e, _, _) -> checkExpr vrefs b.Expr && checkExpr (vrefs.Add b.Var.Stamp) e - | Expr.DebugPoint (_, b) -> checkExpr vrefs b - | Expr.TyChoose (_, b, _) -> checkExpr vrefs b - // Detect standard constants - | Expr.Const _ - | Expr.Op (TOp.UnionCase _, _, [], _) // Nullary union cases - | UncheckedDefaultOfExpr g _ - | SizeOfExpr g _ + | BinopExpr g (vref, arg1, arg2) when + (valRefEq g vref g.equals_operator_vref + || valRefEq g vref g.compare_operator_vref + || valRefEq g vref g.unchecked_addition_vref + || valRefEq g vref g.less_than_operator_vref + || valRefEq g vref g.less_than_or_equals_operator_vref + || valRefEq g vref g.greater_than_operator_vref + || valRefEq g vref g.greater_than_or_equals_operator_vref + || valRefEq g vref g.not_equals_operator_vref + || valRefEq g vref g.unchecked_addition_vref + || valRefEq g vref g.unchecked_multiply_vref + || valRefEq g vref g.unchecked_subtraction_vref + || + // Note: division and modulus can raise exceptions, so are not included + valRefEq g vref g.bitwise_shift_left_vref + || valRefEq g vref g.bitwise_shift_right_vref + || valRefEq g vref g.bitwise_xor_vref + || valRefEq g vref g.bitwise_and_vref + || valRefEq g vref g.bitwise_or_vref + || valRefEq g vref g.exponentiation_vref) + && (not (typeEquiv g (tyOfExpr g arg1) g.string_ty) + && not (typeEquiv g (tyOfExpr g arg1) g.decimal_ty)) + -> + checkExpr vrefs arg1 && checkExpr vrefs arg2 + | Expr.Val(vref, _, _) -> vref.Deref.IsCompiledAsStaticPropertyWithoutField || vrefs.Contains vref.Stamp + | Expr.Match(_, _, dtree, targets, _, _) -> + checkDecisionTree vrefs dtree + && targets |> Array.forall (checkDecisionTreeTarget vrefs) + | Expr.Let(b, e, _, _) -> checkExpr vrefs b.Expr && checkExpr (vrefs.Add b.Var.Stamp) e + | Expr.DebugPoint(_, b) -> checkExpr vrefs b + | Expr.TyChoose(_, b, _) -> checkExpr vrefs b + // Detect standard constants + | Expr.Const _ + | Expr.Op(TOp.UnionCase _, _, [], _) // Nullary union cases + | UncheckedDefaultOfExpr g _ + | SizeOfExpr g _ | TypeOfExpr g _ -> true | NameOfExpr g _ when g.langVersion.SupportsFeature LanguageFeature.NameOf -> true // All others are not simple constant expressions | _ -> false - and checkDecisionTree vrefs x = - match x with - | TDSuccess (es, _n) -> es |> List.forall (checkExpr vrefs) - | TDSwitch (e, cases, dflt, _m) -> - checkExpr vrefs e && - cases |> List.forall (checkDecisionTreeCase vrefs) && - dflt |> Option.forall (checkDecisionTree vrefs) - | TDBind (bind, body) -> - checkExpr vrefs bind.Expr && - checkDecisionTree (vrefs.Add bind.Var.Stamp) body - - and checkDecisionTreeCase vrefs (TCase(discrim, dtree)) = + and checkDecisionTree vrefs x = + match x with + | TDSuccess(es, _n) -> es |> List.forall (checkExpr vrefs) + | TDSwitch(e, cases, dflt, _m) -> + checkExpr vrefs e + && cases |> List.forall (checkDecisionTreeCase vrefs) + && dflt |> Option.forall (checkDecisionTree vrefs) + | TDBind(bind, body) -> checkExpr vrefs bind.Expr && checkDecisionTree (vrefs.Add bind.Var.Stamp) body + + and checkDecisionTreeCase vrefs (TCase(discrim, dtree)) = (match discrim with | DecisionTreeTest.Const _c -> true - | _ -> false) && - checkDecisionTree vrefs dtree + | _ -> false) + && checkDecisionTree vrefs dtree - and checkDecisionTreeTarget vrefs (TTarget(vs, e, _)) = - let vrefs = ((vrefs, vs) ||> List.fold (fun s v -> s.Add v.Stamp)) + and checkDecisionTreeTarget vrefs (TTarget(vs, e, _)) = + let vrefs = ((vrefs, vs) ||> List.fold (fun s v -> s.Add v.Stamp)) checkExpr vrefs e - checkExpr Set.empty inputExpr + checkExpr Set.empty inputExpr let EvalArithShiftOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64) (arg1: Expr) (arg2: Expr) = // At compile-time we check arithmetic let m = unionRanges arg1.Range arg2.Range + try match arg1, arg2 with - | Expr.Const (Const.Int32 x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.Int32 (opInt32 x1 shift), m, ty) - | Expr.Const (Const.SByte x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.SByte (opInt8 x1 shift), m, ty) - | Expr.Const (Const.Int16 x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.Int16 (opInt16 x1 shift), m, ty) - | Expr.Const (Const.Int64 x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.Int64 (opInt64 x1 shift), m, ty) - | Expr.Const (Const.Byte x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.Byte (opUInt8 x1 shift), m, ty) - | Expr.Const (Const.UInt16 x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.UInt16 (opUInt16 x1 shift), m, ty) - | Expr.Const (Const.UInt32 x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.UInt32 (opUInt32 x1 shift), m, ty) - | Expr.Const (Const.UInt64 x1, _, ty), Expr.Const (Const.Int32 shift, _, _) -> Expr.Const (Const.UInt64 (opUInt64 x1 shift), m, ty) - | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(), m)) - with :? System.OverflowException -> error (Error ( FSComp.SR.tastConstantExpressionOverflow(), m)) + | Expr.Const(Const.Int32 x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.Int32(opInt32 x1 shift), m, ty) + | Expr.Const(Const.SByte x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.SByte(opInt8 x1 shift), m, ty) + | Expr.Const(Const.Int16 x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.Int16(opInt16 x1 shift), m, ty) + | Expr.Const(Const.Int64 x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.Int64(opInt64 x1 shift), m, ty) + | Expr.Const(Const.Byte x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.Byte(opUInt8 x1 shift), m, ty) + | Expr.Const(Const.UInt16 x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.UInt16(opUInt16 x1 shift), m, ty) + | Expr.Const(Const.UInt32 x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.UInt32(opUInt32 x1 shift), m, ty) + | Expr.Const(Const.UInt64 x1, _, ty), Expr.Const(Const.Int32 shift, _, _) -> Expr.Const(Const.UInt64(opUInt64 x1 shift), m, ty) + | _ -> error (Error(FSComp.SR.tastNotAConstantExpression (), m)) + with :? System.OverflowException -> + error (Error(FSComp.SR.tastConstantExpressionOverflow (), m)) let EvalArithUnOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64, opSingle, opDouble) (arg1: Expr) = // At compile-time we check arithmetic let m = arg1.Range + try match arg1 with - | Expr.Const (Const.Int32 x1, _, ty) -> Expr.Const (Const.Int32 (opInt32 x1), m, ty) - | Expr.Const (Const.SByte x1, _, ty) -> Expr.Const (Const.SByte (opInt8 x1), m, ty) - | Expr.Const (Const.Int16 x1, _, ty) -> Expr.Const (Const.Int16 (opInt16 x1), m, ty) - | Expr.Const (Const.Int64 x1, _, ty) -> Expr.Const (Const.Int64 (opInt64 x1), m, ty) - | Expr.Const (Const.Byte x1, _, ty) -> Expr.Const (Const.Byte (opUInt8 x1), m, ty) - | Expr.Const (Const.UInt16 x1, _, ty) -> Expr.Const (Const.UInt16 (opUInt16 x1), m, ty) - | Expr.Const (Const.UInt32 x1, _, ty) -> Expr.Const (Const.UInt32 (opUInt32 x1), m, ty) - | Expr.Const (Const.UInt64 x1, _, ty) -> Expr.Const (Const.UInt64 (opUInt64 x1), m, ty) - | Expr.Const (Const.Single x1, _, ty) -> Expr.Const (Const.Single (opSingle x1), m, ty) - | Expr.Const (Const.Double x1, _, ty) -> Expr.Const (Const.Double (opDouble x1), m, ty) - | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(), m)) - with :? System.OverflowException -> error (Error ( FSComp.SR.tastConstantExpressionOverflow(), m)) - -let EvalArithBinOp (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64, opSingle, opDouble, opDecimal) (arg1: Expr) (arg2: Expr) = + | Expr.Const(Const.Int32 x1, _, ty) -> Expr.Const(Const.Int32(opInt32 x1), m, ty) + | Expr.Const(Const.SByte x1, _, ty) -> Expr.Const(Const.SByte(opInt8 x1), m, ty) + | Expr.Const(Const.Int16 x1, _, ty) -> Expr.Const(Const.Int16(opInt16 x1), m, ty) + | Expr.Const(Const.Int64 x1, _, ty) -> Expr.Const(Const.Int64(opInt64 x1), m, ty) + | Expr.Const(Const.Byte x1, _, ty) -> Expr.Const(Const.Byte(opUInt8 x1), m, ty) + | Expr.Const(Const.UInt16 x1, _, ty) -> Expr.Const(Const.UInt16(opUInt16 x1), m, ty) + | Expr.Const(Const.UInt32 x1, _, ty) -> Expr.Const(Const.UInt32(opUInt32 x1), m, ty) + | Expr.Const(Const.UInt64 x1, _, ty) -> Expr.Const(Const.UInt64(opUInt64 x1), m, ty) + | Expr.Const(Const.Single x1, _, ty) -> Expr.Const(Const.Single(opSingle x1), m, ty) + | Expr.Const(Const.Double x1, _, ty) -> Expr.Const(Const.Double(opDouble x1), m, ty) + | _ -> error (Error(FSComp.SR.tastNotAConstantExpression (), m)) + with :? System.OverflowException -> + error (Error(FSComp.SR.tastConstantExpressionOverflow (), m)) + +let EvalArithBinOp + (opInt8, opInt16, opInt32, opInt64, opUInt8, opUInt16, opUInt32, opUInt64, opSingle, opDouble, opDecimal) + (arg1: Expr) + (arg2: Expr) + = // At compile-time we check arithmetic let m = unionRanges arg1.Range arg2.Range + try match arg1, arg2 with - | Expr.Const (Const.Int32 x1, _, ty), Expr.Const (Const.Int32 x2, _, _) -> Expr.Const (Const.Int32 (opInt32 x1 x2), m, ty) - | Expr.Const (Const.SByte x1, _, ty), Expr.Const (Const.SByte x2, _, _) -> Expr.Const (Const.SByte (opInt8 x1 x2), m, ty) - | Expr.Const (Const.Int16 x1, _, ty), Expr.Const (Const.Int16 x2, _, _) -> Expr.Const (Const.Int16 (opInt16 x1 x2), m, ty) - | Expr.Const (Const.Int64 x1, _, ty), Expr.Const (Const.Int64 x2, _, _) -> Expr.Const (Const.Int64 (opInt64 x1 x2), m, ty) - | Expr.Const (Const.Byte x1, _, ty), Expr.Const (Const.Byte x2, _, _) -> Expr.Const (Const.Byte (opUInt8 x1 x2), m, ty) - | Expr.Const (Const.UInt16 x1, _, ty), Expr.Const (Const.UInt16 x2, _, _) -> Expr.Const (Const.UInt16 (opUInt16 x1 x2), m, ty) - | Expr.Const (Const.UInt32 x1, _, ty), Expr.Const (Const.UInt32 x2, _, _) -> Expr.Const (Const.UInt32 (opUInt32 x1 x2), m, ty) - | Expr.Const (Const.UInt64 x1, _, ty), Expr.Const (Const.UInt64 x2, _, _) -> Expr.Const (Const.UInt64 (opUInt64 x1 x2), m, ty) - | Expr.Const (Const.Single x1, _, ty), Expr.Const (Const.Single x2, _, _) -> Expr.Const (Const.Single (opSingle x1 x2), m, ty) - | Expr.Const (Const.Double x1, _, ty), Expr.Const (Const.Double x2, _, _) -> Expr.Const (Const.Double (opDouble x1 x2), m, ty) - | Expr.Const (Const.Decimal x1, _, ty), Expr.Const (Const.Decimal x2, _, _) -> Expr.Const (Const.Decimal (opDecimal x1 x2), m, ty) - | _ -> error (Error ( FSComp.SR.tastNotAConstantExpression(), m)) - with :? System.OverflowException -> error (Error ( FSComp.SR.tastConstantExpressionOverflow(), m)) + | Expr.Const(Const.Int32 x1, _, ty), Expr.Const(Const.Int32 x2, _, _) -> Expr.Const(Const.Int32(opInt32 x1 x2), m, ty) + | Expr.Const(Const.SByte x1, _, ty), Expr.Const(Const.SByte x2, _, _) -> Expr.Const(Const.SByte(opInt8 x1 x2), m, ty) + | Expr.Const(Const.Int16 x1, _, ty), Expr.Const(Const.Int16 x2, _, _) -> Expr.Const(Const.Int16(opInt16 x1 x2), m, ty) + | Expr.Const(Const.Int64 x1, _, ty), Expr.Const(Const.Int64 x2, _, _) -> Expr.Const(Const.Int64(opInt64 x1 x2), m, ty) + | Expr.Const(Const.Byte x1, _, ty), Expr.Const(Const.Byte x2, _, _) -> Expr.Const(Const.Byte(opUInt8 x1 x2), m, ty) + | Expr.Const(Const.UInt16 x1, _, ty), Expr.Const(Const.UInt16 x2, _, _) -> Expr.Const(Const.UInt16(opUInt16 x1 x2), m, ty) + | Expr.Const(Const.UInt32 x1, _, ty), Expr.Const(Const.UInt32 x2, _, _) -> Expr.Const(Const.UInt32(opUInt32 x1 x2), m, ty) + | Expr.Const(Const.UInt64 x1, _, ty), Expr.Const(Const.UInt64 x2, _, _) -> Expr.Const(Const.UInt64(opUInt64 x1 x2), m, ty) + | Expr.Const(Const.Single x1, _, ty), Expr.Const(Const.Single x2, _, _) -> Expr.Const(Const.Single(opSingle x1 x2), m, ty) + | Expr.Const(Const.Double x1, _, ty), Expr.Const(Const.Double x2, _, _) -> Expr.Const(Const.Double(opDouble x1 x2), m, ty) + | Expr.Const(Const.Decimal x1, _, ty), Expr.Const(Const.Decimal x2, _, _) -> Expr.Const(Const.Decimal(opDecimal x1 x2), m, ty) + | _ -> error (Error(FSComp.SR.tastNotAConstantExpression (), m)) + with :? System.OverflowException -> + error (Error(FSComp.SR.tastConstantExpressionOverflow (), m)) // See also PostTypeCheckSemanticChecks.CheckAttribArgExpr, which must match this precisely -let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) = +let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) = let ignore (_x: 'a) = Unchecked.defaultof<'a> let ignore2 (_x: 'a) (_y: 'a) = Unchecked.defaultof<'a> - let inline checkFeature() = + let inline checkFeature () = if suppressLangFeatureCheck = SuppressLanguageFeatureCheck.No then checkLanguageFeatureAndRecover g.langVersion LanguageFeature.ArithmeticInLiterals x.Range - match x with + match x with - // Detect standard constants - | Expr.Const (c, m, _) -> - match c with - | Const.Bool _ - | Const.Int32 _ + // Detect standard constants + | Expr.Const(c, m, _) -> + match c with + | Const.Bool _ + | Const.Int32 _ | Const.SByte _ | Const.Int16 _ | Const.Int32 _ - | Const.Int64 _ + | Const.Int64 _ | Const.Byte _ | Const.UInt16 _ | Const.UInt32 _ @@ -10183,188 +12477,260 @@ let rec EvalAttribArgExpr suppressLangFeatureCheck (g: TcGlobals) (x: Expr) = | Const.Char _ | Const.Zero | Const.String _ - | Const.Decimal _ -> - x - | Const.IntPtr _ | Const.UIntPtr _ | Const.Unit -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), m)) + | Const.Decimal _ -> x + | Const.IntPtr _ + | Const.UIntPtr _ + | Const.Unit -> + errorR (Error(FSComp.SR.tastNotAConstantExpression (), m)) x | TypeOfExpr g _ -> x | TypeDefOfExpr g _ -> x - | Expr.Op (TOp.Coerce, _, [arg], _) -> - EvalAttribArgExpr suppressLangFeatureCheck g arg - | EnumExpr g arg1 -> - EvalAttribArgExpr suppressLangFeatureCheck g arg1 + | Expr.Op(TOp.Coerce, _, [ arg ], _) -> EvalAttribArgExpr suppressLangFeatureCheck g arg + | EnumExpr g arg1 -> EvalAttribArgExpr suppressLangFeatureCheck g arg1 // Detect bitwise or of attribute flags - | AttribBitwiseOrExpr g (arg1, arg2) -> + | AttribBitwiseOrExpr g (arg1, arg2) -> let v1 = EvalAttribArgExpr suppressLangFeatureCheck g arg1 match v1 with | IntegerConstExpr -> - EvalArithBinOp ((|||), (|||), (|||), (|||), (|||), (|||), (|||), (|||), ignore2, ignore2, ignore2) v1 (EvalAttribArgExpr suppressLangFeatureCheck g arg2) + EvalArithBinOp + ((|||), (|||), (|||), (|||), (|||), (|||), (|||), (|||), ignore2, ignore2, ignore2) + v1 + (EvalAttribArgExpr suppressLangFeatureCheck g arg2) | _ -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x | SpecificBinopExpr g g.unchecked_addition_vref (arg1, arg2) -> - let v1, v2 = EvalAttribArgExpr suppressLangFeatureCheck g arg1, EvalAttribArgExpr suppressLangFeatureCheck g arg2 + let v1, v2 = + EvalAttribArgExpr suppressLangFeatureCheck g arg1, EvalAttribArgExpr suppressLangFeatureCheck g arg2 match v1, v2 with - | Expr.Const (Const.String x1, m, ty), Expr.Const (Const.String x2, _, _) -> - Expr.Const (Const.String (x1 + x2), m, ty) - | Expr.Const (Const.Char x1, m, ty), Expr.Const (Const.Char x2, _, _) -> - checkFeature() - Expr.Const (Const.Char (x1 + x2), m, ty) + | Expr.Const(Const.String x1, m, ty), Expr.Const(Const.String x2, _, _) -> Expr.Const(Const.String(x1 + x2), m, ty) + | Expr.Const(Const.Char x1, m, ty), Expr.Const(Const.Char x2, _, _) -> + checkFeature () + Expr.Const(Const.Char(x1 + x2), m, ty) | _ -> - checkFeature() - EvalArithBinOp (Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+), Checked.(+)) v1 v2 + checkFeature () + + EvalArithBinOp + (Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+), + Checked.(+)) + v1 + v2 | SpecificBinopExpr g g.unchecked_subtraction_vref (arg1, arg2) -> - checkFeature() - let v1, v2 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1, EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2 - + checkFeature () + + let v1, v2 = + EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1, EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2 + match v1, v2 with - | Expr.Const (Const.Char x1, m, ty), Expr.Const (Const.Char x2, _, _) -> - Expr.Const (Const.Char (x1 - x2), m, ty) + | Expr.Const(Const.Char x1, m, ty), Expr.Const(Const.Char x2, _, _) -> Expr.Const(Const.Char(x1 - x2), m, ty) | _ -> - EvalArithBinOp (Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-), Checked.(-)) v1 v2 + EvalArithBinOp + (Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-), + Checked.(-)) + v1 + v2 | SpecificBinopExpr g g.unchecked_multiply_vref (arg1, arg2) -> - checkFeature() - EvalArithBinOp (Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*), Checked.(*)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + checkFeature () + + EvalArithBinOp + (Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*), + Checked.(*)) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | SpecificBinopExpr g g.unchecked_division_vref (arg1, arg2) -> - checkFeature() - EvalArithBinOp ((/), (/), (/), (/), (/), (/), (/), (/), (/), (/), (/)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + checkFeature () + + EvalArithBinOp + ((/), (/), (/), (/), (/), (/), (/), (/), (/), (/), (/)) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | SpecificBinopExpr g g.unchecked_modulus_vref (arg1, arg2) -> - checkFeature() - EvalArithBinOp ((%), (%), (%), (%), (%), (%), (%), (%), (%), (%), (%)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + checkFeature () + + EvalArithBinOp + ((%), (%), (%), (%), (%), (%), (%), (%), (%), (%), (%)) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | SpecificBinopExpr g g.bitwise_shift_left_vref (arg1, arg2) -> - checkFeature() - EvalArithShiftOp ((<<<), (<<<), (<<<), (<<<), (<<<), (<<<), (<<<), (<<<)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + checkFeature () + + EvalArithShiftOp + ((<<<), (<<<), (<<<), (<<<), (<<<), (<<<), (<<<), (<<<)) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | SpecificBinopExpr g g.bitwise_shift_right_vref (arg1, arg2) -> - checkFeature() - EvalArithShiftOp ((>>>), (>>>), (>>>), (>>>), (>>>), (>>>), (>>>), (>>>)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + checkFeature () + + EvalArithShiftOp + ((>>>), (>>>), (>>>), (>>>), (>>>), (>>>), (>>>), (>>>)) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | SpecificBinopExpr g g.bitwise_and_vref (arg1, arg2) -> - checkFeature() + checkFeature () let v1 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1 match v1 with | IntegerConstExpr -> - EvalArithBinOp ((&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), ignore2, ignore2, ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + EvalArithBinOp + ((&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), (&&&), ignore2, ignore2, ignore2) + v1 + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | _ -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x | SpecificBinopExpr g g.bitwise_xor_vref (arg1, arg2) -> - checkFeature() + checkFeature () let v1 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1 match v1 with | IntegerConstExpr -> - EvalArithBinOp ((^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), ignore2, ignore2, ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + EvalArithBinOp + ((^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), (^^^), ignore2, ignore2, ignore2) + v1 + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | _ -> - errorR (Error (FSComp.SR.tastNotAConstantExpression(), x.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x | SpecificBinopExpr g g.exponentiation_vref (arg1, arg2) -> - checkFeature() + checkFeature () let v1 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1 match v1 with | FloatConstExpr -> - EvalArithBinOp (ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ( ** ), ( ** ), ignore2) v1 (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) + EvalArithBinOp + (ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ignore2, ( ** ), ( ** ), ignore2) + v1 + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg2) | _ -> - errorR (Error (FSComp.SR.tastNotAConstantExpression(), x.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x | SpecificUnopExpr g g.bitwise_unary_not_vref arg1 -> - checkFeature() + checkFeature () let v1 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1 - + match v1 with | IntegerConstExpr -> - EvalArithUnOp ((~~~), (~~~), (~~~), (~~~), (~~~), (~~~), (~~~), (~~~), ignore, ignore) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + EvalArithUnOp + ((~~~), (~~~), (~~~), (~~~), (~~~), (~~~), (~~~), (~~~), ignore, ignore) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) | _ -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x | SpecificUnopExpr g g.unchecked_unary_minus_vref arg1 -> - checkFeature() + checkFeature () let v1 = EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1 match v1 with | SignedConstExpr -> - EvalArithUnOp (Checked.(~-), Checked.(~-), Checked.(~-), Checked.(~-), ignore, ignore, ignore, ignore, Checked.(~-), Checked.(~-)) v1 + EvalArithUnOp + (Checked.(~-), Checked.(~-), Checked.(~-), Checked.(~-), ignore, ignore, ignore, ignore, Checked.(~-), Checked.(~-)) + v1 | _ -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), v1.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), v1.Range)) x | SpecificUnopExpr g g.unchecked_unary_plus_vref arg1 -> - checkFeature() - EvalArithUnOp ((~+), (~+), (~+), (~+), (~+), (~+), (~+), (~+), (~+), (~+)) (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) + checkFeature () + + EvalArithUnOp + ((~+), (~+), (~+), (~+), (~+), (~+), (~+), (~+), (~+), (~+)) + (EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1) | SpecificUnopExpr g g.unchecked_unary_not_vref arg1 -> - checkFeature() + checkFeature () match EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g arg1 with - | Expr.Const (Const.Bool value, m, ty) -> - Expr.Const (Const.Bool (not value), m, ty) + | Expr.Const(Const.Bool value, m, ty) -> Expr.Const(Const.Bool(not value), m, ty) | expr -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), expr.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), expr.Range)) x // Detect logical operations on booleans, which are represented as a match expression - | Expr.Match (decision = TDSwitch (input = input; cases = [ TCase (DecisionTreeTest.Const (Const.Bool test), TDSuccess ([], targetNum)) ]); targets = [| TTarget (_, t0, _); TTarget (_, t1, _) |]) -> - checkFeature() + | Expr.Match( + decision = TDSwitch(input = input; cases = [ TCase(DecisionTreeTest.Const(Const.Bool test), TDSuccess([], targetNum)) ]) + targets = [| TTarget(_, t0, _); TTarget(_, t1, _) |]) -> + checkFeature () match EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g (stripDebugPoints input) with - | Expr.Const (Const.Bool value, _, _) -> - let pass, fail = - if targetNum = 0 then - t0, t1 - else - t1, t0 + | Expr.Const(Const.Bool value, _, _) -> + let pass, fail = if targetNum = 0 then t0, t1 else t1, t0 if value = test then EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g (stripDebugPoints pass) else EvalAttribArgExpr SuppressLanguageFeatureCheck.Yes g (stripDebugPoints fail) | _ -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range)) + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x - | _ -> - errorR (Error ( FSComp.SR.tastNotAConstantExpression(), x.Range)) + | _ -> + errorR (Error(FSComp.SR.tastNotAConstantExpression (), x.Range)) x -and EvaledAttribExprEquality g e1 e2 = - match e1, e2 with - | Expr.Const (c1, _, _), Expr.Const (c2, _, _) -> c1 = c2 +and EvaledAttribExprEquality g e1 e2 = + match e1, e2 with + | Expr.Const(c1, _, _), Expr.Const(c2, _, _) -> c1 = c2 | TypeOfExpr g ty1, TypeOfExpr g ty2 -> typeEquiv g ty1 ty2 | TypeDefOfExpr g ty1, TypeDefOfExpr g ty2 -> typeEquiv g ty1 ty2 | _ -> false [] let (|ConstToILFieldInit|_|) c = - match c with - | Const.SByte n -> ValueSome (ILFieldInit.Int8 n) - | Const.Int16 n -> ValueSome (ILFieldInit.Int16 n) - | Const.Int32 n -> ValueSome (ILFieldInit.Int32 n) - | Const.Int64 n -> ValueSome (ILFieldInit.Int64 n) - | Const.Byte n -> ValueSome (ILFieldInit.UInt8 n) - | Const.UInt16 n -> ValueSome (ILFieldInit.UInt16 n) - | Const.UInt32 n -> ValueSome (ILFieldInit.UInt32 n) - | Const.UInt64 n -> ValueSome (ILFieldInit.UInt64 n) - | Const.Bool n -> ValueSome (ILFieldInit.Bool n) - | Const.Char n -> ValueSome (ILFieldInit.Char (uint16 n)) - | Const.Single n -> ValueSome (ILFieldInit.Single n) - | Const.Double n -> ValueSome (ILFieldInit.Double n) - | Const.String s -> ValueSome (ILFieldInit.String s) + match c with + | Const.SByte n -> ValueSome(ILFieldInit.Int8 n) + | Const.Int16 n -> ValueSome(ILFieldInit.Int16 n) + | Const.Int32 n -> ValueSome(ILFieldInit.Int32 n) + | Const.Int64 n -> ValueSome(ILFieldInit.Int64 n) + | Const.Byte n -> ValueSome(ILFieldInit.UInt8 n) + | Const.UInt16 n -> ValueSome(ILFieldInit.UInt16 n) + | Const.UInt32 n -> ValueSome(ILFieldInit.UInt32 n) + | Const.UInt64 n -> ValueSome(ILFieldInit.UInt64 n) + | Const.Bool n -> ValueSome(ILFieldInit.Bool n) + | Const.Char n -> ValueSome(ILFieldInit.Char(uint16 n)) + | Const.Single n -> ValueSome(ILFieldInit.Single n) + | Const.Double n -> ValueSome(ILFieldInit.Double n) + | Const.String s -> ValueSome(ILFieldInit.String s) | Const.Zero -> ValueSome ILFieldInit.Null | _ -> ValueNone -let EvalLiteralExprOrAttribArg g x = - match x with - | Expr.Op (TOp.Coerce, _, [Expr.Op (TOp.Array, [elemTy], args, m)], _) - | Expr.Op (TOp.Array, [elemTy], args, m) -> - let args = args |> List.map (EvalAttribArgExpr SuppressLanguageFeatureCheck.No g) - Expr.Op (TOp.Array, [elemTy], args, m) - | _ -> - EvalAttribArgExpr SuppressLanguageFeatureCheck.No g x +let EvalLiteralExprOrAttribArg g x = + match x with + | Expr.Op(TOp.Coerce, _, [ Expr.Op(TOp.Array, [ elemTy ], args, m) ], _) + | Expr.Op(TOp.Array, [ elemTy ], args, m) -> + let args = args |> List.map (EvalAttribArgExpr SuppressLanguageFeatureCheck.No g) + Expr.Op(TOp.Array, [ elemTy ], args, m) + | _ -> EvalAttribArgExpr SuppressLanguageFeatureCheck.No g x // Take into account the fact that some "instance" members are compiled as static // members when using CompilationRepresentation.Static, or any non-virtual instance members // in a type that supports "null" as a true value. This is all members -// where ValRefIsCompiledAsInstanceMember is false but membInfo.MemberFlags.IsInstance +// where ValRefIsCompiledAsInstanceMember is false but membInfo.MemberFlags.IsInstance // is true. // // This is the right abstraction for viewing member types, but the implementation @@ -10373,151 +12739,203 @@ let GetTypeOfIntrinsicMemberInCompiledForm g (vref: ValRef) = assert (not vref.IsExtensionMember) let membInfo, valReprInfo = checkMemberValRef vref let tps, cxs, argInfos, retTy, retInfo = GetTypeOfMemberInMemberForm g vref - let argInfos = + + let argInfos = // Check if the thing is really an instance member compiled as a static member // If so, the object argument counts as a normal argument in the compiled form - if membInfo.MemberFlags.IsInstance && not (ValRefIsCompiledAsInstanceMember g vref) then - let _, origArgInfos, _, _ = GetValReprTypeInFSharpForm g valReprInfo vref.Type vref.Range + if membInfo.MemberFlags.IsInstance && not (ValRefIsCompiledAsInstanceMember g vref) then + let _, origArgInfos, _, _ = + GetValReprTypeInFSharpForm g valReprInfo vref.Type vref.Range + match origArgInfos with - | [] -> - errorR(InternalError("value does not have a valid member type", vref.Range)) + | [] -> + errorR (InternalError("value does not have a valid member type", vref.Range)) argInfos | h :: _ -> h :: argInfos - else argInfos - tps, cxs, argInfos, retTy, retInfo + else + argInfos + tps, cxs, argInfos, retTy, retInfo //-------------------------------------------------------------------------- // Tuple compilation (expressions) -//------------------------------------------------------------------------ +//------------------------------------------------------------------------ +let rec mkCompiledTuple g isStruct (argTys, args, m) = + let n = List.length argTys -let rec mkCompiledTuple g isStruct (argTys, args, m) = - let n = List.length argTys - if n <= 0 then failwith "mkCompiledTuple" - elif n < maxTuple then (mkCompiledTupleTyconRef g isStruct n, argTys, args, m) + if n <= 0 then + failwith "mkCompiledTuple" + elif n < maxTuple then + (mkCompiledTupleTyconRef g isStruct n, argTys, args, m) else let argTysA, argTysB = List.splitAfter goodTupleFields argTys let argsA, argsB = List.splitAfter goodTupleFields args - let ty8, v8 = - match argTysB, argsB with - | [ty8], [arg8] -> + + let ty8, v8 = + match argTysB, argsB with + | [ ty8 ], [ arg8 ] -> match ty8 with // if it's already been nested or ended, pass it through - | TType_app(tn, _, _) when (isCompiledTupleTyconRef g tn) -> - ty8, arg8 + | TType_app(tn, _, _) when (isCompiledTupleTyconRef g tn) -> ty8, arg8 | _ -> - let ty8enc = TType_app((if isStruct then g.struct_tuple1_tcr else g.ref_tuple1_tcr), [ty8], g.knownWithoutNull) - let v8enc = Expr.Op (TOp.Tuple (mkTupInfo isStruct), [ty8], [arg8], m) + let ty8enc = + TType_app((if isStruct then g.struct_tuple1_tcr else g.ref_tuple1_tcr), [ ty8 ], g.knownWithoutNull) + + let v8enc = Expr.Op(TOp.Tuple(mkTupInfo isStruct), [ ty8 ], [ arg8 ], m) ty8enc, v8enc - | _ -> + | _ -> let a, b, c, d = mkCompiledTuple g isStruct (argTysB, argsB, m) let ty8plus = TType_app(a, b, g.knownWithoutNull) - let v8plus = Expr.Op (TOp.Tuple (mkTupInfo isStruct), b, c, d) + let v8plus = Expr.Op(TOp.Tuple(mkTupInfo isStruct), b, c, d) ty8plus, v8plus - let argTysAB = argTysA @ [ty8] - (mkCompiledTupleTyconRef g isStruct (List.length argTysAB), argTysAB, argsA @ [v8], m) -let mkILMethodSpecForTupleItem (_g: TcGlobals) (ty: ILType) n = - mkILNonGenericInstanceMethSpecInTy(ty, (if n < goodTupleFields then "get_Item"+(n+1).ToString() else "get_Rest"), [], mkILTyvarTy (uint16 n)) + let argTysAB = argTysA @ [ ty8 ] + (mkCompiledTupleTyconRef g isStruct (List.length argTysAB), argTysAB, argsA @ [ v8 ], m) + +let mkILMethodSpecForTupleItem (_g: TcGlobals) (ty: ILType) n = + mkILNonGenericInstanceMethSpecInTy ( + ty, + (if n < goodTupleFields then + "get_Item" + (n + 1).ToString() + else + "get_Rest"), + [], + mkILTyvarTy (uint16 n) + ) -let mkILFieldSpecForTupleItem (ty: ILType) n = - mkILFieldSpecInTy (ty, (if n < goodTupleFields then "Item"+(n+1).ToString() else "Rest"), mkILTyvarTy (uint16 n)) +let mkILFieldSpecForTupleItem (ty: ILType) n = + mkILFieldSpecInTy ( + ty, + (if n < goodTupleFields then + "Item" + (n + 1).ToString() + else + "Rest"), + mkILTyvarTy (uint16 n) + ) let mkGetTupleItemN g m n (ty: ILType) isStruct expr retTy = if isStruct then - mkAsmExpr ([mkNormalLdfld (mkILFieldSpecForTupleItem ty n) ], [], [expr], [retTy], m) + mkAsmExpr ([ mkNormalLdfld (mkILFieldSpecForTupleItem ty n) ], [], [ expr ], [ retTy ], m) else - mkAsmExpr ([mkNormalCall(mkILMethodSpecForTupleItem g ty n)], [], [expr], [retTy], m) + mkAsmExpr ([ mkNormalCall (mkILMethodSpecForTupleItem g ty n) ], [], [ expr ], [ retTy ], m) /// Match an Int32 constant expression [] -let (|Int32Expr|_|) expr = - match expr with - | Expr.Const (Const.Int32 n, _, _) -> ValueSome n - | _ -> ValueNone +let (|Int32Expr|_|) expr = + match expr with + | Expr.Const(Const.Int32 n, _, _) -> ValueSome n + | _ -> ValueNone /// Match a try-finally expression [] -let (|TryFinally|_|) expr = - match expr with - | Expr.Op (TOp.TryFinally _, [_resTy], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)], _) -> ValueSome(e1, e2) +let (|TryFinally|_|) expr = + match expr with + | Expr.Op(TOp.TryFinally _, [ _resTy ], [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ], _) -> + ValueSome(e1, e2) | _ -> ValueNone - + // detect ONLY the while loops that result from compiling 'for ... in ... do ...' [] -let (|WhileLoopForCompiledForEachExpr|_|) expr = - match expr with - | Expr.Op (TOp.While (spInWhile, WhileLoopForCompiledForEachExprMarker), _, [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)], m) -> - ValueSome(spInWhile, e1, e2, m) +let (|WhileLoopForCompiledForEachExpr|_|) expr = + match expr with + | Expr.Op(TOp.While(spInWhile, WhileLoopForCompiledForEachExprMarker), + _, + [ Expr.Lambda(_, _, _, [ _ ], e1, _, _); Expr.Lambda(_, _, _, [ _ ], e2, _, _) ], + m) -> ValueSome(spInWhile, e1, e2, m) | _ -> ValueNone - + [] -let (|Let|_|) expr = - match expr with - | Expr.Let (TBind(v, e1, sp), e2, _, _) -> ValueSome(v, e1, sp, e2) +let (|Let|_|) expr = + match expr with + | Expr.Let(TBind(v, e1, sp), e2, _, _) -> ValueSome(v, e1, sp, e2) | _ -> ValueNone [] -let (|RangeInt32Step|_|) g expr = - match expr with - // detect 'n .. m' - | Expr.App (Expr.Val (vf, _, _), _, [tyarg], [startExpr;finishExpr], _) - when valRefEq g vf g.range_op_vref && typeEquiv g tyarg g.int_ty -> ValueSome(startExpr, 1, finishExpr) - +let (|RangeInt32Step|_|) g expr = + match expr with + // detect 'n .. m' + | Expr.App(Expr.Val(vf, _, _), _, [ tyarg ], [ startExpr; finishExpr ], _) when + valRefEq g vf g.range_op_vref && typeEquiv g tyarg g.int_ty + -> + ValueSome(startExpr, 1, finishExpr) + // detect (RangeInt32 startExpr N finishExpr), the inlined/compiled form of 'n .. m' and 'n .. N .. m' - | Expr.App (Expr.Val (vf, _, _), _, [], [startExpr; Int32Expr n; finishExpr], _) - when valRefEq g vf g.range_int32_op_vref -> ValueSome(startExpr, n, finishExpr) + | Expr.App(Expr.Val(vf, _, _), _, [], [ startExpr; Int32Expr n; finishExpr ], _) when valRefEq g vf g.range_int32_op_vref -> + ValueSome(startExpr, n, finishExpr) | _ -> ValueNone [] -let (|GetEnumeratorCall|_|) expr = - match expr with - | Expr.Op (TOp.ILCall ( _, _, _, _, _, _, _, ilMethodRef, _, _, _), _, [Expr.Val (vref, _, _) | Expr.Op (_, _, [Expr.Val (vref, ValUseFlag.NormalValUse, _)], _) ], _) -> - if ilMethodRef.Name = "GetEnumerator" then ValueSome vref - else ValueNone - | _ -> ValueNone +let (|GetEnumeratorCall|_|) expr = + match expr with + | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethodRef, _, _, _), + _, + [ Expr.Val(vref, _, _) | Expr.Op(_, _, [ Expr.Val(vref, ValUseFlag.NormalValUse, _) ], _) ], + _) -> + if ilMethodRef.Name = "GetEnumerator" then + ValueSome vref + else + ValueNone + | _ -> ValueNone // This code matches exactly the output of TcForEachExpr [] -let (|CompiledForEachExpr|_|) g expr = +let (|CompiledForEachExpr|_|) g expr = match expr with - | Let (enumerableVar, enumerableExpr, spFor, - Let (enumeratorVar, GetEnumeratorCall enumerableVar2, _enumeratorBind, - TryFinally (WhileLoopForCompiledForEachExpr (spInWhile, _, (Let (elemVar, _, _, bodyExpr) as elemLet), _), _))) - // Apply correctness conditions to ensure this really is a compiled for-each expression. - when valRefEq g (mkLocalValRef enumerableVar) enumerableVar2 && - enumerableVar.IsCompilerGenerated && - enumeratorVar.IsCompilerGenerated && - (let fvs = (freeInExpr CollectLocals bodyExpr) - not (Zset.contains enumerableVar fvs.FreeLocals) && - not (Zset.contains enumeratorVar fvs.FreeLocals)) -> + | Let(enumerableVar, + enumerableExpr, + spFor, + Let(enumeratorVar, + GetEnumeratorCall enumerableVar2, + _enumeratorBind, + TryFinally(WhileLoopForCompiledForEachExpr(spInWhile, _, (Let(elemVar, _, _, bodyExpr) as elemLet), _), _))) when + // Apply correctness conditions to ensure this really is a compiled for-each expression. + valRefEq g (mkLocalValRef enumerableVar) enumerableVar2 + && enumerableVar.IsCompilerGenerated + && enumeratorVar.IsCompilerGenerated + && (let fvs = (freeInExpr CollectLocals bodyExpr) + + not (Zset.contains enumerableVar fvs.FreeLocals) + && not (Zset.contains enumeratorVar fvs.FreeLocals)) + -> // Extract useful ranges let mBody = bodyExpr.Range let mWholeExpr = expr.Range let mIn = elemLet.Range - let mFor = match spFor with DebugPointAtBinding.Yes mFor -> mFor | _ -> enumerableExpr.Range - let spIn, mIn = match spInWhile with DebugPointAtWhile.Yes mIn -> DebugPointAtInOrTo.Yes mIn, mIn | _ -> DebugPointAtInOrTo.No, mIn - let spInWhile = match spIn with DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + let mFor = + match spFor with + | DebugPointAtBinding.Yes mFor -> mFor + | _ -> enumerableExpr.Range + + let spIn, mIn = + match spInWhile with + | DebugPointAtWhile.Yes mIn -> DebugPointAtInOrTo.Yes mIn, mIn + | _ -> DebugPointAtInOrTo.No, mIn + + let spInWhile = + match spIn with + | DebugPointAtInOrTo.Yes m -> DebugPointAtWhile.Yes m + | DebugPointAtInOrTo.No -> DebugPointAtWhile.No + let enumerableTy = tyOfExpr g enumerableExpr - ValueSome (enumerableTy, enumerableExpr, elemVar, bodyExpr, (mBody, spFor, spIn, mFor, mIn, spInWhile, mWholeExpr)) - | _ -> ValueNone + ValueSome(enumerableTy, enumerableExpr, elemVar, bodyExpr, (mBody, spFor, spIn, mFor, mIn, spInWhile, mWholeExpr)) + | _ -> ValueNone [] -let (|CompiledInt32RangeForEachExpr|_|) g expr = +let (|CompiledInt32RangeForEachExpr|_|) g expr = match expr with | CompiledForEachExpr g (_, RangeInt32Step g (startExpr, step, finishExpr), elemVar, bodyExpr, ranges) -> - ValueSome (startExpr, step, finishExpr, elemVar, bodyExpr, ranges) + ValueSome(startExpr, step, finishExpr, elemVar, bodyExpr, ranges) | _ -> ValueNone [] let (|ValApp|_|) g vref expr = match expr with - | Expr.App (Expr.Val (vref2, _, _), _f0ty, tyargs, args, m) when valRefEq g vref vref2 -> ValueSome (tyargs, args, m) + | Expr.App(Expr.Val(vref2, _, _), _f0ty, tyargs, args, m) when valRefEq g vref vref2 -> ValueSome(tyargs, args, m) | _ -> ValueNone [] @@ -10602,16 +13020,16 @@ module IntegralConst = /// Returns the absolute value of the given integral constant. let abs c = match c with - | Const.Int32 Int32.MinValue -> Const.UInt32 (uint Int32.MaxValue + 1u) - | Const.Int64 Int64.MinValue -> Const.UInt64 (uint64 Int64.MaxValue + 1UL) - | Const.IntPtr Int64.MinValue -> Const.UIntPtr (uint64 Int64.MaxValue + 1UL) - | Const.Int16 Int16.MinValue -> Const.UInt16 (uint16 Int16.MaxValue + 1us) - | Const.SByte SByte.MinValue -> Const.Byte (byte SByte.MaxValue + 1uy) - | Const.Int32 v -> Const.Int32 (abs v) - | Const.Int64 v -> Const.Int64 (abs v) - | Const.IntPtr v -> Const.IntPtr (abs v) - | Const.Int16 v -> Const.Int16 (abs v) - | Const.SByte v -> Const.SByte (abs v) + | Const.Int32 Int32.MinValue -> Const.UInt32(uint Int32.MaxValue + 1u) + | Const.Int64 Int64.MinValue -> Const.UInt64(uint64 Int64.MaxValue + 1UL) + | Const.IntPtr Int64.MinValue -> Const.UIntPtr(uint64 Int64.MaxValue + 1UL) + | Const.Int16 Int16.MinValue -> Const.UInt16(uint16 Int16.MaxValue + 1us) + | Const.SByte SByte.MinValue -> Const.Byte(byte SByte.MaxValue + 1uy) + | Const.Int32 v -> Const.Int32(abs v) + | Const.Int64 v -> Const.Int64(abs v) + | Const.IntPtr v -> Const.IntPtr(abs v) + | Const.Int16 v -> Const.Int16(abs v) + | Const.SByte v -> Const.SByte(abs v) | _ -> c /// start..finish @@ -10619,21 +13037,35 @@ module IntegralConst = [] let (|IntegralRange|_|) g expr = match expr with - | ValApp g g.range_int32_op_vref ([], [start; step; finish], _) -> ValueSome (g.int32_ty, (start, step, finish)) - | ValApp g g.range_int64_op_vref ([], [start; step; finish], _) -> ValueSome (g.int64_ty, (start, step, finish)) - | ValApp g g.range_uint64_op_vref ([], [start; step; finish], _) -> ValueSome (g.uint64_ty, (start, step, finish)) - | ValApp g g.range_uint32_op_vref ([], [start; step; finish], _) -> ValueSome (g.uint32_ty, (start, step, finish)) - | ValApp g g.range_nativeint_op_vref ([], [start; step; finish], _) -> ValueSome (g.nativeint_ty, (start, step, finish)) - | ValApp g g.range_unativeint_op_vref ([], [start; step; finish], _) -> ValueSome (g.unativeint_ty, (start, step, finish)) - | ValApp g g.range_int16_op_vref ([], [start; step; finish], _) -> ValueSome (g.int16_ty, (start, step, finish)) - | ValApp g g.range_uint16_op_vref ([], [start; step; finish], _) -> ValueSome (g.uint16_ty, (start, step, finish)) - | ValApp g g.range_sbyte_op_vref ([], [start; step; finish], _) -> ValueSome (g.sbyte_ty, (start, step, finish)) - | ValApp g g.range_byte_op_vref ([], [start; step; finish], _) -> ValueSome (g.byte_ty, (start, step, finish)) - | ValApp g g.range_char_op_vref ([], [start; finish], _) -> ValueSome (g.char_ty, (start, Expr.Const (Const.Char '\001', Text.Range.range0, g.char_ty), finish)) - | ValApp g g.range_op_vref (ty :: _, [start; finish], _) when isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty -> ValueSome (ty, (start, mkTypedOne g Text.Range.range0 ty, finish)) - | ValApp g g.range_step_op_vref ([ty; ty2], [start; step; finish], _) when typeEquiv g ty ty2 && (isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty) -> ValueSome (ty, (start, step, finish)) - | ValApp g g.range_generic_op_vref ([ty; ty2], [_one; _add; start; finish], _) when typeEquiv g ty ty2 && (isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty) -> ValueSome (ty, (start, mkTypedOne g Text.Range.range0 ty, finish)) - | ValApp g g.range_step_generic_op_vref ([ty; ty2], [_zero; _add; start; step; finish], _) when typeEquiv g ty ty2 && (isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty) -> ValueSome (ty, (start, step, finish)) + | ValApp g g.range_int32_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.int32_ty, (start, step, finish)) + | ValApp g g.range_int64_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.int64_ty, (start, step, finish)) + | ValApp g g.range_uint64_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.uint64_ty, (start, step, finish)) + | ValApp g g.range_uint32_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.uint32_ty, (start, step, finish)) + | ValApp g g.range_nativeint_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.nativeint_ty, (start, step, finish)) + | ValApp g g.range_unativeint_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.unativeint_ty, (start, step, finish)) + | ValApp g g.range_int16_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.int16_ty, (start, step, finish)) + | ValApp g g.range_uint16_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.uint16_ty, (start, step, finish)) + | ValApp g g.range_sbyte_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.sbyte_ty, (start, step, finish)) + | ValApp g g.range_byte_op_vref ([], [ start; step; finish ], _) -> ValueSome(g.byte_ty, (start, step, finish)) + | ValApp g g.range_char_op_vref ([], [ start; finish ], _) -> + ValueSome(g.char_ty, (start, Expr.Const(Const.Char '\001', Text.Range.range0, g.char_ty), finish)) + | ValApp g g.range_op_vref (ty :: _, [ start; finish ], _) when isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty -> + ValueSome(ty, (start, mkTypedOne g Text.Range.range0 ty, finish)) + | ValApp g g.range_step_op_vref ([ ty; ty2 ], [ start; step; finish ], _) when + typeEquiv g ty ty2 + && (isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty) + -> + ValueSome(ty, (start, step, finish)) + | ValApp g g.range_generic_op_vref ([ ty; ty2 ], [ _one; _add; start; finish ], _) when + typeEquiv g ty ty2 + && (isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty) + -> + ValueSome(ty, (start, mkTypedOne g Text.Range.range0 ty, finish)) + | ValApp g g.range_step_generic_op_vref ([ ty; ty2 ], [ _zero; _add; start; step; finish ], _) when + typeEquiv g ty ty2 + && (isIntegerTy g ty || typeEquivAux EraseMeasures g ty g.char_ty) + -> + ValueSome(ty, (start, step, finish)) | _ -> ValueNone /// 5..1 @@ -10644,13 +13076,25 @@ let (|IntegralRange|_|) g expr = [] let (|EmptyRange|_|) (start, step, finish) = match start, step, finish with - | Expr.Const (value = Const.Int32 start), Expr.Const (value = Const.Int32 step), Expr.Const (value = Const.Int32 finish) when finish < start && step > 0 || finish > start && step < 0 -> ValueSome EmptyRange - | Expr.Const (value = Const.Int64 start), Expr.Const (value = Const.Int64 step), Expr.Const (value = Const.Int64 finish) when finish < start && step > 0L || finish > start && step < 0L -> ValueSome EmptyRange - | Expr.Const (value = Const.UInt64 start), Expr.Const (value = Const.UInt64 _), Expr.Const (value = Const.UInt64 finish) when finish < start -> ValueSome EmptyRange - | Expr.Const (value = Const.UInt32 start), Expr.Const (value = Const.UInt32 _), Expr.Const (value = Const.UInt32 finish) when finish < start -> ValueSome EmptyRange + | Expr.Const(value = Const.Int32 start), Expr.Const(value = Const.Int32 step), Expr.Const(value = Const.Int32 finish) when + finish < start && step > 0 || finish > start && step < 0 + -> + ValueSome EmptyRange + | Expr.Const(value = Const.Int64 start), Expr.Const(value = Const.Int64 step), Expr.Const(value = Const.Int64 finish) when + finish < start && step > 0L || finish > start && step < 0L + -> + ValueSome EmptyRange + | Expr.Const(value = Const.UInt64 start), Expr.Const(value = Const.UInt64 _), Expr.Const(value = Const.UInt64 finish) when + finish < start + -> + ValueSome EmptyRange + | Expr.Const(value = Const.UInt32 start), Expr.Const(value = Const.UInt32 _), Expr.Const(value = Const.UInt32 finish) when + finish < start + -> + ValueSome EmptyRange // sizeof is not constant, so |𝑐| ≥ 0x80000000n cannot be treated as a constant. - | Expr.Const (value = Const.IntPtr start), Expr.Const (value = Const.IntPtr step), Expr.Const (value = Const.IntPtr finish) when + | Expr.Const(value = Const.IntPtr start), Expr.Const(value = Const.IntPtr step), Expr.Const(value = Const.IntPtr finish) when uint64 start < 0x80000000UL && uint64 step < 0x80000000UL && uint64 finish < 0x80000000UL @@ -10659,7 +13103,7 @@ let (|EmptyRange|_|) (start, step, finish) = ValueSome EmptyRange // sizeof is not constant, so |𝑐| > 0xffffffffun cannot be treated as a constant. - | Expr.Const (value = Const.UIntPtr start), Expr.Const (value = Const.UIntPtr step), Expr.Const (value = Const.UIntPtr finish) when + | Expr.Const(value = Const.UIntPtr start), Expr.Const(value = Const.UIntPtr step), Expr.Const(value = Const.UIntPtr finish) when start <= 0xffffffffUL && step <= 0xffffffffUL && finish <= 0xffffffffUL @@ -10667,11 +13111,22 @@ let (|EmptyRange|_|) (start, step, finish) = -> ValueSome EmptyRange - | Expr.Const (value = Const.Int16 start), Expr.Const (value = Const.Int16 step), Expr.Const (value = Const.Int16 finish) when finish < start && step > 0s || finish > start && step < 0s -> ValueSome EmptyRange - | Expr.Const (value = Const.UInt16 start), Expr.Const (value = Const.UInt16 _), Expr.Const (value = Const.UInt16 finish) when finish < start -> ValueSome EmptyRange - | Expr.Const (value = Const.SByte start), Expr.Const (value = Const.SByte step), Expr.Const (value = Const.SByte finish) when finish < start && step > 0y || finish > start && step < 0y -> ValueSome EmptyRange - | Expr.Const (value = Const.Byte start), Expr.Const (value = Const.Byte _), Expr.Const (value = Const.Byte finish) when finish < start -> ValueSome EmptyRange - | Expr.Const (value = Const.Char start), Expr.Const (value = Const.Char _), Expr.Const (value = Const.Char finish) when finish < start -> ValueSome EmptyRange + | Expr.Const(value = Const.Int16 start), Expr.Const(value = Const.Int16 step), Expr.Const(value = Const.Int16 finish) when + finish < start && step > 0s || finish > start && step < 0s + -> + ValueSome EmptyRange + | Expr.Const(value = Const.UInt16 start), Expr.Const(value = Const.UInt16 _), Expr.Const(value = Const.UInt16 finish) when + finish < start + -> + ValueSome EmptyRange + | Expr.Const(value = Const.SByte start), Expr.Const(value = Const.SByte step), Expr.Const(value = Const.SByte finish) when + finish < start && step > 0y || finish > start && step < 0y + -> + ValueSome EmptyRange + | Expr.Const(value = Const.Byte start), Expr.Const(value = Const.Byte _), Expr.Const(value = Const.Byte finish) when finish < start -> + ValueSome EmptyRange + | Expr.Const(value = Const.Char start), Expr.Const(value = Const.Char _), Expr.Const(value = Const.Char finish) when finish < start -> + ValueSome EmptyRange | _ -> ValueNone /// Note: this assumes that an empty range has already been checked for @@ -10680,65 +13135,107 @@ let (|EmptyRange|_|) (start, step, finish) = let (|ConstCount|_|) (start, step, finish) = match start, step, finish with // The count for these ranges is 2⁶⁴ + 1. We must handle such ranges at runtime. - | Expr.Const (value = Const.Int64 Int64.MinValue), Expr.Const (value = Const.Int64 1L), Expr.Const (value = Const.Int64 Int64.MaxValue) - | Expr.Const (value = Const.Int64 Int64.MaxValue), Expr.Const (value = Const.Int64 -1L), Expr.Const (value = Const.Int64 Int64.MinValue) - | Expr.Const (value = Const.UInt64 UInt64.MinValue), Expr.Const (value = Const.UInt64 1UL), Expr.Const (value = Const.UInt64 UInt64.MaxValue) - | Expr.Const (value = Const.IntPtr Int64.MinValue), Expr.Const (value = Const.IntPtr 1L), Expr.Const (value = Const.IntPtr Int64.MaxValue) - | Expr.Const (value = Const.IntPtr Int64.MaxValue), Expr.Const (value = Const.IntPtr -1L), Expr.Const (value = Const.IntPtr Int64.MinValue) - | Expr.Const (value = Const.UIntPtr UInt64.MinValue), Expr.Const (value = Const.UIntPtr 1UL), Expr.Const (value = Const.UIntPtr UInt64.MaxValue) -> ValueNone + | Expr.Const(value = Const.Int64 Int64.MinValue), Expr.Const(value = Const.Int64 1L), Expr.Const(value = Const.Int64 Int64.MaxValue) + | Expr.Const(value = Const.Int64 Int64.MaxValue), Expr.Const(value = Const.Int64 -1L), Expr.Const(value = Const.Int64 Int64.MinValue) + | Expr.Const(value = Const.UInt64 UInt64.MinValue), + Expr.Const(value = Const.UInt64 1UL), + Expr.Const(value = Const.UInt64 UInt64.MaxValue) + | Expr.Const(value = Const.IntPtr Int64.MinValue), Expr.Const(value = Const.IntPtr 1L), Expr.Const(value = Const.IntPtr Int64.MaxValue) + | Expr.Const(value = Const.IntPtr Int64.MaxValue), Expr.Const(value = Const.IntPtr -1L), Expr.Const(value = Const.IntPtr Int64.MinValue) + | Expr.Const(value = Const.UIntPtr UInt64.MinValue), + Expr.Const(value = Const.UIntPtr 1UL), + Expr.Const(value = Const.UIntPtr UInt64.MaxValue) -> ValueNone // We must special-case a step of Int64.MinValue, since we cannot call abs on it. - | Expr.Const (value = Const.Int64 start), Expr.Const (value = Const.Int64 Int64.MinValue), Expr.Const (value = Const.Int64 finish) when start <= finish -> ValueSome (Const.UInt64 ((uint64 finish - uint64 start) / (uint64 Int64.MaxValue + 1UL) + 1UL)) - | Expr.Const (value = Const.Int64 start), Expr.Const (value = Const.Int64 Int64.MinValue), Expr.Const (value = Const.Int64 finish) -> ValueSome (Const.UInt64 ((uint64 start - uint64 finish) / (uint64 Int64.MaxValue + 1UL) + 1UL)) - | Expr.Const (value = Const.IntPtr start), Expr.Const (value = Const.IntPtr Int64.MinValue), Expr.Const (value = Const.IntPtr finish) when start <= finish -> ValueSome (Const.UIntPtr ((uint64 start - uint64 finish) / (uint64 Int64.MaxValue + 1UL) + 1UL)) - | Expr.Const (value = Const.IntPtr start), Expr.Const (value = Const.IntPtr Int64.MinValue), Expr.Const (value = Const.IntPtr finish) -> ValueSome (Const.UIntPtr ((uint64 start - uint64 finish) / (uint64 Int64.MaxValue + 1UL) + 1UL)) + | Expr.Const(value = Const.Int64 start), Expr.Const(value = Const.Int64 Int64.MinValue), Expr.Const(value = Const.Int64 finish) when + start <= finish + -> + ValueSome(Const.UInt64((uint64 finish - uint64 start) / (uint64 Int64.MaxValue + 1UL) + 1UL)) + | Expr.Const(value = Const.Int64 start), Expr.Const(value = Const.Int64 Int64.MinValue), Expr.Const(value = Const.Int64 finish) -> + ValueSome(Const.UInt64((uint64 start - uint64 finish) / (uint64 Int64.MaxValue + 1UL) + 1UL)) + | Expr.Const(value = Const.IntPtr start), Expr.Const(value = Const.IntPtr Int64.MinValue), Expr.Const(value = Const.IntPtr finish) when + start <= finish + -> + ValueSome(Const.UIntPtr((uint64 start - uint64 finish) / (uint64 Int64.MaxValue + 1UL) + 1UL)) + | Expr.Const(value = Const.IntPtr start), Expr.Const(value = Const.IntPtr Int64.MinValue), Expr.Const(value = Const.IntPtr finish) -> + ValueSome(Const.UIntPtr((uint64 start - uint64 finish) / (uint64 Int64.MaxValue + 1UL) + 1UL)) - | Expr.Const (value = Const.Int64 start), Expr.Const (value = Const.Int64 step), Expr.Const (value = Const.Int64 finish) when start <= finish -> ValueSome (Const.UInt64 ((uint64 finish - uint64 start) / uint64 (abs step) + 1UL)) - | Expr.Const (value = Const.Int64 start), Expr.Const (value = Const.Int64 step), Expr.Const (value = Const.Int64 finish) -> ValueSome (Const.UInt64 ((uint64 start - uint64 finish) / uint64 (abs step) + 1UL)) + | Expr.Const(value = Const.Int64 start), Expr.Const(value = Const.Int64 step), Expr.Const(value = Const.Int64 finish) when + start <= finish + -> + ValueSome(Const.UInt64((uint64 finish - uint64 start) / uint64 (abs step) + 1UL)) + | Expr.Const(value = Const.Int64 start), Expr.Const(value = Const.Int64 step), Expr.Const(value = Const.Int64 finish) -> + ValueSome(Const.UInt64((uint64 start - uint64 finish) / uint64 (abs step) + 1UL)) // sizeof is not constant, so |𝑐| ≥ 0x80000000n cannot be treated as a constant. - | Expr.Const (value = Const.IntPtr start), Expr.Const (value = Const.IntPtr step), Expr.Const (value = Const.IntPtr finish) when + | Expr.Const(value = Const.IntPtr start), Expr.Const(value = Const.IntPtr step), Expr.Const(value = Const.IntPtr finish) when uint64 start < 0x80000000UL && uint64 step < 0x80000000UL && uint64 finish < 0x80000000UL && start <= finish -> - ValueSome (Const.UIntPtr ((uint64 finish - uint64 start) / uint64 (abs step) + 1UL)) + ValueSome(Const.UIntPtr((uint64 finish - uint64 start) / uint64 (abs step) + 1UL)) - | Expr.Const (value = Const.IntPtr start), Expr.Const (value = Const.IntPtr step), Expr.Const (value = Const.IntPtr finish) when + | Expr.Const(value = Const.IntPtr start), Expr.Const(value = Const.IntPtr step), Expr.Const(value = Const.IntPtr finish) when uint64 start < 0x80000000UL && uint64 step < 0x80000000UL && uint64 finish < 0x80000000UL -> - ValueSome (Const.UIntPtr ((uint64 start - uint64 finish) / uint64 (abs step) + 1UL)) + ValueSome(Const.UIntPtr((uint64 start - uint64 finish) / uint64 (abs step) + 1UL)) - | Expr.Const (value = Const.Int32 start), Expr.Const (value = Const.Int32 step), Expr.Const (value = Const.Int32 finish) when start <= finish -> ValueSome (Const.UInt64 ((uint64 finish - uint64 start) / uint64 (abs (int64 step)) + 1UL)) - | Expr.Const (value = Const.Int32 start), Expr.Const (value = Const.Int32 step), Expr.Const (value = Const.Int32 finish) -> ValueSome (Const.UInt64 ((uint64 start - uint64 finish) / uint64 (abs (int64 step)) + 1UL)) + | Expr.Const(value = Const.Int32 start), Expr.Const(value = Const.Int32 step), Expr.Const(value = Const.Int32 finish) when + start <= finish + -> + ValueSome(Const.UInt64((uint64 finish - uint64 start) / uint64 (abs (int64 step)) + 1UL)) + | Expr.Const(value = Const.Int32 start), Expr.Const(value = Const.Int32 step), Expr.Const(value = Const.Int32 finish) -> + ValueSome(Const.UInt64((uint64 start - uint64 finish) / uint64 (abs (int64 step)) + 1UL)) - | Expr.Const (value = Const.Int16 start), Expr.Const (value = Const.Int16 step), Expr.Const (value = Const.Int16 finish) when start <= finish -> ValueSome (Const.UInt32 ((uint finish - uint start) / uint (abs (int step)) + 1u)) - | Expr.Const (value = Const.Int16 start), Expr.Const (value = Const.Int16 step), Expr.Const (value = Const.Int16 finish) -> ValueSome (Const.UInt32 ((uint start - uint finish) / uint (abs (int step)) + 1u)) + | Expr.Const(value = Const.Int16 start), Expr.Const(value = Const.Int16 step), Expr.Const(value = Const.Int16 finish) when + start <= finish + -> + ValueSome(Const.UInt32((uint finish - uint start) / uint (abs (int step)) + 1u)) + | Expr.Const(value = Const.Int16 start), Expr.Const(value = Const.Int16 step), Expr.Const(value = Const.Int16 finish) -> + ValueSome(Const.UInt32((uint start - uint finish) / uint (abs (int step)) + 1u)) - | Expr.Const (value = Const.SByte start), Expr.Const (value = Const.SByte step), Expr.Const (value = Const.SByte finish) when start <= finish -> ValueSome (Const.UInt16 ((uint16 finish - uint16 start) / uint16 (abs (int16 step)) + 1us)) - | Expr.Const (value = Const.SByte start), Expr.Const (value = Const.SByte step), Expr.Const (value = Const.SByte finish) -> ValueSome (Const.UInt16 ((uint16 start - uint16 finish) / uint16 (abs (int16 step)) + 1us)) + | Expr.Const(value = Const.SByte start), Expr.Const(value = Const.SByte step), Expr.Const(value = Const.SByte finish) when + start <= finish + -> + ValueSome(Const.UInt16((uint16 finish - uint16 start) / uint16 (abs (int16 step)) + 1us)) + | Expr.Const(value = Const.SByte start), Expr.Const(value = Const.SByte step), Expr.Const(value = Const.SByte finish) -> + ValueSome(Const.UInt16((uint16 start - uint16 finish) / uint16 (abs (int16 step)) + 1us)) // sizeof is not constant, so |𝑐| > 0xffffffffun cannot be treated as a constant. - | Expr.Const (value = Const.UIntPtr start), Expr.Const (value = Const.UIntPtr step), Expr.Const (value = Const.UIntPtr finish) when - start <= 0xffffffffUL - && step <= 0xffffffffUL - && finish <= 0xffffffffUL + | Expr.Const(value = Const.UIntPtr start), Expr.Const(value = Const.UIntPtr step), Expr.Const(value = Const.UIntPtr finish) when + start <= 0xffffffffUL && step <= 0xffffffffUL && finish <= 0xffffffffUL + -> + ValueSome(Const.UIntPtr((finish - start) / step + 1UL)) + + | Expr.Const(value = Const.UInt64 start), Expr.Const(value = Const.UInt64 step), Expr.Const(value = Const.UInt64 finish) when + start <= finish + -> + ValueSome(Const.UInt64((finish - start) / step + 1UL)) + | Expr.Const(value = Const.UInt64 start), Expr.Const(value = Const.UInt64 step), Expr.Const(value = Const.UInt64 finish) -> + ValueSome(Const.UInt64((start - finish) / step + 1UL)) + | Expr.Const(value = Const.UInt32 start), Expr.Const(value = Const.UInt32 step), Expr.Const(value = Const.UInt32 finish) when + start <= finish -> - ValueSome (Const.UIntPtr ((finish - start) / step + 1UL)) - - | Expr.Const (value = Const.UInt64 start), Expr.Const (value = Const.UInt64 step), Expr.Const (value = Const.UInt64 finish) when start <= finish -> ValueSome (Const.UInt64 ((finish - start) / step + 1UL)) - | Expr.Const (value = Const.UInt64 start), Expr.Const (value = Const.UInt64 step), Expr.Const (value = Const.UInt64 finish) -> ValueSome (Const.UInt64 ((start - finish) / step + 1UL)) - | Expr.Const (value = Const.UInt32 start), Expr.Const (value = Const.UInt32 step), Expr.Const (value = Const.UInt32 finish) when start <= finish -> ValueSome (Const.UInt64 (uint64 (finish - start) / uint64 step + 1UL)) - | Expr.Const (value = Const.UInt32 start), Expr.Const (value = Const.UInt32 step), Expr.Const (value = Const.UInt32 finish) -> ValueSome (Const.UInt64 (uint64 (start - finish) / uint64 step + 1UL)) - | Expr.Const (value = Const.UInt16 start), Expr.Const (value = Const.UInt16 step), Expr.Const (value = Const.UInt16 finish) when start <= finish -> ValueSome (Const.UInt32 (uint (finish - start) / uint step + 1u)) - | Expr.Const (value = Const.UInt16 start), Expr.Const (value = Const.UInt16 step), Expr.Const (value = Const.UInt16 finish) -> ValueSome (Const.UInt32 (uint (start - finish) / uint step + 1u)) - | Expr.Const (value = Const.Byte start), Expr.Const (value = Const.Byte step), Expr.Const (value = Const.Byte finish) when start <= finish -> ValueSome (Const.UInt16 (uint16 (finish - start) / uint16 step + 1us)) - | Expr.Const (value = Const.Byte start), Expr.Const (value = Const.Byte step), Expr.Const (value = Const.Byte finish) -> ValueSome (Const.UInt16 (uint16 (start - finish) / uint16 step + 1us)) - | Expr.Const (value = Const.Char start), Expr.Const (value = Const.Char step), Expr.Const (value = Const.Char finish) when start <= finish -> ValueSome (Const.UInt32 (uint (finish - start) / uint step + 1u)) - | Expr.Const (value = Const.Char start), Expr.Const (value = Const.Char step), Expr.Const (value = Const.Char finish) -> ValueSome (Const.UInt32 (uint (start - finish) / uint step + 1u)) + ValueSome(Const.UInt64(uint64 (finish - start) / uint64 step + 1UL)) + | Expr.Const(value = Const.UInt32 start), Expr.Const(value = Const.UInt32 step), Expr.Const(value = Const.UInt32 finish) -> + ValueSome(Const.UInt64(uint64 (start - finish) / uint64 step + 1UL)) + | Expr.Const(value = Const.UInt16 start), Expr.Const(value = Const.UInt16 step), Expr.Const(value = Const.UInt16 finish) when + start <= finish + -> + ValueSome(Const.UInt32(uint (finish - start) / uint step + 1u)) + | Expr.Const(value = Const.UInt16 start), Expr.Const(value = Const.UInt16 step), Expr.Const(value = Const.UInt16 finish) -> + ValueSome(Const.UInt32(uint (start - finish) / uint step + 1u)) + | Expr.Const(value = Const.Byte start), Expr.Const(value = Const.Byte step), Expr.Const(value = Const.Byte finish) when start <= finish -> + ValueSome(Const.UInt16(uint16 (finish - start) / uint16 step + 1us)) + | Expr.Const(value = Const.Byte start), Expr.Const(value = Const.Byte step), Expr.Const(value = Const.Byte finish) -> + ValueSome(Const.UInt16(uint16 (start - finish) / uint16 step + 1us)) + | Expr.Const(value = Const.Char start), Expr.Const(value = Const.Char step), Expr.Const(value = Const.Char finish) when start <= finish -> + ValueSome(Const.UInt32(uint (finish - start) / uint step + 1u)) + | Expr.Const(value = Const.Char start), Expr.Const(value = Const.Char step), Expr.Const(value = Const.Char finish) -> + ValueSome(Const.UInt32(uint (start - finish) / uint step + 1u)) | _ -> ValueNone @@ -10774,36 +13271,51 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = let rangeExpr = match rangeExpr with // Type-specific range op (RangeInt32, etc.). - | Expr.App (funcExpr, formalType, tyargs, [_start; _step; _finish], m) -> Expr.App (funcExpr, formalType, tyargs, [start; step; finish], m) + | Expr.App(funcExpr, formalType, tyargs, [ _start; _step; _finish ], m) -> + Expr.App(funcExpr, formalType, tyargs, [ start; step; finish ], m) // Generic range–step op (RangeStepGeneric). - | Expr.App (funcExpr, formalType, tyargs, [zero; add; _start; _step; _finish], m) -> Expr.App (funcExpr, formalType, tyargs, [zero; add; start; step; finish], m) - | _ -> error (InternalError ($"Unrecognized range function application '{rangeExpr}'.", m)) + | Expr.App(funcExpr, formalType, tyargs, [ zero; add; _start; _step; _finish ], m) -> + Expr.App(funcExpr, formalType, tyargs, [ zero; add; start; step; finish ], m) + | _ -> error (InternalError($"Unrecognized range function application '{rangeExpr}'.", m)) - mkSequential - m - rangeExpr - (mkUnit g m) + mkSequential m rangeExpr (mkUnit g m) let mkSignednessAppropriateClt ty e1 e2 = if isSignedIntegerTy g ty then mkILAsmClt g m e1 e2 else - mkAsmExpr ([AI_clt_un], [], [e1; e2], [g.bool_ty], m) + mkAsmExpr ([ AI_clt_un ], [], [ e1; e2 ], [ g.bool_ty ], m) let unsignedEquivalent ty = - if typeEquivAux EraseMeasures g ty g.int64_ty then g.uint64_ty - elif typeEquivAux EraseMeasures g ty g.int32_ty then g.uint32_ty - elif typeEquivAux EraseMeasures g ty g.int16_ty then g.uint16_ty - elif typeEquivAux EraseMeasures g ty g.sbyte_ty then g.byte_ty - else ty + if typeEquivAux EraseMeasures g ty g.int64_ty then + g.uint64_ty + elif typeEquivAux EraseMeasures g ty g.int32_ty then + g.uint32_ty + elif typeEquivAux EraseMeasures g ty g.int16_ty then + g.uint16_ty + elif typeEquivAux EraseMeasures g ty g.sbyte_ty then + g.byte_ty + else + ty /// Find the unsigned type with twice the width of the given type, if available. let nextWidestUnsignedTy ty = - if typeEquivAux EraseMeasures g ty g.int64_ty || typeEquivAux EraseMeasures g ty g.int32_ty || typeEquivAux EraseMeasures g ty g.uint32_ty then + if + typeEquivAux EraseMeasures g ty g.int64_ty + || typeEquivAux EraseMeasures g ty g.int32_ty + || typeEquivAux EraseMeasures g ty g.uint32_ty + then g.uint64_ty - elif typeEquivAux EraseMeasures g ty g.int16_ty || typeEquivAux EraseMeasures g ty g.uint16_ty || typeEquivAux EraseMeasures g ty g.char_ty then + elif + typeEquivAux EraseMeasures g ty g.int16_ty + || typeEquivAux EraseMeasures g ty g.uint16_ty + || typeEquivAux EraseMeasures g ty g.char_ty + then g.uint32_ty - elif typeEquivAux EraseMeasures g ty g.sbyte_ty || typeEquivAux EraseMeasures g ty g.byte_ty then + elif + typeEquivAux EraseMeasures g ty g.sbyte_ty + || typeEquivAux EraseMeasures g ty g.byte_ty + then g.uint16_ty else ty @@ -10812,25 +13324,30 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = /// We do this so that adding one won't result in overflow. let mkWiden e = if typeEquivAux EraseMeasures g rangeTy g.int32_ty then - mkAsmExpr ([AI_conv DT_I8], [], [e], [g.uint64_ty], m) + mkAsmExpr ([ AI_conv DT_I8 ], [], [ e ], [ g.uint64_ty ], m) elif typeEquivAux EraseMeasures g rangeTy g.uint32_ty then - mkAsmExpr ([AI_conv DT_U8], [], [e], [g.uint64_ty], m) + mkAsmExpr ([ AI_conv DT_U8 ], [], [ e ], [ g.uint64_ty ], m) elif typeEquivAux EraseMeasures g rangeTy g.int16_ty then - mkAsmExpr ([AI_conv DT_I4], [], [e], [g.uint32_ty], m) - elif typeEquivAux EraseMeasures g rangeTy g.uint16_ty || typeEquivAux EraseMeasures g rangeTy g.char_ty then - mkAsmExpr ([AI_conv DT_U4], [], [e], [g.uint32_ty], m) + mkAsmExpr ([ AI_conv DT_I4 ], [], [ e ], [ g.uint32_ty ], m) + elif + typeEquivAux EraseMeasures g rangeTy g.uint16_ty + || typeEquivAux EraseMeasures g rangeTy g.char_ty + then + mkAsmExpr ([ AI_conv DT_U4 ], [], [ e ], [ g.uint32_ty ], m) elif typeEquivAux EraseMeasures g rangeTy g.sbyte_ty then - mkAsmExpr ([AI_conv DT_I2], [], [e], [g.uint16_ty], m) + mkAsmExpr ([ AI_conv DT_I2 ], [], [ e ], [ g.uint16_ty ], m) elif typeEquivAux EraseMeasures g rangeTy g.byte_ty then - mkAsmExpr ([AI_conv DT_U2], [], [e], [g.uint16_ty], m) + mkAsmExpr ([ AI_conv DT_U2 ], [], [ e ], [ g.uint16_ty ], m) else e /// Expects that |e1| ≥ |e2|. - let mkDiff e1 e2 = mkAsmExpr ([AI_sub], [], [e1; e2], [unsignedEquivalent (tyOfExpr g e1)], m) + let mkDiff e1 e2 = + mkAsmExpr ([ AI_sub ], [], [ e1; e2 ], [ unsignedEquivalent (tyOfExpr g e1) ], m) /// diff / step - let mkQuotient diff step = mkAsmExpr ([AI_div_un], [], [diff; step], [tyOfExpr g diff], m) + let mkQuotient diff step = + mkAsmExpr ([ AI_div_un ], [], [ diff; step ], [ tyOfExpr g diff ], m) /// Whether the total count might not fit in 64 bits. let couldBeTooBig ty = @@ -10845,54 +13362,67 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = let ty = tyOfExpr g pseudoCount if couldBeTooBig rangeTy then - mkAsmExpr ([AI_add_ovf_un], [], [pseudoCount; mkTypedOne g m ty], [ty], m) + mkAsmExpr ([ AI_add_ovf_un ], [], [ pseudoCount; mkTypedOne g m ty ], [ ty ], m) else - mkAsmExpr ([AI_add], [], [pseudoCount; mkTypedOne g m ty], [ty], m) + mkAsmExpr ([ AI_add ], [], [ pseudoCount; mkTypedOne g m ty ], [ ty ], m) let mkRuntimeCalc mkThrowIfStepIsZero pseudoCount count = - if typeEquivAux EraseMeasures g rangeTy g.int64_ty || typeEquivAux EraseMeasures g rangeTy g.uint64_ty then - RangeCount.PossiblyOversize (fun mkLoopExpr -> - mkThrowIfStepIsZero - (mkCompGenLetIn m (nameof pseudoCount) (tyOfExpr g pseudoCount) pseudoCount (fun (_, pseudoCount) -> - let wouldOvf = mkILAsmCeq g m pseudoCount (Expr.Const (Const.UInt64 UInt64.MaxValue, m, g.uint64_ty)) - mkCompGenLetIn m (nameof wouldOvf) g.bool_ty wouldOvf (fun (_, wouldOvf) -> - mkLoopExpr count wouldOvf)))) - elif typeEquivAux EraseMeasures g rangeTy g.nativeint_ty || typeEquivAux EraseMeasures g rangeTy g.unativeint_ty then // We have a nativeint ty whose size we won't know till runtime. - RangeCount.PossiblyOversize (fun mkLoopExpr -> - mkThrowIfStepIsZero - (mkCompGenLetIn m (nameof pseudoCount) (tyOfExpr g pseudoCount) pseudoCount (fun (_, pseudoCount) -> + if + typeEquivAux EraseMeasures g rangeTy g.int64_ty + || typeEquivAux EraseMeasures g rangeTy g.uint64_ty + then + RangeCount.PossiblyOversize(fun mkLoopExpr -> + mkThrowIfStepIsZero ( + mkCompGenLetIn m (nameof pseudoCount) (tyOfExpr g pseudoCount) pseudoCount (fun (_, pseudoCount) -> + let wouldOvf = + mkILAsmCeq g m pseudoCount (Expr.Const(Const.UInt64 UInt64.MaxValue, m, g.uint64_ty)) + + mkCompGenLetIn m (nameof wouldOvf) g.bool_ty wouldOvf (fun (_, wouldOvf) -> mkLoopExpr count wouldOvf)) + )) + elif + typeEquivAux EraseMeasures g rangeTy g.nativeint_ty + || typeEquivAux EraseMeasures g rangeTy g.unativeint_ty + then // We have a nativeint ty whose size we won't know till runtime. + RangeCount.PossiblyOversize(fun mkLoopExpr -> + mkThrowIfStepIsZero ( + mkCompGenLetIn m (nameof pseudoCount) (tyOfExpr g pseudoCount) pseudoCount (fun (_, pseudoCount) -> let wouldOvf = mkCond DebugPointAtBinding.NoneAtInvisible m g.bool_ty - (mkILAsmCeq g m (mkAsmExpr ([I_sizeof g.ilg.typ_IntPtr], [], [], [g.uint32_ty], m)) (Expr.Const (Const.UInt32 4u, m, g.uint32_ty))) - (mkILAsmCeq g m pseudoCount (Expr.Const (Const.UIntPtr (uint64 UInt32.MaxValue), m, g.unativeint_ty))) - (mkILAsmCeq g m pseudoCount (Expr.Const (Const.UIntPtr UInt64.MaxValue, m, g.unativeint_ty))) - - mkCompGenLetIn m (nameof wouldOvf) g.bool_ty wouldOvf (fun (_, wouldOvf) -> - mkLoopExpr count wouldOvf)))) + (mkILAsmCeq + g + m + (mkAsmExpr ([ I_sizeof g.ilg.typ_IntPtr ], [], [], [ g.uint32_ty ], m)) + (Expr.Const(Const.UInt32 4u, m, g.uint32_ty))) + (mkILAsmCeq g m pseudoCount (Expr.Const(Const.UIntPtr(uint64 UInt32.MaxValue), m, g.unativeint_ty))) + (mkILAsmCeq g m pseudoCount (Expr.Const(Const.UIntPtr UInt64.MaxValue, m, g.unativeint_ty))) + + mkCompGenLetIn m (nameof wouldOvf) g.bool_ty wouldOvf (fun (_, wouldOvf) -> mkLoopExpr count wouldOvf)) + )) else - RangeCount.Safe (mkThrowIfStepIsZero count) + RangeCount.Safe(mkThrowIfStepIsZero count) match start, step, finish with // start..0..finish - | _, Expr.Const (value = IntegralConst.Zero), _ -> RangeCount.ConstantZeroStep (mkSequential m (mkCallAndIgnoreRangeExpr start step finish) (mkTypedZero g m rangeTy)) + | _, Expr.Const(value = IntegralConst.Zero), _ -> + RangeCount.ConstantZeroStep(mkSequential m (mkCallAndIgnoreRangeExpr start step finish) (mkTypedZero g m rangeTy)) // 5..1 // 1..-1..5 - | EmptyRange -> RangeCount.Constant (mkTypedZero g m rangeTy) + | EmptyRange -> RangeCount.Constant(mkTypedZero g m rangeTy) // 1..5 // 1..2..5 // 5..-1..1 - | ConstCount count -> RangeCount.Constant (Expr.Const (count, m, nextWidestUnsignedTy rangeTy)) + | ConstCount count -> RangeCount.Constant(Expr.Const(count, m, nextWidestUnsignedTy rangeTy)) // start..finish // start..1..finish // // if finish < start then 0 else finish - start + 1 - | _, Expr.Const (value = IntegralConst.One), _ -> + | _, Expr.Const(value = IntegralConst.One), _ -> let mkCount mkAddOne = let count = mkAddOne (mkDiff finish start) let countTy = tyOfExpr g count @@ -10907,14 +13437,16 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = match start, finish with // The total count could exceed 2⁶⁴. - | Expr.Const (value = Const.Int64 Int64.MinValue), _ | _, Expr.Const (value = Const.Int64 Int64.MaxValue) - | Expr.Const (value = Const.UInt64 UInt64.MinValue), _ | _, Expr.Const (value = Const.UInt64 UInt64.MaxValue) -> - mkRuntimeCalc id (mkCount id) (mkCount mkAddOne) + | Expr.Const(value = Const.Int64 Int64.MinValue), _ + | _, Expr.Const(value = Const.Int64 Int64.MaxValue) + | Expr.Const(value = Const.UInt64 UInt64.MinValue), _ + | _, Expr.Const(value = Const.UInt64 UInt64.MaxValue) -> mkRuntimeCalc id (mkCount id) (mkCount mkAddOne) // The total count could not exceed 2⁶⁴. - | Expr.Const (value = Const.Int64 _), _ | _, Expr.Const (value = Const.Int64 _) - | Expr.Const (value = Const.UInt64 _), _ | _, Expr.Const (value = Const.UInt64 _) -> - RangeCount.Safe (mkCount mkAddOne) + | Expr.Const(value = Const.Int64 _), _ + | _, Expr.Const(value = Const.Int64 _) + | Expr.Const(value = Const.UInt64 _), _ + | _, Expr.Const(value = Const.UInt64 _) -> RangeCount.Safe(mkCount mkAddOne) | _ -> mkRuntimeCalc id (mkCount id) (mkCount mkAddOne) @@ -10923,7 +13455,7 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = // start..-1..finish // // if start < finish then 0 else start - finish + 1 - | _, Expr.Const (value = IntegralConst.MinusOne), _ -> + | _, Expr.Const(value = IntegralConst.MinusOne), _ -> let mkCount mkAddOne = let count = mkAddOne (mkDiff start finish) let countTy = tyOfExpr g count @@ -10938,19 +13470,19 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = match start, finish with // The total count could exceed 2⁶⁴. - | Expr.Const (value = Const.Int64 Int64.MaxValue), _ | _, Expr.Const (value = Const.Int64 Int64.MinValue) -> - mkRuntimeCalc id (mkCount id) (mkCount mkAddOne) + | Expr.Const(value = Const.Int64 Int64.MaxValue), _ + | _, Expr.Const(value = Const.Int64 Int64.MinValue) -> mkRuntimeCalc id (mkCount id) (mkCount mkAddOne) // The total count could not exceed 2⁶⁴. - | Expr.Const (value = Const.Int64 _), _ | _, Expr.Const (value = Const.Int64 _) -> - RangeCount.Safe (mkCount mkAddOne) + | Expr.Const(value = Const.Int64 _), _ + | _, Expr.Const(value = Const.Int64 _) -> RangeCount.Safe(mkCount mkAddOne) | _ -> mkRuntimeCalc id (mkCount id) (mkCount mkAddOne) // start..2..finish // // if finish < start then 0 else (finish - start) / step + 1 - | _, Expr.Const (value = IntegralConst.Positive), _ -> + | _, Expr.Const(value = IntegralConst.Positive), _ -> let count = let count = mkAddOne (mkQuotient (mkDiff finish start) step) let countTy = tyOfExpr g count @@ -10972,9 +13504,11 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = // start..-2..finish // // if start < finish then 0 else (start - finish) / abs step + 1 - | _, Expr.Const (value = IntegralConst.Negative as negativeStep), _ -> + | _, Expr.Const(value = IntegralConst.Negative as negativeStep), _ -> let count = - let count = mkAddOne (mkQuotient (mkDiff start finish) (Expr.Const (IntegralConst.abs negativeStep, m, unsignedEquivalent rangeTy))) + let count = + mkAddOne (mkQuotient (mkDiff start finish) (Expr.Const(IntegralConst.abs negativeStep, m, unsignedEquivalent rangeTy))) + let countTy = tyOfExpr g count mkCond @@ -11029,7 +13563,15 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = count let negativeStep = - let absStep = mkAsmExpr ([AI_add], [], [mkAsmExpr ([AI_not], [], [step], [rangeTy], m); mkTypedOne g m rangeTy], [rangeTy], m) + let absStep = + mkAsmExpr ( + [ AI_add ], + [], + [ mkAsmExpr ([ AI_not ], [], [ step ], [ rangeTy ], m); mkTypedOne g m rangeTy ], + [ rangeTy ], + m + ) + let count = mkAddOne (mkQuotient (mkDiff start finish) absStep) let countTy = tyOfExpr g count @@ -11062,56 +13604,57 @@ let mkRangeCount g m rangeTy rangeExpr start step finish = match start, finish with // The total count could exceed 2⁶⁴. - | Expr.Const (value = Const.Int64 Int64.MinValue), _ | _, Expr.Const (value = Const.Int64 Int64.MaxValue) - | Expr.Const (value = Const.Int64 Int64.MaxValue), _ | _, Expr.Const (value = Const.Int64 Int64.MinValue) - | Expr.Const (value = Const.UInt64 UInt64.MinValue), _ | _, Expr.Const (value = Const.UInt64 UInt64.MaxValue) -> - mkRuntimeCalc mkThrowIfStepIsZero (mkCount id) (mkCount mkAddOne) + | Expr.Const(value = Const.Int64 Int64.MinValue), _ + | _, Expr.Const(value = Const.Int64 Int64.MaxValue) + | Expr.Const(value = Const.Int64 Int64.MaxValue), _ + | _, Expr.Const(value = Const.Int64 Int64.MinValue) + | Expr.Const(value = Const.UInt64 UInt64.MinValue), _ + | _, Expr.Const(value = Const.UInt64 UInt64.MaxValue) -> mkRuntimeCalc mkThrowIfStepIsZero (mkCount id) (mkCount mkAddOne) // The total count could not exceed 2⁶⁴. - | Expr.Const (value = Const.Int64 _), _ | _, Expr.Const (value = Const.Int64 _) - | Expr.Const (value = Const.UInt64 _), _ | _, Expr.Const (value = Const.UInt64 _) -> - RangeCount.Safe (mkThrowIfStepIsZero (mkCount mkAddOne)) + | Expr.Const(value = Const.Int64 _), _ + | _, Expr.Const(value = Const.Int64 _) + | Expr.Const(value = Const.UInt64 _), _ + | _, Expr.Const(value = Const.UInt64 _) -> RangeCount.Safe(mkThrowIfStepIsZero (mkCount mkAddOne)) | _ -> mkRuntimeCalc mkThrowIfStepIsZero (mkCount id) (mkCount mkAddOne) -let mkOptimizedRangeLoop (g: TcGlobals) (mBody, mFor, mIn, spInWhile) (rangeTy, rangeExpr) (start, step, finish) (buildLoop: (Count -> ((Idx -> Elem -> Body) -> Loop) -> Expr)) = +let mkOptimizedRangeLoop + (g: TcGlobals) + (mBody, mFor, mIn, spInWhile) + (rangeTy, rangeExpr) + (start, step, finish) + (buildLoop: (Count -> ((Idx -> Elem -> Body) -> Loop) -> Expr)) + = let inline mkLetBindingsIfNeeded f = match start, step, finish with - | (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _) -> - f start step finish - + | (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _) -> f start step finish + | (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _), _ -> - mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> - f start step finish) - + mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> f start step finish) + | _, (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _) -> - mkCompGenLetIn start.Range (nameof start) rangeTy start (fun (_, start) -> - f start step finish) - + mkCompGenLetIn start.Range (nameof start) rangeTy start (fun (_, start) -> f start step finish) + | (Expr.Const _ | Expr.Val _), _, (Expr.Const _ | Expr.Val _) -> - mkCompGenLetIn step.Range (nameof step) rangeTy step (fun (_, step) -> - f start step finish) - + mkCompGenLetIn step.Range (nameof step) rangeTy step (fun (_, step) -> f start step finish) + | _, (Expr.Const _ | Expr.Val _), _ -> mkCompGenLetIn start.Range (nameof start) rangeTy start (fun (_, start) -> - mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> - f start step finish)) - + mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> f start step finish)) + | (Expr.Const _ | Expr.Val _), _, _ -> mkCompGenLetIn step.Range (nameof step) rangeTy step (fun (_, step) -> - mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> - f start step finish)) - + mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> f start step finish)) + | _, _, (Expr.Const _ | Expr.Val _) -> mkCompGenLetIn start.Range (nameof start) rangeTy start (fun (_, start) -> - mkCompGenLetIn step.Range (nameof step) rangeTy step (fun (_, step) -> - f start step finish)) - + mkCompGenLetIn step.Range (nameof step) rangeTy step (fun (_, step) -> f start step finish)) + | _, _, _ -> mkCompGenLetIn start.Range (nameof start) rangeTy start (fun (_, start) -> mkCompGenLetIn step.Range (nameof step) rangeTy step (fun (_, step) -> - mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> - f start step finish))) + mkCompGenLetIn finish.Range (nameof finish) rangeTy finish (fun (_, finish) -> f start step finish))) mkLetBindingsIfNeeded (fun start step finish -> /// Start at 0 and count up through count - 1. @@ -11125,34 +13668,29 @@ let mkOptimizedRangeLoop (g: TcGlobals) (mBody, mFor, mIn, spInWhile) (rangeTy, mkCompGenLetMutableIn mIn "i" countTy (mkTypedZero g mIn countTy) (fun (idxVal, idxVar) -> mkCompGenLetMutableIn mIn "loopVar" rangeTy start (fun (loopVal, loopVar) -> // loopVar <- loopVar + step - let incrV = mkValSet mIn (mkLocalValRef loopVal) (mkAsmExpr ([AI_add], [], [loopVar; step], [rangeTy], mIn)) + let incrV = + mkValSet mIn (mkLocalValRef loopVal) (mkAsmExpr ([ AI_add ], [], [ loopVar; step ], [ rangeTy ], mIn)) // i <- i + 1 - let incrI = mkValSet mIn (mkLocalValRef idxVal) (mkAsmExpr ([AI_add], [], [idxVar; mkTypedOne g mIn countTy], [rangeTy], mIn)) + let incrI = + mkValSet + mIn + (mkLocalValRef idxVal) + (mkAsmExpr ([ AI_add ], [], [ idxVar; mkTypedOne g mIn countTy ], [ rangeTy ], mIn)) // // loopVar <- loopVar + step // i <- i + 1 - let body = mkSequentials g mBody [mkBody idxVar loopVar; incrV; incrI] + let body = mkSequentials g mBody [ mkBody idxVar loopVar; incrV; incrI ] // i < count - let guard = mkAsmExpr ([AI_clt_un], [], [idxVar; count], [g.bool_ty], mFor) + let guard = mkAsmExpr ([ AI_clt_un ], [], [ idxVar; count ], [ g.bool_ty ], mFor) // while i < count do // // loopVar <- loopVar + step // i <- i + 1 - mkWhile - g - ( - spInWhile, - WhileLoopForCompiledForEachExprMarker, - guard, - body, - mBody - ) - ) - ) + mkWhile g (spInWhile, WhileLoopForCompiledForEachExprMarker, guard, body, mBody))) /// Start at 0 and count up till we have wrapped around. /// We only emit this if the type is or may be 64-bit and step is not constant, @@ -11170,41 +13708,39 @@ let mkOptimizedRangeLoop (g: TcGlobals) (mBody, mFor, mIn, spInWhile) (rangeTy, mkCompGenLetMutableIn mIn "i" countTy (mkTypedZero g mIn countTy) (fun (idxVal, idxVar) -> mkCompGenLetMutableIn mIn "loopVar" rangeTy start (fun (loopVal, loopVar) -> // loopVar <- loopVar + step - let incrV = mkValSet mIn (mkLocalValRef loopVal) (mkAsmExpr ([AI_add], [], [loopVar; step], [rangeTy], mIn)) + let incrV = + mkValSet mIn (mkLocalValRef loopVal) (mkAsmExpr ([ AI_add ], [], [ loopVar; step ], [ rangeTy ], mIn)) // i <- i + 1 - let incrI = mkValSet mIn (mkLocalValRef idxVal) (mkAsmExpr ([AI_add], [], [idxVar; mkTypedOne g mIn countTy], [rangeTy], mIn)) + let incrI = + mkValSet + mIn + (mkLocalValRef idxVal) + (mkAsmExpr ([ AI_add ], [], [ idxVar; mkTypedOne g mIn countTy ], [ rangeTy ], mIn)) // guard <- i <> 0 - let breakIfZero = mkValSet mFor (mkLocalValRef guardVal) (mkAsmExpr ([ILInstr.AI_cgt_un], [], [idxVar; mkTypedZero g mFor countTy], [g.bool_ty], mFor)) + let breakIfZero = + mkValSet + mFor + (mkLocalValRef guardVal) + (mkAsmExpr ([ ILInstr.AI_cgt_un ], [], [ idxVar; mkTypedZero g mFor countTy ], [ g.bool_ty ], mFor)) // // loopVar <- loopVar + step // i <- i + 1 // guard <- i <> 0 - let body = mkSequentials g mBody [mkBody idxVar loopVar; incrV; incrI; breakIfZero] + let body = + mkSequentials g mBody [ mkBody idxVar loopVar; incrV; incrI; breakIfZero ] // while guard do // // loopVar <- loopVar + step // i <- i + 1 // guard <- i <> 0 - mkWhile - g - ( - spInWhile, - WhileLoopForCompiledForEachExprMarker, - guardVar, - body, - mBody - ) - ) - ) - ) + mkWhile g (spInWhile, WhileLoopForCompiledForEachExprMarker, guardVar, body, mBody)))) match mkRangeCount g mIn rangeTy rangeExpr start step finish with - | RangeCount.Constant count -> - buildLoop count (fun mkBody -> mkCountUpExclusive mkBody count) + | RangeCount.Constant count -> buildLoop count (fun mkBody -> mkCountUpExclusive mkBody count) | RangeCount.ConstantZeroStep count -> mkCompGenLetIn mIn (nameof count) (tyOfExpr g count) count (fun (_, count) -> @@ -11223,10 +13759,9 @@ let mkOptimizedRangeLoop (g: TcGlobals) (mBody, mFor, mIn, spInWhile) (rangeTy, g.unit_ty wouldOvf (mkCountUpInclusive mkBody (tyOfExpr g count)) - (mkCompGenLetIn mIn (nameof count) (tyOfExpr g count) count (fun (_, count) -> mkCountUpExclusive mkBody count)))) - ) + (mkCompGenLetIn mIn (nameof count) (tyOfExpr g count) count (fun (_, count) -> mkCountUpExclusive mkBody count))))) -let mkDebugPoint m expr = +let mkDebugPoint m expr = Expr.DebugPoint(DebugPointAtLeafExpr.Yes m, expr) type OptimizeForExpressionOptions = @@ -11235,29 +13770,31 @@ type OptimizeForExpressionOptions = let DetectAndOptimizeForEachExpression g option expr = match option, expr with - | _, CompiledInt32RangeForEachExpr g (startExpr, (1 | -1 as step), finishExpr, elemVar, bodyExpr, ranges) -> + | _, CompiledInt32RangeForEachExpr g (startExpr, (1 | -1 as step), finishExpr, elemVar, bodyExpr, ranges) -> + + let _mBody, spFor, spIn, _mFor, _mIn, _spInWhile, mWholeExpr = ranges - let _mBody, spFor, spIn, _mFor, _mIn, _spInWhile, mWholeExpr = ranges - let spFor = match spFor with DebugPointAtBinding.Yes mFor -> DebugPointAtFor.Yes mFor | _ -> DebugPointAtFor.No - mkFastForLoop g (spFor, spIn, mWholeExpr, elemVar, startExpr, (step = 1), finishExpr, bodyExpr) + let spFor = + match spFor with + | DebugPointAtBinding.Yes mFor -> DebugPointAtFor.Yes mFor + | _ -> DebugPointAtFor.No - | OptimizeAllForExpressions, CompiledForEachExpr g (_enumTy, rangeExpr & IntegralRange g (rangeTy, (start, step, finish)), elemVar, bodyExpr, ranges) when + mkFastForLoop g (spFor, spIn, mWholeExpr, elemVar, startExpr, (step = 1), finishExpr, bodyExpr) + + | OptimizeAllForExpressions, + CompiledForEachExpr g (_enumTy, rangeExpr & IntegralRange g (rangeTy, (start, step, finish)), elemVar, bodyExpr, ranges) when g.langVersion.SupportsFeature LanguageFeature.LowerIntegralRangesToFastLoops -> let mBody, _spFor, _spIn, mFor, mIn, spInWhile, _mWhole = ranges - mkOptimizedRangeLoop - g - (mBody, mFor, mIn, spInWhile) - (rangeTy, rangeExpr) - (start, step, finish) - (fun _count mkLoop -> mkLoop (fun _idxVar loopVar -> mkInvisibleLet elemVar.Range elemVar loopVar bodyExpr)) + mkOptimizedRangeLoop g (mBody, mFor, mIn, spInWhile) (rangeTy, rangeExpr) (start, step, finish) (fun _count mkLoop -> + mkLoop (fun _idxVar loopVar -> mkInvisibleLet elemVar.Range elemVar loopVar bodyExpr)) | OptimizeAllForExpressions, CompiledForEachExpr g (enumerableTy, enumerableExpr, elemVar, bodyExpr, ranges) -> - let mBody, spFor, spIn, mFor, mIn, spInWhile, mWholeExpr = ranges + let mBody, spFor, spIn, mFor, mIn, spInWhile, mWholeExpr = ranges - if isStringTy g enumerableTy then + if isStringTy g enumerableTy then // type is string, optimize for expression as: // let $str = enumerable // for $idx = 0 to str.Length - 1 do @@ -11273,14 +13810,17 @@ let DetectAndOptimizeForEachExpression g option expr = let startExpr = mkZero g mFor let finishExpr = mkDecr g mFor lengthExpr // for compat reasons, loop item over string is sometimes object, not char - let loopItemExpr = mkCoerceIfNeeded g elemVar.Type g.char_ty charExpr + let loopItemExpr = mkCoerceIfNeeded g elemVar.Type g.char_ty charExpr let bodyExpr = mkInvisibleLet mIn elemVar loopItemExpr bodyExpr - let forExpr = mkFastForLoop g (DebugPointAtFor.No, spIn, mWholeExpr, idxVar, startExpr, true, finishExpr, bodyExpr) + + let forExpr = + mkFastForLoop g (DebugPointAtFor.No, spIn, mWholeExpr, idxVar, startExpr, true, finishExpr, bodyExpr) + let expr = mkLet spFor mFor strVar enumerableExpr forExpr expr - elif isListTy g enumerableTy then + elif isListTy g enumerableTy then // type is list, optimize for expression as: // let mutable $currentVar = listExpr // let mutable $nextVar = $tailOrNull @@ -11298,28 +13838,44 @@ let DetectAndOptimizeForEachExpression g option expr = let elemTy = destListTy g enumerableTy let guardExpr = mkNonNullTest g mFor nextExpr - let headOrDefaultExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [elemTy], IndexHead, mIn) - let tailOrNullExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [elemTy], IndexTail, mIn) + + let headOrDefaultExpr = + mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [ elemTy ], IndexHead, mIn) + + let tailOrNullExpr = + mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr, g.cons_ucref, [ elemTy ], IndexTail, mIn) let bodyExpr = - mkInvisibleLet mIn elemVar headOrDefaultExpr - (mkSequential mIn + mkInvisibleLet + mIn + elemVar + headOrDefaultExpr + (mkSequential + mIn bodyExpr - (mkSequential mIn + (mkSequential + mIn (mkValSet mIn (mkLocalValRef currentVar) nextExpr) (mkValSet mIn (mkLocalValRef nextVar) tailOrNullExpr))) let expr = // let mutable current = enumerableExpr - mkLet spFor mIn currentVar enumerableExpr + mkLet + spFor + mIn + currentVar + enumerableExpr // let mutable next = current.TailOrNull - (mkInvisibleLet mFor nextVar tailOrNullExpr + (mkInvisibleLet + mFor + nextVar + tailOrNullExpr // while nonNull next do - (mkWhile g (spInWhile, WhileLoopForCompiledForEachExprMarker, guardExpr, bodyExpr, mBody))) + (mkWhile g (spInWhile, WhileLoopForCompiledForEachExprMarker, guardExpr, bodyExpr, mBody))) expr - else + else expr | _ -> expr @@ -11331,61 +13887,65 @@ let (|InnerExprPat|) expr = stripExpr expr /// is to eliminate variables of static type "unit". These is a /// utility function related to this. -let BindUnitVars g (mvs: Val list, paramInfos: ArgReprInfo list, body) = - match mvs, paramInfos with - | [v], [] -> +let BindUnitVars g (mvs: Val list, paramInfos: ArgReprInfo list, body) = + match mvs, paramInfos with + | [ v ], [] -> assert isUnitTy g v.Type - [], mkLet DebugPointAtBinding.NoneAtInvisible v.Range v (mkUnit g v.Range) body + [], mkLet DebugPointAtBinding.NoneAtInvisible v.Range v (mkUnit g v.Range) body | _ -> mvs, body -let isThreadOrContextStatic g attrs = - HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute attrs || - HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute attrs +let isThreadOrContextStatic g attrs = + HasFSharpAttributeOpt g g.attrib_ThreadStaticAttribute attrs + || HasFSharpAttributeOpt g g.attrib_ContextStaticAttribute attrs let mkUnitDelayLambda (g: TcGlobals) m e = let uv, _ = mkCompGenLocal m "unitVar" g.unit_ty - mkLambda m uv (e, tyOfExpr g e) + mkLambda m uv (e, tyOfExpr g e) [] let (|UseResumableStateMachinesExpr|_|) g expr = match expr with - | ValApp g g.cgh__useResumableCode_vref (_, _, _m) -> ValueSome () + | ValApp g g.cgh__useResumableCode_vref (_, _, _m) -> ValueSome() | _ -> ValueNone /// Match an if...then...else expression or the result of "a && b" or "a || b" [] let (|IfThenElseExpr|_|) expr = match expr with - | Expr.Match (_spBind, _exprm, TDSwitch(cond, [ TCase( DecisionTreeTest.Const (Const.Bool true), TDSuccess ([], 0) )], Some (TDSuccess ([], 1)), _), - [| TTarget([], thenExpr, _); TTarget([], elseExpr, _) |], _m, _ty) -> - ValueSome (cond, thenExpr, elseExpr) + | Expr.Match(_spBind, + _exprm, + TDSwitch(cond, [ TCase(DecisionTreeTest.Const(Const.Bool true), TDSuccess([], 0)) ], Some(TDSuccess([], 1)), _), + [| TTarget([], thenExpr, _); TTarget([], elseExpr, _) |], + _m, + _ty) -> ValueSome(cond, thenExpr, elseExpr) | _ -> ValueNone /// if __useResumableCode then ... else ... [] let (|IfUseResumableStateMachinesExpr|_|) g expr = match expr with - | IfThenElseExpr(UseResumableStateMachinesExpr g (), thenExpr, elseExpr) -> ValueSome (thenExpr, elseExpr) + | IfThenElseExpr(UseResumableStateMachinesExpr g (), thenExpr, elseExpr) -> ValueSome(thenExpr, elseExpr) | _ -> ValueNone /// Combine a list of ModuleOrNamespaceType's making up the description of a CCU. checking there are now /// duplicate modules etc. -let CombineCcuContentFragments l = +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 rec CombineModuleOrNamespaceTypes path (mty1: ModuleOrNamespaceType) (mty2: ModuleOrNamespaceType) = let kind = mty1.ModuleOrNamespaceKind let tab1 = mty1.AllEntitiesByLogicalMangledName let tab2 = mty2.AllEntitiesByLogicalMangledName - let entities = + + let entities = [ - for e1 in mty1.AllEntities do + 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 + for e2 in mty2.AllEntities do match tab1.TryGetValue e2.LogicalName with | true, _ -> () | _ -> yield e2 @@ -11395,34 +13955,42 @@ let CombineCcuContentFragments l = ModuleOrNamespaceType(kind, vals, QueueList.ofList entities) - and CombineEntities path (entity1: Entity) (entity2: Entity) = + and CombineEntities path (entity1: Entity) (entity2: Entity) = - let path2 = path@[entity2.DemangledModuleOrNamespaceName] + let path2 = path @ [ entity2.DemangledModuleOrNamespaceName ] match entity1.IsNamespace, entity2.IsNamespace, entity1.IsModule, entity2.IsModule with - | true, true, _, _ -> - () + | 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 -> + | _, 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 + + { data1 with entity_attribs = 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 = + 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" @@ -11437,49 +14005,70 @@ 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) + { 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 - }) + } + ) [] -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) +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) +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) +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) + 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 [] let (|MatchTwoCasesExpr|_|) expr = - match expr with - | Expr.Match (spBind, mExpr, TDSwitch(cond, [ TCase( DecisionTreeTest.UnionCase (ucref, a), TDSuccess ([], tg1) )], Some (TDSuccess ([], tg2)), b), tgs, m, ty) -> + match expr with + | Expr.Match(spBind, + mExpr, + TDSwitch(cond, [ TCase(DecisionTreeTest.UnionCase(ucref, a), TDSuccess([], tg1)) ], Some(TDSuccess([], tg2)), b), + tgs, + m, + ty) -> // How to rebuild this construct - let rebuild (cond, ucref, tg1, tg2, tgs) = - Expr.Match (spBind, mExpr, TDSwitch(cond, [ TCase( DecisionTreeTest.UnionCase (ucref, a), TDSuccess ([], tg1) )], Some (TDSuccess ([], tg2)), b), tgs, m, ty) + let rebuild (cond, ucref, tg1, tg2, tgs) = + Expr.Match( + spBind, + mExpr, + TDSwitch(cond, [ TCase(DecisionTreeTest.UnionCase(ucref, a), TDSuccess([], tg1)) ], Some(TDSuccess([], tg2)), b), + tgs, + m, + ty + ) - ValueSome (cond, ucref, tg1, tg2, tgs, rebuild) + ValueSome(cond, ucref, tg1, tg2, tgs, rebuild) | _ -> ValueNone @@ -11487,48 +14076,72 @@ let (|MatchTwoCasesExpr|_|) expr = [] let (|MatchOptionExpr|_|) expr = match expr with - | MatchTwoCasesExpr(cond, ucref, tg1, tg2, tgs, rebuildTwoCases) -> + | MatchTwoCasesExpr(cond, ucref, tg1, tg2, tgs, rebuildTwoCases) -> let tgNone, tgSome = if ucref.CaseName = "None" then tg1, tg2 else tg2, tg1 - match tgs[tgNone], tgs[tgSome] with - | TTarget([], noneBranchExpr, b2), - TTarget([], Expr.Let(TBind(unionCaseVar, Expr.Op(TOp.UnionCaseProof a1, a2, a3, a4), a5), - Expr.Let(TBind(someVar, Expr.Op(TOp.UnionCaseFieldGet (a6a, a6b), a7, a8, a9), a10), someBranchExpr, a11, a12), a13, a14), a16) - when unionCaseVar.LogicalName = "unionCase" -> + + match tgs[tgNone], tgs[tgSome] with + | TTarget([], noneBranchExpr, b2), + TTarget([], + Expr.Let(TBind(unionCaseVar, Expr.Op(TOp.UnionCaseProof a1, a2, a3, a4), a5), + Expr.Let(TBind(someVar, Expr.Op(TOp.UnionCaseFieldGet(a6a, a6b), a7, a8, a9), a10), someBranchExpr, a11, a12), + a13, + a14), + a16) when unionCaseVar.LogicalName = "unionCase" -> // How to rebuild this construct let rebuild (cond, noneBranchExpr, someVar, someBranchExpr) = let tgs = Array.zeroCreate 2 tgs[tgNone] <- TTarget([], noneBranchExpr, b2) - tgs[tgSome] <- TTarget([], Expr.Let(TBind(unionCaseVar, Expr.Op(TOp.UnionCaseProof a1, a2, a3, a4), a5), - Expr.Let(TBind(someVar, Expr.Op(TOp.UnionCaseFieldGet (a6a, a6b), a7, a8, a9), a10), someBranchExpr, a11, a12), a13, a14), a16) + + tgs[tgSome] <- + TTarget( + [], + Expr.Let( + TBind(unionCaseVar, Expr.Op(TOp.UnionCaseProof a1, a2, a3, a4), a5), + Expr.Let(TBind(someVar, Expr.Op(TOp.UnionCaseFieldGet(a6a, a6b), a7, a8, a9), a10), someBranchExpr, a11, a12), + a13, + a14 + ), + a16 + ) + rebuildTwoCases (cond, ucref, tg1, tg2, tgs) - ValueSome (cond, noneBranchExpr, someVar, someBranchExpr, rebuild) + ValueSome(cond, noneBranchExpr, someVar, someBranchExpr, rebuild) | _ -> ValueNone | _ -> ValueNone [] let (|ResumableEntryAppExpr|_|) g expr = match expr with - | ValApp g g.cgh__resumableEntry_vref (_, _, _m) -> ValueSome () + | ValApp g g.cgh__resumableEntry_vref (_, _, _m) -> ValueSome() | _ -> ValueNone /// Match an (unoptimized) __resumableEntry expression [] let (|ResumableEntryMatchExpr|_|) g expr = match expr with - | Expr.Let(TBind(matchVar, matchExpr, sp1), MatchOptionExpr (Expr.Val(matchVar2, b, c), noneBranchExpr, someVar, someBranchExpr, rebuildMatch), d, e) -> - match matchExpr with - | ResumableEntryAppExpr g () -> - if valRefEq g (mkLocalValRef matchVar) matchVar2 then + | Expr.Let(TBind(matchVar, matchExpr, sp1), + MatchOptionExpr(Expr.Val(matchVar2, b, c), noneBranchExpr, someVar, someBranchExpr, rebuildMatch), + d, + e) -> + match matchExpr with + | ResumableEntryAppExpr g () -> + if valRefEq g (mkLocalValRef matchVar) matchVar2 then // How to rebuild this construct let rebuild (noneBranchExpr, someBranchExpr) = - Expr.Let(TBind(matchVar, matchExpr, sp1), rebuildMatch (Expr.Val(matchVar2, b, c), noneBranchExpr, someVar, someBranchExpr), d, e) + Expr.Let( + TBind(matchVar, matchExpr, sp1), + rebuildMatch (Expr.Val(matchVar2, b, c), noneBranchExpr, someVar, someBranchExpr), + d, + e + ) - ValueSome (noneBranchExpr, someVar, someBranchExpr, rebuild) + ValueSome(noneBranchExpr, someVar, someBranchExpr, rebuild) - else ValueNone + else + ValueNone | _ -> ValueNone | _ -> ValueNone @@ -11536,88 +14149,104 @@ let (|ResumableEntryMatchExpr|_|) g expr = [] let (|StructStateMachineExpr|_|) g expr = match expr with - | ValApp g g.cgh__stateMachine_vref ([dataTy; _resultTy], [moveNext; setStateMachine; afterCode], _m) -> - match moveNext, setStateMachine, afterCode with - | NewDelegateExpr g (_, [moveNextThisVar], moveNextBody, _, _), - NewDelegateExpr g (_, [setStateMachineThisVar;setStateMachineStateVar], setStateMachineBody, _, _), - NewDelegateExpr g (_, [afterCodeThisVar], afterCodeBody, _, _) -> - ValueSome (dataTy, - (moveNextThisVar, moveNextBody), - (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), - (afterCodeThisVar, afterCodeBody)) + | ValApp g g.cgh__stateMachine_vref ([ dataTy; _resultTy ], [ moveNext; setStateMachine; afterCode ], _m) -> + match moveNext, setStateMachine, afterCode with + | NewDelegateExpr g (_, [ moveNextThisVar ], moveNextBody, _, _), + NewDelegateExpr g (_, [ setStateMachineThisVar; setStateMachineStateVar ], setStateMachineBody, _, _), + NewDelegateExpr g (_, [ afterCodeThisVar ], afterCodeBody, _, _) -> + ValueSome( + dataTy, + (moveNextThisVar, moveNextBody), + (setStateMachineThisVar, setStateMachineStateVar, setStateMachineBody), + (afterCodeThisVar, afterCodeBody) + ) | _ -> ValueNone | _ -> ValueNone [] let (|ResumeAtExpr|_|) g expr = match expr with - | ValApp g g.cgh__resumeAt_vref (_, [pcExpr], _m) -> ValueSome pcExpr + | ValApp g g.cgh__resumeAt_vref (_, [ pcExpr ], _m) -> ValueSome pcExpr | _ -> ValueNone // Detect __debugPoint calls [] let (|DebugPointExpr|_|) g expr = match expr with - | ValApp g g.cgh__debugPoint_vref (_, [StringExpr debugPointName], _m) -> ValueSome debugPointName + | ValApp g g.cgh__debugPoint_vref (_, [ StringExpr debugPointName ], _m) -> ValueSome debugPointName | _ -> ValueNone // Detect sequencing constructs in state machine code [] -let (|SequentialResumableCode|_|) (g: TcGlobals) expr = +let (|SequentialResumableCode|_|) (g: TcGlobals) expr = match expr with // e1; e2 - | Expr.Sequential(e1, e2, NormalSeq, m) -> - ValueSome (e1, e2, m, (fun e1 e2 -> Expr.Sequential(e1, e2, NormalSeq, m))) + | Expr.Sequential(e1, e2, NormalSeq, m) -> ValueSome(e1, e2, m, (fun e1 e2 -> Expr.Sequential(e1, e2, NormalSeq, m))) // let __stack_step = e1 in e2 | Expr.Let(bind, e2, m, _) when bind.Var.CompiledName(g.CompilerGlobalState).StartsWithOrdinal(stackVarPrefix) -> - ValueSome (bind.Expr, e2, m, (fun e1 e2 -> mkLet bind.DebugPoint m bind.Var e1 e2)) + ValueSome(bind.Expr, e2, m, (fun e1 e2 -> mkLet bind.DebugPoint m bind.Var e1 e2)) | _ -> ValueNone -let mkLabelled m l e = mkCompGenSequential m (Expr.Op (TOp.Label l, [], [], m)) e +let mkLabelled m l e = + mkCompGenSequential m (Expr.Op(TOp.Label l, [], [], m)) e -let isResumableCodeTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _, _) -> tyconRefEq g tcref g.ResumableCode_tcr | _ -> false) +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 rec isReturnsResumableCodeTy g ty = + if isFunTy g ty then + isReturnsResumableCodeTy g (rangeOfFunTy g ty) + else + isResumableCodeTy g ty [] let (|ResumableCodeInvoke|_|) g expr = match expr with // defn.Invoke x --> let arg = x in [defn][arg/x] - | Expr.App ((Expr.Val (invokeRef, _, _) as iref), a, b, (f :: args), m) - when invokeRef.LogicalName = "Invoke" && isReturnsResumableCodeTy g (tyOfExpr g f) -> - ValueSome (iref, f, args, m, (fun (f2, args2) -> Expr.App ((iref, a, b, (f2 :: args2), m)))) + | Expr.App((Expr.Val(invokeRef, _, _) as iref), a, b, (f :: args), m) when + invokeRef.LogicalName = "Invoke" && isReturnsResumableCodeTy g (tyOfExpr g f) + -> + ValueSome(iref, f, args, m, (fun (f2, args2) -> Expr.App((iref, a, b, (f2 :: args2), m)))) | _ -> ValueNone let ComputeUseMethodImpl g (v: Val) = - v.ImplementedSlotSigs |> List.exists (fun slotsig -> + 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 && + isInterfaceTy g oty + && (let isCompare = - tcref.GeneratedCompareToValues.IsSome && - (typeEquiv g oty g.mk_IComparable_ty || - tyconRefEq g g.system_GenericIComparable_tcref otcref) + tcref.GeneratedCompareToValues.IsSome + && (typeEquiv g oty g.mk_IComparable_ty + || tyconRefEq g g.system_GenericIComparable_tcref otcref) - not isCompare) && + not isCompare) + && (let isGenericEquals = - tcref.GeneratedHashAndEqualsWithComparerValues.IsSome && - tyconRefEq g g.system_GenericIEquatable_tcref otcref + tcref.GeneratedHashAndEqualsWithComparerValues.IsSome + && tyconRefEq g g.system_GenericIEquatable_tcref otcref - not isGenericEquals) && + not isGenericEquals) + && (let isStructural = - (tcref.GeneratedCompareToWithComparerValues.IsSome && typeEquiv g oty g.mk_IStructuralComparable_ty) || - (tcref.GeneratedHashAndEqualsWithComparerValues.IsSome && typeEquiv g oty g.mk_IStructuralEquatable_ty) + (tcref.GeneratedCompareToWithComparerValues.IsSome + && typeEquiv g oty g.mk_IStructuralComparable_ty) + || (tcref.GeneratedHashAndEqualsWithComparerValues.IsSome + && typeEquiv g oty g.mk_IStructuralEquatable_ty) not isStructural)) @@ -11625,91 +14254,114 @@ let ComputeUseMethodImpl g (v: Val) = let (|Seq|_|) g expr = match expr with // use 'seq { ... }' as an indicator - | ValApp g g.seq_vref ([elemTy], [e], _m) -> ValueSome (e, elemTy) + | ValApp g g.seq_vref ([ elemTy ], [ e ], _m) -> ValueSome(e, elemTy) | _ -> ValueNone /// Detect a 'yield x' within a 'seq { ... }' [] let (|SeqYield|_|) g expr = match expr with - | ValApp g g.seq_singleton_vref (_, [arg], m) -> ValueSome (arg, m) + | ValApp g g.seq_singleton_vref (_, [ arg ], m) -> ValueSome(arg, m) | _ -> ValueNone /// Detect a 'expr; expr' within a 'seq { ... }' [] let (|SeqAppend|_|) g expr = match expr with - | ValApp g g.seq_append_vref (_, [arg1; arg2], m) -> ValueSome (arg1, arg2, m) + | ValApp g g.seq_append_vref (_, [ arg1; arg2 ], m) -> ValueSome(arg1, arg2, m) | _ -> ValueNone -let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals +let isVarFreeInExpr v e = + Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals /// Detect a 'while gd do expr' within a 'seq { ... }' [] let (|SeqWhile|_|) g expr = match expr with - | ValApp g g.seq_generated_vref (_, [Expr.Lambda (_, _, _, [dummyv], guardExpr, _, _);innerExpr], m) - when not (isVarFreeInExpr dummyv guardExpr) -> - + | ValApp g g.seq_generated_vref (_, [ Expr.Lambda(_, _, _, [ dummyv ], guardExpr, _, _); innerExpr ], m) when + not (isVarFreeInExpr dummyv guardExpr) + -> + // The debug point for 'while' is attached to the innerExpr, see TcSequenceExpression let mWhile = innerExpr.Range - let spWhile = match mWhile.NotedSourceConstruct with NotedSourceConstruct.While -> DebugPointAtWhile.Yes mWhile | _ -> DebugPointAtWhile.No - ValueSome (guardExpr, innerExpr, spWhile, m) - | _ -> - ValueNone + let spWhile = + match mWhile.NotedSourceConstruct with + | NotedSourceConstruct.While -> DebugPointAtWhile.Yes mWhile + | _ -> DebugPointAtWhile.No + + ValueSome(guardExpr, innerExpr, spWhile, m) + + | _ -> ValueNone [] let (|SeqTryFinally|_|) g expr = match expr with - | ValApp g g.seq_finally_vref (_, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _) as arg2], m) - when not (isVarFreeInExpr dummyv compensation) -> + | ValApp g g.seq_finally_vref (_, [ arg1; Expr.Lambda(_, _, _, [ dummyv ], compensation, _, _) as arg2 ], m) when + not (isVarFreeInExpr dummyv compensation) + -> // The debug point for 'try' and 'finally' are attached to the first and second arguments // respectively, see TcSequenceExpression let mTry = arg1.Range let mFinally = arg2.Range - let spTry = match mTry.NotedSourceConstruct with NotedSourceConstruct.Try -> DebugPointAtTry.Yes mTry | _ -> DebugPointAtTry.No - let spFinally = match mFinally.NotedSourceConstruct with NotedSourceConstruct.Finally -> DebugPointAtFinally.Yes mFinally | _ -> DebugPointAtFinally.No - ValueSome (arg1, compensation, spTry, spFinally, m) + let spTry = + match mTry.NotedSourceConstruct with + | NotedSourceConstruct.Try -> DebugPointAtTry.Yes mTry + | _ -> DebugPointAtTry.No - | _ -> - ValueNone + let spFinally = + match mFinally.NotedSourceConstruct with + | NotedSourceConstruct.Finally -> DebugPointAtFinally.Yes mFinally + | _ -> DebugPointAtFinally.No + + ValueSome(arg1, compensation, spTry, spFinally, m) + + | _ -> ValueNone [] let (|SeqUsing|_|) g expr = match expr with - | ValApp g g.seq_using_vref ([_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, mBind, _)], m) -> + | ValApp g g.seq_using_vref ([ _; _; elemTy ], [ resource; Expr.Lambda(_, _, _, [ v ], body, mBind, _) ], m) -> // The debug point mFor at the 'use x = ... ' gets attached to the lambda - let spBind = match mBind.NotedSourceConstruct with NotedSourceConstruct.Binding -> DebugPointAtBinding.Yes mBind | _ -> DebugPointAtBinding.NoneAtInvisible - ValueSome (resource, v, body, elemTy, spBind, m) - | _ -> - ValueNone + let spBind = + match mBind.NotedSourceConstruct with + | NotedSourceConstruct.Binding -> DebugPointAtBinding.Yes mBind + | _ -> DebugPointAtBinding.NoneAtInvisible + + ValueSome(resource, v, body, elemTy, spBind, m) + | _ -> ValueNone [] let (|SeqForEach|_|) g expr = match expr with // Nested for loops are represented by calls to Seq.collect - | ValApp g g.seq_collect_vref ([_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, mIn, _); inp], mFor) -> + | ValApp g g.seq_collect_vref ([ _inpElemTy; _enumty2; genElemTy ], [ Expr.Lambda(_, _, _, [ v ], body, mIn, _); inp ], mFor) -> // The debug point mIn at the 'in' gets attached to the first argument, see TcSequenceExpression - let spIn = match mIn.NotedSourceConstruct with NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn | _ -> DebugPointAtInOrTo.No - ValueSome (inp, v, body, genElemTy, mFor, mIn, spIn) + let spIn = + match mIn.NotedSourceConstruct with + | NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn + | _ -> DebugPointAtInOrTo.No + + ValueSome(inp, v, body, genElemTy, mFor, mIn, spIn) // "for x in e -> e2" is converted to a call to Seq.map by the F# type checker. This could be removed, except it is also visible in F# quotations. - | ValApp g g.seq_map_vref ([_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, mIn, _); inp], mFor) -> - let spIn = match mIn.NotedSourceConstruct with NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn | _ -> DebugPointAtInOrTo.No + | ValApp g g.seq_map_vref ([ _inpElemTy; genElemTy ], [ Expr.Lambda(_, _, _, [ v ], body, mIn, _); inp ], mFor) -> + let spIn = + match mIn.NotedSourceConstruct with + | NotedSourceConstruct.InOrTo -> DebugPointAtInOrTo.Yes mIn + | _ -> DebugPointAtInOrTo.No // The debug point mFor at the 'for' gets attached to the first argument, see TcSequenceExpression - ValueSome (inp, v, mkCallSeqSingleton g body.Range genElemTy body, genElemTy, mFor, mIn, spIn) + ValueSome(inp, v, mkCallSeqSingleton g body.Range genElemTy body, genElemTy, mFor, mIn, spIn) | _ -> ValueNone [] let (|SeqDelay|_|) g expr = match expr with - | ValApp g g.seq_delay_vref ([elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) - when not (isVarFreeInExpr v e) -> - ValueSome (e, elemTy) + | ValApp g g.seq_delay_vref ([ elemTy ], [ Expr.Lambda(_, _, _, [ v ], e, _, _) ], _m) when not (isVarFreeInExpr v e) -> + ValueSome(e, elemTy) | _ -> ValueNone [] @@ -11745,7 +14397,7 @@ let (|EmptyModuleOrNamespaces|_|) (moduleOrNamespaceContents: ModuleOrNamespaceC |> List.forall (function | ModuleOrNamespaceContents.TMDefOpens _ | ModuleOrNamespaceContents.TMDefDo _ - | ModuleOrNamespaceContents.TMDefRec (isRec = true; tycons = []; bindings = []) -> true + | ModuleOrNamespaceContents.TMDefRec(isRec = true; tycons = []; bindings = []) -> true | _ -> false) |> fun isEmpty -> if isEmpty then Some mspec else None | _ -> None @@ -11757,7 +14409,7 @@ let (|EmptyModuleOrNamespaces|_|) (moduleOrNamespaceContents: ModuleOrNamespaceC ValueNone | _ -> ValueNone -let tryFindExtensionAttribute (g: TcGlobals) (attribs: Attrib list): Attrib option = +let tryFindExtensionAttribute (g: TcGlobals) (attribs: Attrib list) : Attrib option = attribs |> List.tryFind (IsMatchingFSharpAttribute g g.attrib_ExtensionAttribute) @@ -11765,23 +14417,23 @@ let tryAddExtensionAttributeIfNotAlreadyPresentForModule (g: TcGlobals) (tryFindExtensionAttributeIn: (Attrib list -> Attrib option) -> Attrib option) (moduleEntity: Entity) - : 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 = extensionAttrib :: moduleEntity.Attribs } + { moduleEntity with + entity_attribs = extensionAttrib :: moduleEntity.Attribs + } let tryAddExtensionAttributeIfNotAlreadyPresentForType (g: TcGlobals) (tryFindExtensionAttributeIn: (Attrib list -> Attrib option) -> Attrib option) (moduleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref) (typeEntity: Entity) - : Entity - = + : Entity = if Option.isSome (tryFindExtensionAttribute g typeEntity.Attribs) then typeEntity else @@ -11789,9 +14441,8 @@ let tryAddExtensionAttributeIfNotAlreadyPresentForType | None -> typeEntity | Some extensionAttrib -> moduleOrNamespaceTypeAccumulator.Value.AllEntitiesByLogicalMangledName.TryFind(typeEntity.LogicalName) - |> Option.iter (fun e -> - e.entity_attribs <- extensionAttrib :: e.Attribs - ) + |> Option.iter (fun e -> e.entity_attribs <- extensionAttrib :: e.Attribs) + typeEntity type TypedTreeNode = @@ -11803,12 +14454,9 @@ type TypedTreeNode = let rec visitEntity (entity: Entity) : TypedTreeNode = let kind = - if entity.IsModule then - "module" - elif entity.IsNamespace then - "namespace" - else - "other" + if entity.IsModule then "module" + elif entity.IsNamespace then "namespace" + else "other" let children = if not entity.IsModuleOrNamespace then @@ -11835,20 +14483,21 @@ and visitVal (v: Val) : TypedTreeNode = 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 = [] - }) - ) + |> 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 = [] - }) + |> Seq.map (fun typar -> + { + Name = typar.Name + Kind = "Typar" + Children = [] + }) } { @@ -11857,11 +14506,11 @@ and visitVal (v: Val) : TypedTreeNode = Children = Seq.toList children } -let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma:bool) (node: TypedTreeNode) = +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}\",") @@ -11869,24 +14518,25 @@ let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma:bool) (node 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() @@ -11894,7 +14544,10 @@ let serializeEntity path (entity: Entity) = serializeNode writer false root writer.Flush() let json = sw.ToString() - use out = FileSystem.OpenFileForWriteShim(path, fileMode = System.IO.FileMode.Create) + + use out = + FileSystem.OpenFileForWriteShim(path, fileMode = System.IO.FileMode.Create) + out.WriteAllText(json) let updateSeqTypeIsPrefix (fsharpCoreMSpec: ModuleOrNamespace) = @@ -11919,14 +14572,12 @@ let updateSeqTypeIsPrefix (fsharpCoreMSpec: ModuleOrNamespace) = seqEntity.entity_flags.PreEstablishedHasDefaultConstructor, seqEntity.entity_flags.HasSelfReferentialConstructor, seqEntity.entity_flags.IsStructRecordOrUnionType - ) - ) - ) + ))) let isTyparOrderMismatch (tps: Typars) (argInfos: CurriedArgInfos) = let rec getTyparName (ty: TType) : string list = match ty with - | TType_var (typar = tp) -> + | TType_var(typar = tp) -> if tp.Id.idText <> unassignedTyparName then [ tp.Id.idText ] else @@ -11935,15 +14586,13 @@ let isTyparOrderMismatch (tps: Typars) (argInfos: CurriedArgInfos) = | 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 + | 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.collect (fun argInfos -> argInfos |> List.collect (fun (ty, _) -> getTyparName ty)) |> List.distinct let typarNamesInDefinition = diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 2ac62b02787..13a43e63e39 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -934,14 +934,10 @@ let pickleObjWithDanglingCcus inMem file g scope p x = oscope = scope occus = Table<_>.Create "occus" oentities = - NodeOutTable<_, _> - .Create((fun (tc: Tycon) -> tc.Stamp), (fun tc -> tc.LogicalName), (fun tc -> tc.Range), id, "otycons") + NodeOutTable<_, _>.Create((fun (tc: Tycon) -> tc.Stamp), (fun tc -> tc.LogicalName), (fun tc -> tc.Range), id, "otycons") otypars = - NodeOutTable<_, _> - .Create((fun (tp: Typar) -> tp.Stamp), (fun tp -> tp.DisplayName), (fun tp -> tp.Range), id, "otypars") - ovals = - NodeOutTable<_, _> - .Create((fun (v: Val) -> v.Stamp), (fun v -> v.LogicalName), (fun v -> v.Range), id, "ovals") + NodeOutTable<_, _>.Create((fun (tp: Typar) -> tp.Stamp), (fun tp -> tp.DisplayName), (fun tp -> tp.Range), id, "otypars") + ovals = NodeOutTable<_, _>.Create((fun (v: Val) -> v.Stamp), (fun v -> v.LogicalName), (fun v -> v.Range), id, "ovals") oanoninfos = NodeOutTable<_, _> .Create((fun (v: AnonRecdTypeInfo) -> v.Stamp), (fun v -> string v.IlTypeName), (fun _ -> range0), id, "oanoninfos") @@ -970,11 +966,9 @@ let pickleObjWithDanglingCcus inMem file g scope p x = oscope = scope occus = Table<_>.Create "occus (fake)" oentities = - NodeOutTable<_, _> - .Create((fun (tc: Tycon) -> tc.Stamp), (fun tc -> tc.LogicalName), (fun tc -> tc.Range), id, "otycons") + NodeOutTable<_, _>.Create((fun (tc: Tycon) -> tc.Stamp), (fun tc -> tc.LogicalName), (fun tc -> tc.Range), id, "otycons") otypars = - NodeOutTable<_, _> - .Create((fun (tp: Typar) -> tp.Stamp), (fun tp -> tp.DisplayName), (fun tp -> tp.Range), id, "otypars") + NodeOutTable<_, _>.Create((fun (tp: Typar) -> tp.Stamp), (fun tp -> tp.DisplayName), (fun tp -> tp.Range), id, "otypars") ovals = NodeOutTable<_, _> .Create((fun (v: Val) -> v.Stamp), (fun v -> v.LogicalName), (fun v -> v.Range), (fun osgn -> osgn), "ovals") @@ -1049,14 +1043,9 @@ let unpickleObjWithDanglingCcus iilscope = viewedScope iccus = new_itbl "iccus (fake)" [||] ientities = - NodeInTable<_, _> - .Create(Tycon.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "itycons", 0) - itypars = - NodeInTable<_, _> - .Create(Typar.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "itypars", 0) - ivals = - NodeInTable<_, _> - .Create(Val.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "ivals", 0) + NodeInTable<_, _>.Create(Tycon.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "itycons", 0) + itypars = NodeInTable<_, _>.Create(Typar.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "itypars", 0) + ivals = NodeInTable<_, _>.Create(Val.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "ivals", 0) ianoninfos = NodeInTable<_, _> .Create(AnonRecdTypeInfo.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "ianoninfos", 0) @@ -1109,8 +1098,7 @@ let unpickleObjWithDanglingCcus NodeInTable<_, _> .Create(Typar.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "itypars", ntypars) ivals = - NodeInTable<_, _> - .Create(Val.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "ivals", nvals) + NodeInTable<_, _>.Create(Val.NewUnlinked, (fun osgn tg -> osgn.Link tg), (fun osgn -> osgn.IsLinked), "ivals", nvals) ianoninfos = NodeInTable<_, _> .Create( diff --git a/src/Compiler/TypedTree/tainted.fs b/src/Compiler/TypedTree/tainted.fs index 8b3561aaaa3..04f2c149e53 100644 --- a/src/Compiler/TypedTree/tainted.fs +++ b/src/Compiler/TypedTree/tainted.fs @@ -5,54 +5,45 @@ namespace FSharp.Compiler #if !NO_TYPEPROVIDERS open System -open Internal.Utilities.Library +open Internal.Utilities.Library open FSharp.Core.CompilerServices open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.Text open FSharp.Compiler.Text.Range [] -type internal TypeProviderToken() = interface LockToken +type internal TypeProviderToken() = + interface LockToken [] type internal TypeProviderLock() = inherit Lock() type internal TypeProviderError - ( - errNum: int, - tpDesignation: string, - m: range, - errors: string list, - typeNameContext: string option, - methodNameContext: string option - ) = + (errNum: int, tpDesignation: string, m: range, errors: string list, typeNameContext: string option, methodNameContext: string option) = inherit Exception() - new((errNum, msg: string), tpDesignation,m) = - TypeProviderError(errNum, tpDesignation, m, [msg]) - - new(errNum, tpDesignation, m, messages: seq) = - TypeProviderError(errNum, tpDesignation, m, List.ofSeq messages, None, None) + new((errNum, msg: string), tpDesignation, m) = TypeProviderError(errNum, tpDesignation, m, [ msg ]) + + new(errNum, tpDesignation, m, messages: seq) = TypeProviderError(errNum, tpDesignation, m, List.ofSeq messages, None, None) member _.Number = errNum member _.Range = m - override _.Message = + override _.Message = match errors with - | [text] -> text - | inner -> + | [ text ] -> text + | inner -> // imitates old-fashioned behavior with merged text // usually should not fall into this case (only if someone takes Message directly instead of using Iter) - inner - |> String.concat Environment.NewLine + inner |> String.concat Environment.NewLine - member _.MapText(f, tpDesignation, m) = + member _.MapText(f, tpDesignation, m) = let (errNum: int), _ = f "" - TypeProviderError(errNum, tpDesignation, m, (Seq.map (f >> snd) errors)) + TypeProviderError(errNum, tpDesignation, m, (Seq.map (f >> snd) errors)) - member _.WithContext(typeNameContext:string, methodNameContext:string) = + member _.WithContext(typeNameContext: string, methodNameContext: string) = TypeProviderError(errNum, tpDesignation, m, errors, Some typeNameContext, Some methodNameContext) // .Message is just the error, whereas .ContextualErrorMessage has contextual prefix information @@ -60,97 +51,126 @@ type internal TypeProviderError // TPE having type\method name as contextual information // without context: Type Provider 'TP' has reported the error: MSG // with context: Type Provider 'TP' has reported the error in method M of type T: MSG - member this.ContextualErrorMessage= + member this.ContextualErrorMessage = match typeNameContext, methodNameContext with | Some tc, Some mc -> - let _,msgWithPrefix = FSComp.SR.etProviderErrorWithContext(tpDesignation, tc, mc, this.Message) + let _, msgWithPrefix = + FSComp.SR.etProviderErrorWithContext (tpDesignation, tc, mc, this.Message) + msgWithPrefix | _ -> - let _,msgWithPrefix = FSComp.SR.etProviderError(tpDesignation, this.Message) + let _, msgWithPrefix = FSComp.SR.etProviderError (tpDesignation, this.Message) msgWithPrefix - + /// provides uniform way to handle plain and composite instances of TypeProviderError - member this.Iter f = + member this.Iter f = match errors with - | [_] -> f this + | [ _ ] -> f this | errors -> for msg in errors do - f (TypeProviderError(errNum, tpDesignation, m, [msg], typeNameContext, methodNameContext)) - -type TaintedContext = { TypeProvider: ITypeProvider; TypeProviderAssemblyRef: ILScopeRef; Lock: TypeProviderLock } - -[][] -type internal Tainted<'T> (context: TaintedContext, value: 'T) = + f (TypeProviderError(errNum, tpDesignation, m, [ msg ], typeNameContext, methodNameContext)) + +type TaintedContext = + { + TypeProvider: ITypeProvider + TypeProviderAssemblyRef: ILScopeRef + Lock: TypeProviderLock + } + +[] +[] +type internal Tainted<'T>(context: TaintedContext, value: 'T) = do - match box context.TypeProvider with - | null -> + match box context.TypeProvider with + | null -> assert false failwith "null ITypeProvider in Tainted constructor" | _ -> () - member _.TypeProviderDesignation = - !! context.TypeProvider.GetType().FullName + member _.TypeProviderDesignation = !!context.TypeProvider.GetType().FullName - member _.TypeProviderAssemblyRef = - context.TypeProviderAssemblyRef + member _.TypeProviderAssemblyRef = context.TypeProviderAssemblyRef - member this.Protect f (range: range) = - try + member this.Protect f (range: range) = + try context.Lock.AcquireLock(fun _ -> f value) with - | :? TypeProviderError -> reraise() - | :? AggregateException as ae -> - let errNum,_ = FSComp.SR.etProviderError("", "") - let messages = [for e in ae.InnerExceptions -> if isNull e.InnerException then e.Message else (e.Message + ": " + e.GetBaseException().Message)] - raise <| TypeProviderError(errNum, this.TypeProviderDesignation, range, messages) - | e -> - let errNum,_ = FSComp.SR.etProviderError("", "") - let error = if isNull e.InnerException then e.Message else (e.Message + ": " + e.GetBaseException().Message) - raise <| TypeProviderError((errNum, error), this.TypeProviderDesignation, range) + | :? TypeProviderError -> reraise () + | :? AggregateException as ae -> + let errNum, _ = FSComp.SR.etProviderError ("", "") + + let messages = + [ + for e in ae.InnerExceptions -> + if isNull e.InnerException then + e.Message + else + (e.Message + ": " + e.GetBaseException().Message) + ] + + raise + <| TypeProviderError(errNum, this.TypeProviderDesignation, range, messages) + | e -> + let errNum, _ = FSComp.SR.etProviderError ("", "") + + let error = + if isNull e.InnerException then + e.Message + else + (e.Message + ": " + e.GetBaseException().Message) + + raise <| TypeProviderError((errNum, error), this.TypeProviderDesignation, range) member _.TypeProvider = Tainted<_>(context, context.TypeProvider) - member this.PApply(f,range: range) = + member this.PApply(f, range: range) = let u = this.Protect f range Tainted(context, u) - member this.PApply2(f,range: range) = - let u1,u2 = this.Protect f range + member this.PApply2(f, range: range) = + let u1, u2 = this.Protect f range Tainted(context, u1), Tainted(context, u2) - member this.PApply3(f,range: range) = - let u1,u2,u3 = this.Protect f range + member this.PApply3(f, range: range) = + let u1, u2, u3 = this.Protect f range Tainted(context, u1), Tainted(context, u2), Tainted(context, u3) - member this.PApply4(f,range: range) = - let u1,u2,u3,u4 = this.Protect f range + member this.PApply4(f, range: range) = + let u1, u2, u3, u4 = this.Protect f range Tainted(context, u1), Tainted(context, u2), Tainted(context, u3), Tainted(context, u4) - member this.PApplyNoFailure f = this.PApply (f, range0) + member this.PApplyNoFailure f = this.PApply(f, range0) - member this.PApplyWithProvider(f, range: range) = + member this.PApplyWithProvider(f, range: range) = let u = this.Protect (fun x -> f (x, context.TypeProvider)) range Tainted(context, u) - member this.PApplyArray(f, methodName, range:range) = - let a : 'U[] MaybeNull = this.Protect f range - match a with - | Null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(methodName), this.TypeProviderDesignation, range) - | NonNull a -> a |> Array.map (fun u -> Tainted(context,u)) + member this.PApplyArray(f, methodName, range: range) = + let a: 'U[] MaybeNull = this.Protect f range - member this.PApplyFilteredArray(factory, filter, methodName, range:range) = - let a : 'U[] MaybeNull = this.Protect factory range - match a with - | Null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(methodName), this.TypeProviderDesignation, range) - | NonNull a -> a |> Array.filter filter |> Array.map (fun u -> Tainted(context,u)) + match a with + | Null -> + raise + <| TypeProviderError(FSComp.SR.etProviderReturnedNull (methodName), this.TypeProviderDesignation, range) + | NonNull a -> a |> Array.map (fun u -> Tainted(context, u)) - member this.PApplyOption(f, range: range) = + member this.PApplyFilteredArray(factory, filter, methodName, range: range) = + let a: 'U[] MaybeNull = this.Protect factory range + + match a with + | Null -> + raise + <| TypeProviderError(FSComp.SR.etProviderReturnedNull (methodName), this.TypeProviderDesignation, range) + | NonNull a -> a |> Array.filter filter |> Array.map (fun u -> Tainted(context, u)) + + member this.PApplyOption(f, range: range) = let a = this.Protect f range - match a with - | None -> None - | Some x -> Some (Tainted(context, x)) - member this.PUntaint(f,range: range) = this.Protect f range + match a with + | None -> None + | Some x -> Some(Tainted(context, x)) + + member this.PUntaint(f, range: range) = this.Protect f range member this.PUntaintNoFailure f = this.PUntaint(f, range0) @@ -158,28 +178,40 @@ type internal Tainted<'T> (context: TaintedContext, value: 'T) = member _.AccessObjectDirectly = value static member CreateAll(providerSpecs: (ITypeProvider * ILScopeRef) list) = - [for tp,nm in providerSpecs do - yield Tainted<_>({ TypeProvider=tp; TypeProviderAssemblyRef=nm; Lock=TypeProviderLock() },tp) ] - - member _.OfType<'U> () = + [ + for tp, nm in providerSpecs do + yield + Tainted<_>( + { + TypeProvider = tp + TypeProviderAssemblyRef = nm + Lock = TypeProviderLock() + }, + tp + ) + ] + + member _.OfType<'U>() = match box value with - | :? 'U as u -> Some (Tainted(context,u)) + | :? 'U as u -> Some(Tainted(context, u)) | _ -> None - member this.Coerce<'U> (range: range) = - Tainted(context, this.Protect(fun value -> box value :?> 'U) range) + member this.Coerce<'U>(range: range) = + Tainted(context, this.Protect (fun value -> box value :?> 'U) range) module internal Tainted = - let (|Null|NonNull|) (p:Tainted<'T | null>) : Choice> when 'T : not null and 'T : not struct = - if p.PUntaintNoFailure isNull then Null else NonNull (p.PApplyNoFailure nonNull) + let (|Null|NonNull|) (p: Tainted<'T | null>) : Choice> when 'T: not null and 'T: not struct = + if p.PUntaintNoFailure isNull then + Null + else + NonNull(p.PApplyNoFailure nonNull) - let Eq (p:Tainted<'T>) (v:'T) = p.PUntaintNoFailure (fun pv -> pv = v) + let Eq (p: Tainted<'T>) (v: 'T) = p.PUntaintNoFailure(fun pv -> pv = v) - let EqTainted (t1:Tainted<'T>) (t2:Tainted<'T>) = + let EqTainted (t1: Tainted<'T>) (t2: Tainted<'T>) = t1.PUntaintNoFailure(fun t1 -> t1 === t2.AccessObjectDirectly) - let GetHashCodeTainted (t:Tainted<'T>) = t.PUntaintNoFailure hash - + let GetHashCodeTainted (t: Tainted<'T>) = t.PUntaintNoFailure hash + #endif - diff --git a/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs b/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs index f69eaad8c30..2b038b751ef 100644 --- a/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs +++ b/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs @@ -1,3 +1,3 @@ -[] +[] do () diff --git a/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs.bsl b/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs.bsl index 8e83e55acfa..5562c7b55e1 100644 --- a/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs.bsl +++ b/tests/service/data/SyntaxTree/Attribute/RangeOfAttribute.fs.bsl @@ -9,24 +9,40 @@ ImplFile [{ TypeName = SynLongIdent ([MyAttribute], [], [None]) ArgExpr = Paren - (App - (NonAtomic, false, - App - (NonAtomic, true, - LongIdent - (false, - SynLongIdent - ([op_Equality], [], - [Some (OriginalNotation "=")]), None, - (2,18--2,19)), Ident foo, (2,14--2,19)), - Const - (String ("bar", Regular, (2,19--2,24)), - (2,19--2,24)), (2,14--2,24)), (2,13--2,14), - Some (2,24--2,25), (2,13--2,25)) + (Tuple + (false, + [App + (NonAtomic, false, + App + (NonAtomic, true, + LongIdent + (false, + SynLongIdent + ([op_Equality], [], + [Some (OriginalNotation "=")]), None, + (2,18--2,19)), Ident foo, (2,14--2,19)), + Const + (String ("bar", Regular, (2,19--2,24)), + (2,19--2,24)), (2,14--2,24)); + App + (NonAtomic, false, + App + (NonAtomic, true, + LongIdent + (false, + SynLongIdent + ([op_Equality], [], + [Some (OriginalNotation "=")]), None, + (2,30--2,31)), Ident mimi, (2,26--2,31)), + Const + (String ("baz", Regular, (2,31--2,36)), + (2,31--2,36)), (2,26--2,36))], [(2,24--2,25)], + (2,14--2,36)), (2,13--2,14), Some (2,36--2,37), + (2,13--2,37)) Target = None AppliesToGetterAndSetter = false - Range = (2,2--2,25) }] - Range = (2,0--2,27) }], (2,0--2,27)); + Range = (2,2--2,37) }] + Range = (2,0--2,39) }], (2,0--2,39)); Expr (Do (Const (Unit, (3,3--3,5)), (3,0--3,5)), (3,0--3,5))], PreXmlDocEmpty, [], None, (2,0--4,0), { LeadingKeyword = None })], (true, true), { ConditionalDirectives = []