From 1d562ef512061592a66eefbb6f98e4cceb85f64e Mon Sep 17 00:00:00 2001 From: Kevin Ransom Date: Fri, 8 Nov 2024 12:57:46 -0800 Subject: [PATCH] code --- src/Compiler/Checking/CheckDeclarations.fs | 2 +- .../Checking/Expressions/CheckExpressions.fs | 27 +-- .../Checking/Expressions/CheckExpressions.fsi | 3 +- src/Compiler/Checking/PostInferenceChecks.fs | 4 +- src/Compiler/Checking/SignatureConformance.fs | 7 +- src/Compiler/CodeGen/IlxGen.fs | 49 +++-- src/Compiler/Driver/fsc.fs | 2 +- src/Compiler/Optimize/Optimizer.fs | 6 +- src/Compiler/Service/IncrementalBuild.fs | 4 +- src/Compiler/TypedTree/CompilerGlobalState.fs | 4 +- src/Compiler/TypedTree/TypedTreeOps.fs | 175 +++++++++--------- src/Compiler/TypedTree/TypedTreeOps.fsi | 10 +- 12 files changed, 157 insertions(+), 136 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 80c1a656c2d..325bceee7ce 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -1042,7 +1042,7 @@ module MutRecBindingChecking = AddLocalTyconRefs true g cenv.amap tcref.Range [tcref] initialEnvForTycon // Make fresh version of the class type for type checking the members and lets * - let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars true // The basic iteration over the declarations in a single type definition let initialInnerState = (None, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index c6b1372843d..f56dd550f8b 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -1834,13 +1834,18 @@ let MakeAndPublishSimpleValsForMergedScope (cenv: cenv) env m (names: NameMap<_> // to C<_> occurs then generate C for a fresh type inference variable ?ty. //------------------------------------------------------------------------- -let FreshenTyconRef (g: TcGlobals) m rigid (tcref: TyconRef) declaredTyconTypars = +let FreshenTyconRef (g: TcGlobals) m rigid (tcref: TyconRef) declaredTyconTypars doCopyTypars = let origTypars = declaredTyconTypars let clearStaticReq = g.langVersion.SupportsFeature LanguageFeature.InterfacesWithAbstractStaticMembers - let freshTypars = copyTypars clearStaticReq origTypars - if rigid <> TyparRigidity.Rigid then - for tp in freshTypars do - tp.SetRigidity rigid + let freshTypars = + if doCopyTypars then + let typars = copyTypars clearStaticReq origTypars + if rigid <> TyparRigidity.Rigid then + for tp in typars do + tp.SetRigidity rigid + typars + else + origTypars let renaming, tinst = FixupNewTypars m [] [] origTypars freshTypars let origTy = TType_app(tcref, List.map mkTyparTy origTypars, g.knownWithoutNull) @@ -2673,11 +2678,11 @@ module EventDeclarationNormalization = /// Make a copy of the "this" type for a generic object type, e.g. List<'T> --> List<'?> for a fresh inference variable. /// Also adjust the "this" type to take into account whether the type is a struct. -let FreshenObjectArgType (cenv: cenv) m rigid tcref isExtrinsic declaredTyconTypars = +let FreshenObjectArgType (cenv: cenv) m rigid tcref isExtrinsic declaredTyconTypars (doCopyTypars: bool) = let g = cenv.g let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = - FreshenTyconRef g m rigid tcref declaredTyconTypars + FreshenTyconRef g m rigid tcref declaredTyconTypars doCopyTypars // Struct members have a byref 'this' type (unless they are extrinsic extension members) let thisTy = @@ -4208,7 +4213,7 @@ and TcValSpec (cenv: cenv) env declKind newOk containerInfo memFlagsOpt thisTyOp | Some(MemberOrValContainerInfo(tcref, _, _, _, declaredTyconTypars)) -> let isExtrinsic = (declKind = ExtrinsicExtensionBinding) let _, enclosingDeclaredTypars, _, _, thisTy = - FreshenObjectArgType cenv m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars + FreshenObjectArgType cenv m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars (not cenv.g.realsig) // An implemented interface type is in terms of the type's type parameters. // We need a signature in terms of the values' type parameters. @@ -11894,7 +11899,7 @@ and AnalyzeRecursiveStaticMemberOrValDecl CheckForNonAbstractInterface g declKind tcref memberFlags true id.idRange let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let tcrefObjTy, enclosingDeclaredTypars, renaming, _, _ = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, _, _ = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars (not cenv.g.realsig) let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner let envinner = MakeInnerEnvForTyconRef envinner tcref isExtrinsic @@ -11919,7 +11924,7 @@ and AnalyzeRecursiveStaticMemberOrValDecl error(Error(FSComp.SR.tcConstructorsDisallowedInExceptionAugmentation(), id.idRange)) let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars true let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner let envinner = MakeInnerEnvForTyconRef envinner tcref isExtrinsic @@ -12005,7 +12010,7 @@ and AnalyzeRecursiveInstanceMemberDecl // The type being augmented tells us the type of 'this' let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars (not cenv.g.realsig) let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fsi b/src/Compiler/Checking/Expressions/CheckExpressions.fsi index 0e4e17a8f83..4124c9f8bb2 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fsi +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fsi @@ -483,7 +483,8 @@ val FreshenObjectArgType: tcref: TyconRef -> isExtrinsic: bool -> declaredTyconTypars: Typar list -> - TType * Typar list * TyparInstantiation * TType * TType + bool -> + TType * Typar list * TyparInstantiation * TType * TType /// Get the accumulated module/namespace type for the current module/namespace being processed. val GetCurrAccumulatedModuleOrNamespaceType: env: TcEnv -> ModuleOrNamespaceType diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 645f43fe3cb..c7f8b50ed0e 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2664,9 +2664,9 @@ and CheckModuleSpec cenv env mbind = let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } CheckDefnInModule cenv env rhs -let CheckImplFileContents cenv env implFileTy implFileContents = +let CheckImplFileContents cenv env implFileTy implFileContents = let rpi, mhi = ComputeRemappingFromImplementationToSignature cenv.g implFileContents implFileTy - let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: env.sigToImplRemapInfo } + let env = { env with sigToImplRemapInfo = (mkRepackageRemapping rpi cenv.g.realsig, mhi) :: env.sigToImplRemapInfo } UpdatePrettyTyparNames.updateModuleOrNamespaceType implFileTy CheckDefnInModule cenv env implFileContents diff --git a/src/Compiler/Checking/SignatureConformance.fs b/src/Compiler/Checking/SignatureConformance.fs index 8e8dc84eb2b..1ea7e30cd91 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -15,6 +15,7 @@ open FSharp.Compiler.Features open FSharp.Compiler.InfoReader open FSharp.Compiler.Syntax open FSharp.Compiler.SyntaxTreeOps +open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics @@ -48,16 +49,16 @@ exception DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer of range: range // Use a type to capture the constant, common parameters -type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = +type Checker(g: TcGlobals, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = // Build a remap that maps tcrefs in the signature to tcrefs in the implementation // Used when checking attributes. let sigToImplRemap = - let remap = Remap.Empty + let remap = {Remap.Empty with realsig = g.realsig} let remap = (remapInfo.RepackagedEntities, remap) ||> List.foldBack (fun (implTcref, signTcref) acc -> addTyconRefRemap signTcref implTcref acc) let remap = (remapInfo.RepackagedVals, remap) ||> List.foldBack (fun (implValRef, signValRef) acc -> addValRemap signValRef.Deref implValRef.Deref acc) remap - + // For all attributable elements (types, modules, exceptions, record fields, unions, parameters, generic type parameters) // // (a) Start with lists AImpl and ASig containing the attributes in the implementation and signature, in declaration order diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 2a1c876b8f5..75cf8847f5f 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -1197,6 +1197,10 @@ and IlxGenEnv = /// Full list of enclosing bound values. First non-compiler-generated element is used to help give nice names for closures and other expressions. letBoundVars: ValRef list + + /// nested type generic parameters for currentloc + nestedTypars: Zset + /// The set of IL local variable indexes currently in use by lexically scoped variables, to allow reuse on different branches. /// Really an integer set. liveLocals: IntMap @@ -1259,7 +1263,7 @@ let AddTyparsToEnv typars (eenv: IlxGenEnv) = let AddSignatureRemapInfo _msg (rpi, mhi) eenv = { eenv with - sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: eenv.sigToImplRemapInfo + sigToImplRemapInfo = (mkRepackageRemapping rpi eenv.realsig, mhi) :: eenv.sigToImplRemapInfo } //-------------------------------------------------------------------------- @@ -1281,7 +1285,7 @@ let AddStorageForVal (g: TcGlobals) (v, s) eenv = 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 + match tryRescopeVal g.fslibCcu { Remap.Empty with realsig = g.realsig } v with | ValueNone -> eenv | ValueSome vref -> match vref.TryDeref with @@ -6892,14 +6896,6 @@ and GenFreevar cenv m eenvouter tyenvinner (fv: Val) = and GetIlxClosureFreeVars cenv m (thisVars: ValRef list) boxity eenv takenNames expr = let g = cenv.g - // Choose a base name for the closure - let basename = - let boundv = eenv.letBoundVars |> List.tryFind (fun v -> not v.IsCompilerGenerated) - - match boundv with - | Some v -> v.CompiledName cenv.g.CompilerGlobalState - | None -> "clo" - // Get a unique stamp for the closure. This must be stable for things that can be part of a let rec. let uniq = match expr with @@ -6909,18 +6905,28 @@ and GetIlxClosureFreeVars cenv m (thisVars: ValRef list) boxity eenv takenNames | _ -> newUnique () // Choose a name for the closure - let ilCloTypeRef = + let ilCloTypeRef, initialFreeTyvars = + let boundvar = + eenv.letBoundVars |> List.tryFind (fun v -> not v.IsCompilerGenerated) + + let basename = + match boundvar with + | Some v -> v.CompiledName cenv.g.CompilerGlobalState + | None -> "clo" + // FSharp 1.0 bug 3404: System.Reflection doesn't like '.' and '`' in type names let basenameSafeForUseAsTypename = CleanUpGeneratedTypeName basename - let suffixmark = expr.Range - let cloName = // Ensure that we have an g.CompilerGlobalState assert (g.CompilerGlobalState |> Option.isSome) - g.CompilerGlobalState.Value.StableNameGenerator.GetUniqueCompilerGeneratedName(basenameSafeForUseAsTypename, suffixmark, uniq) + g.CompilerGlobalState.Value.StableNameGenerator.GetUniqueCompilerGeneratedName(basenameSafeForUseAsTypename, expr.Range, uniq) + + let ilCloTypeRef = NestedTypeRefForCompLoc eenv.cloc cloName + + let initialFreeTyvars = { emptyFreeTyvars with FreeTypars = eenv.nestedTypars } - NestedTypeRefForCompLoc eenv.cloc cloName + ilCloTypeRef, initialFreeTyvars // Collect the free variables of the closure let cloFreeVarResults = @@ -6931,7 +6937,8 @@ and GetIlxClosureFreeVars cenv m (thisVars: ValRef list) boxity eenv takenNames | None -> opts | Some(tcref, _, typars, _) -> opts.WithTemplateReplacement(tyconRefEq g tcref, typars) - freeInExpr opts expr + //freeInExpr opts expr + accFreeInExpr opts expr { emptyFreeVars with FreeTyvars = initialFreeTyvars } // Partition the free variables when some can be accessed from places besides the immediate environment // Also filter out the current value being bound, if any, as it is available from the "this" @@ -8166,7 +8173,7 @@ and GenLetRecFixup cenv cgbuf eenv (ilxCloSpec: IlxClosureSpec, e, ilField: ILFi CG.EmitInstr cgbuf (pop 2) Push0 (mkNormalStfld (mkILFieldSpec (ilField.FieldRef, ilxCloSpec.ILType))) /// Generate letrec bindings -and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) (dict: Dictionary option) = +and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) (dict: Dictionary option) = // 'let rec' bindings are always considered to be in loops, that is each may have backward branches for the // tailcalls back to the entry point. This means we don't rely on zero-init of mutable locals @@ -8320,7 +8327,8 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) ( ||> List.fold (fun forwardReferenceSet (bind: Binding) -> GenBinding cenv cgbuf eenv bind false updateForwardReferenceSet bind forwardReferenceSet) - | true, tref -> + | true, (tc, tref) -> + let eenv = { eenv with nestedTypars = (eenv.nestedTypars |> Zset.addList tc.TyparsNoRange) } CodeGenInitMethod cenv cgbuf @@ -10250,7 +10258,7 @@ and GenModuleOrNamespaceContents cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo | TMDefRec(_isRec, opens, tycons, mbinds, m) -> let eenvinner = AddDebugImportsToEnv cenv eenv opens - let dict = Some(Dictionary()) + let dict = Some(Dictionary()) for tc in tycons do let optTref = @@ -10260,7 +10268,7 @@ and GenModuleOrNamespaceContents cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo GenTypeDef cenv cgbuf.mgbuf lazyInitInfo eenv m tc match optTref with - | Some tref -> dict.Value.Add(tc.Stamp, tref) + | Some tref -> dict.Value.Add(tc.Stamp, (tc, tref)) | None -> () // Generate chunks of non-nested bindings together to allow recursive fixups. @@ -11984,6 +11992,7 @@ let GetEmptyIlxGenEnv (g: TcGlobals) ccu = someTypeInThisAssembly = g.ilg.typ_Object // dummy value isFinalFile = false letBoundVars = [] + nestedTypars = Zset.empty typarOrder liveLocals = IntMap.empty () innerVals = [] sigToImplRemapInfo = [] (* "module remap info" *) diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 1d17950a9ac..28ccaa31493 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -841,7 +841,7 @@ let main3 = // Encode the signature data ReportTime tcConfig "Encode Interface Data" - let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents + let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents tcConfig.realsig let sigDataAttributes, sigDataResources = try diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 51d889f5691..aba0da6b880 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -588,7 +588,7 @@ let BindExternalLocalVal cenv (v: Val) vval 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 + match tryRescopeVal g.fslibCcu {Remap.Empty with realsig = g.realsig} v with | ValueSome vref -> BindValueForFslib vref.nlr v vval env | _ -> env else env @@ -1523,8 +1523,8 @@ let RemapOptimizationInfo g tmenv = remapLazyModulInfo /// Hide information when a value is no longer visible -let AbstractAndRemapModulInfo g (repackage, hidden) info = - let mrpi = mkRepackageRemapping repackage +let AbstractAndRemapModulInfo (g: TcGlobals) (repackage, hidden) info = + let mrpi = mkRepackageRemapping repackage g.realsig let info = info |> AbstractLazyModulInfoByHiding false hidden let info = info |> RemapOptimizationInfo g mrpi info diff --git a/src/Compiler/Service/IncrementalBuild.fs b/src/Compiler/Service/IncrementalBuild.fs index 872b27fdcd9..43f656c7cee 100644 --- a/src/Compiler/Service/IncrementalBuild.fs +++ b/src/Compiler/Service/IncrementalBuild.fs @@ -634,9 +634,9 @@ module Utilities = /// as a cross-assembly reference. Note the assembly has not been generated on disk, so this is /// a virtualized view of the assembly contents as computed by background checking. [] -type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, generatedCcu: CcuThunk, outfile, topAttrs, assemblyName, ilAssemRef) = +type RawFSharpAssemblyDataBackedByLanguageService (tcConfig: TcConfig, tcGlobals, generatedCcu: CcuThunk, outfile, topAttrs, assemblyName, ilAssemRef) = - let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents + let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents tcConfig.realsig let sigData = let _sigDataAttributes, sigDataResources = EncodeSignatureData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, true) diff --git a/src/Compiler/TypedTree/CompilerGlobalState.fs b/src/Compiler/TypedTree/CompilerGlobalState.fs index 72da3da4f58..119cfe287fd 100644 --- a/src/Compiler/TypedTree/CompilerGlobalState.fs +++ b/src/Compiler/TypedTree/CompilerGlobalState.fs @@ -73,4 +73,6 @@ 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() = System.Threading.Interlocked.Increment &stampCount +let newStamp() = + let x = System.Threading.Interlocked.Increment &stampCount + x \ No newline at end of file diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 71f26dbf95b..42f84d91555 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -123,7 +123,10 @@ let emptyTyparInst = ([]: TyparInstantiation) [] type Remap = - { tpinst: TyparInstantiation + { /// are we producing real signature files + realsig: bool + + tpinst: TyparInstantiation /// Values to remap valRemap: ValRemap @@ -134,14 +137,12 @@ type Remap = /// Remove existing trait solutions? removeTraitSolutions: bool } -let emptyRemap = - { tpinst = emptyTyparInst - tyconRefRemap = emptyTyconRefRemap - valRemap = ValMap.Empty - removeTraitSolutions = false } - -type Remap with - static member Empty = emptyRemap + static member Empty ={ + realsig = false + tpinst = [] + tyconRefRemap = TyconRefMap<_>.Empty + valRemap = ValMap.Empty + removeTraitSolutions = false } //-------------------------------------------------------------------------- // Substitute for type variables and remap type constructors @@ -150,8 +151,8 @@ type Remap with let addTyconRefRemap tcref1 tcref2 tmenv = { tmenv with tyconRefRemap = tmenv.tyconRefRemap.Add tcref1 tcref2 } -let isRemapEmpty remap = - isNil remap.tpinst && +let isRemapEmpty remap = + isNil remap.tpinst && remap.tyconRefRemap.IsEmpty && remap.valRemap.IsEmpty @@ -218,8 +219,8 @@ let rec remapTypeAux (tyenv: Remap) (ty: TType) = 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 (tps, ty) -> + let tpsR, tyenv = copyAndRemapAndBindTypars tyenv tps false// @@@@@@@@ TType_forall (tpsR, remapTypeAux tyenv ty) | TType_measure unt -> @@ -323,20 +324,23 @@ and bindTypars tps tyargs tpinst = // This version is used to remap most type parameters, e.g. ones bound at tycons, vals, records // See notes below on remapTypeFull for why we have a function that accepts remapAttribs as an argument -and copyAndRemapAndBindTyparsFull remapAttrib tyenv tps = - match tps with - | [] -> tps, tyenv - | _ -> - let tpsR = copyTypars false tps - let tyenv = { tyenv with tpinst = bindTypars tps (generalizeTypars tpsR) tyenv.tpinst } - (tps, tpsR) ||> List.iter2 (fun tporig tp -> - tp.SetConstraints (remapTyparConstraintsAux tyenv tporig.Constraints) - tp.SetAttribs (tporig.Attribs |> remapAttrib)) - tpsR, tyenv +and copyAndRemapAndBindTyparsFull remapAttrib tyenv tps doCopyTypars = + match tps with + | [] -> tps, tyenv + | _ -> + match doCopyTypars with + | true -> + 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 + | false -> tps, tyenv // copies bound typars, extends tpinst -and copyAndRemapAndBindTypars tyenv tps = - copyAndRemapAndBindTyparsFull (fun _ -> []) tyenv tps +and copyAndRemapAndBindTypars tyenv tps doCopyTypars = + copyAndRemapAndBindTyparsFull (fun _ -> []) tyenv tps doCopyTypars and remapValLinkage tyenv (vlink: ValLinkageFullKey) = let tyOpt = vlink.TypeForLinkage @@ -384,13 +388,13 @@ let remapTypes tyenv x = /// 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 true + 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 @@ -399,25 +403,21 @@ let remapParam tyenv (TSlotParam(nm, ty, fl1, fl2, fl3, attribs) as x) = 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 + let ctpsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenv ctps (not tyenv.realsig) + let methTyparsR, tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tyenvinner methTypars (not tyenv.realsig) 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 } +let mkInstRemap tpinst realsig = { Remap.Empty with tpinst = tpinst; realsig = realsig } // 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 instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst false) x // Todo: figure out how to set this correctly +let instTypeWithRealsig tpinst realsig x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst realsig) x +let instTypes tpinst x = if isNil tpinst then x else remapTypesAux (mkInstRemap tpinst false) x +let instTrait tpinst x = if isNil tpinst then x else remapTraitInfo (mkInstRemap tpinst false) x +let instTyparConstraints tpinst x = if isNil tpinst then x else remapTyparConstraintsAux (mkInstRemap tpinst false) x +let instSlotSig tpinst ss = remapSlotSig (fun _ -> []) (mkInstRemap tpinst false) ss let copySlotSig ss = remapSlotSig (fun _ -> []) Remap.Empty ss - let mkTyparToTyparRenaming tpsorig tps = let tinst = generalizeTypars tps mkTyparInst tpsorig tinst, tinst @@ -4853,11 +4853,11 @@ type SignatureHidingInfo = 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 } +let mkRepackageRemapping mrpi (realsig: bool) = + { Remap.Empty with + realsig = realsig + valRemap = ValMap.OfList (mrpi.RepackagedVals |> List.map (fun (vref, x) -> vref.Deref, x)) + tyconRefRemap = TyconRefMap.OfList mrpi.RepackagedEntities } //-------------------------------------------------------------------------- // Compute instances of the above for mty -> mty @@ -5868,10 +5868,7 @@ let remapAttribKind tmenv k = | ILAttrib _ as x -> x | FSAttrib vref -> FSAttrib(remapValRef tmenv vref) -let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps = - let tps', tyenvinner = copyAndRemapAndBindTyparsFull remapAttrib tmenv tps - let tmenvinner = tyenvinner - tps', tmenvinner +let tmenvCopyRemapAndBindTypars remapAttrib tmenv tps = copyAndRemapAndBindTyparsFull remapAttrib tmenv tps (not tmenv.realsig) type RemapContext = { g: TcGlobals @@ -6082,7 +6079,7 @@ and remapOpExpr (ctxt: RemapContext) (compgen: ValCopyFlag) (tmenv: Remap) (op, 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 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 @@ -6332,38 +6329,40 @@ and copyTycon compgen (tycon: 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. let vsR, tmenvinner = copyAndRemapAndBindVals ctxt compgen tmenvinner vs // "if a type constructor is hidden then all its inner values and inner type constructors must also be hidden" - // Hence we can just lookup the inner tycon/value mappings in the tables. - - let lookupVal (v: Val) = - let vref = - try - let res = tmenvinner.valRemap[v] - res - with :? KeyNotFoundException -> + // Hence we can just lookup the inner tycon/value mappings in the tables. + + let lookupVal (v: Val) = + let vref = + try + let res = tmenvinner.valRemap[v] + res + with :? KeyNotFoundException -> errorR(InternalError(sprintf "couldn't remap internal value '%s'" v.LogicalName, v.Range)) mkLocalValRef v vref.Deref - let lookupTycon tycon = - let tcref = - try + let lookupTycon tycon = + let tcref = + try let res = tmenvinner.tyconRefRemap[mkLocalTyconRef tycon] res - with :? KeyNotFoundException -> + 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)) tcdR.entity_typars <- LazyWithContext.NotLazy tpsR @@ -6371,17 +6370,15 @@ and copyAndRemapAndBindTyconsAndVals ctxt compgen tmenv tycons vs = 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 } - | _ -> + | _ -> tcdR.SetTypeAbbrev typeAbbrevR tcdR.SetExceptionInfo exnInfoR) tyconsR, vsR, tmenvinner - and allTyconsOfTycon (tycon: Tycon) = seq { yield tycon for nestedTycon in tycon.ModuleOrNamespaceType.AllEntities do @@ -6495,19 +6492,19 @@ let remapPossibleForallTy g tmenv ty = let copyModuleOrNamespaceType g compgen mtyp = let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } - copyAndRemapAndBindModTy ctxt compgen Remap.Empty mtyp |> fst + copyAndRemapAndBindModTy ctxt compgen {Remap.Empty with realsig = g.realsig} mtyp |> fst let copyExpr g compgen e = let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } - remapExprImpl ctxt compgen Remap.Empty e + remapExprImpl ctxt compgen {Remap.Empty with realsig = g.realsig} e let copyImplFile g compgen e = let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } - remapImplFile ctxt compgen Remap.Empty e |> fst + remapImplFile ctxt compgen {Remap.Empty with realsig = g.realsig} e |> fst let instExpr g tpinst e = let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") } - remapExprImpl ctxt CloneAll (mkInstRemap tpinst) e + remapExprImpl ctxt CloneAll (mkInstRemap tpinst g.realsig) e //-------------------------------------------------------------------------- // Replace Marks - adjust debugging marks when a lambda gets @@ -8503,19 +8500,21 @@ let MakeArgsForTopArgs _g m argTysl tpenv = fst (mkCompGenLocal m nm ty))) let AdjustValForExpectedValReprInfo g m (vref: ValRef) flags valReprInfo = - let tps, argTysl, retTy, _ = GetValReprTypeInFSharpForm g valReprInfo vref.Type m - let tpsR = copyTypars false tps + let tpsR = + match g.realsig with + | true -> tps + | false -> copyTypars false tps let tyargsR = List.map mkTyparTy tpsR let tpenv = bindTypars tps tyargsR emptyTyparInst - let rtyR = instType tpenv retTy + let rtyR = instTypeWithRealsig tpenv g.realsig 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) + 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 @@ -9788,7 +9787,7 @@ and RewriteImplFile env implFile = // accessed via non local references. //-------------------------------------------------------------------------- -let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) = +let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) realsig = let accEntityRemap (entity: Entity) acc = match tryRescopeEntity viewedCcu entity with @@ -9812,7 +9811,7 @@ let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) = let entities = allEntitiesOfModuleOrNamespaceTy mty let vs = allValsOfModuleOrNamespaceTy mty // Remap the entities first so we can correctly remap the types in the signatures of the ValLinkageFullKey's in the value references - let acc = List.foldBack accEntityRemap entities Remap.Empty + let acc = List.foldBack accEntityRemap entities { Remap.Empty with realsig = realsig } let allRemap = List.foldBack accValRemap vs acc allRemap diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index 85c2adaab91..58c30f5f3cb 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -558,7 +558,8 @@ type ValRemap = ValMap /// Represents a combination of substitutions/instantiations where things replace other things during remapping [] type Remap = - { tpinst: TyparInstantiation + { realsig: bool + tpinst: TyparInstantiation valRemap: ValRemap tyconRefRemap: TyconRefRemap removeTraitSolutions: bool } @@ -1184,6 +1185,9 @@ val accFreeInDecisionTree: FreeVarOptions -> DecisionTree -> FreeVars -> FreeVar /// Get the free variables in a module definition. val freeInModuleOrNamespace: FreeVarOptions -> ModuleOrNamespaceContents -> FreeVars +/// Get the free variables in an expression with accumulator +val accFreeInExpr: FreeVarOptions -> Expr -> FreeVars -> FreeVars + /// Get the free variables in an expression. val freeInExpr: FreeVarOptions -> Expr -> FreeVars @@ -1312,7 +1316,7 @@ val ComputeSignatureHidingInfoAtAssemblyBoundary: ModuleOrNamespaceType -> Signa val ComputeImplementationHidingInfoAtAssemblyBoundary: ModuleOrNamespaceContents -> SignatureHidingInfo -> SignatureHidingInfo -val mkRepackageRemapping: SignatureRepackageInfo -> Remap +val mkRepackageRemapping: SignatureRepackageInfo -> bool -> Remap /// Wrap one module or namespace implementation in a 'namespace N' outer wrapper val wrapModuleOrNamespaceContentsInNamespace: @@ -1341,7 +1345,7 @@ val tryRescopeVal: CcuThunk -> Remap -> Val -> ValRef voption /// of an assembly, compute a remapping that converts local references to non-local references. /// This remapping must be applied to all pickled expressions and types /// exported from the assembly. -val MakeExportRemapping: CcuThunk -> ModuleOrNamespace -> Remap +val MakeExportRemapping: CcuThunk -> ModuleOrNamespace -> bool -> Remap /// Make a remapping table for viewing a module or namespace 'from the outside' val ApplyExportRemappingToEntity: TcGlobals -> Remap -> ModuleOrNamespace -> ModuleOrNamespace