From 4a7fdf123e7ec840441c791163e955dcc3ee638c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 7 Sep 2021 16:05:48 +0100 Subject: [PATCH 1/8] code cleanup --- src/fsharp/CheckComputationExpressions.fs | 402 +++++++++++----------- 1 file changed, 200 insertions(+), 202 deletions(-) diff --git a/src/fsharp/CheckComputationExpressions.fs b/src/fsharp/CheckComputationExpressions.fs index ae78f8d9b3a..1c9aecdc594 100644 --- a/src/fsharp/CheckComputationExpressions.fs +++ b/src/fsharp/CheckComputationExpressions.fs @@ -782,7 +782,6 @@ let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, inter // zip expr1 expr2 (fun pat1 pat3 -> ...) | ForEachThenJoinOrGroupJoinOrZipClause true (isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, secondResultPatOpt, mOpCore, innerComp) -> - if q = CustomOperationsMode.Denied then error(Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere(), nm.idRange)) let firstSource = mkSourceExprConditional isFromSource firstSource let secondSource = mkSourceExpr secondSource @@ -1180,20 +1179,40 @@ let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, inter // or // build.Bind(build.MergeSources(expr1, expr2), ...) | SynExpr.LetOrUseBang(letSpBind, false, isFromSource, letPat, letRhsExpr, andBangBindings, innerComp, letBindRange) -> - if cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang then - if isQuery then error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), letBindRange)) - let bindRange = match letSpBind with DebugPointAtBinding.Yes m -> m | _ -> letRhsExpr.Range - let sources = (letRhsExpr :: [for _, _, _, _, andExpr, _ in andBangBindings -> andExpr ]) |> List.map (mkSourceExprConditional isFromSource) - let pats = letPat :: [for _, _, _, andPat, _, _ in andBangBindings -> andPat ] - let sourcesRange = sources |> List.map (fun e -> e.Range) |> List.reduce unionRanges - - let numSources = sources.Length - let bindReturnNName = "Bind"+string numSources+"Return" - let bindNName = "Bind"+string numSources - - // Check if this is a Bind2Return etc. - let hasBindReturnN = not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindReturnNName builderTy)) - if hasBindReturnN && Option.isSome (convertSimpleReturnToExpr varSpace innerComp) then + if not (cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang) then + error(Error(FSComp.SR.tcAndBangNotSupported(), comp.Range)) + + if isQuery then + error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), letBindRange)) + + let bindRange = match letSpBind with DebugPointAtBinding.Yes m -> m | _ -> letRhsExpr.Range + let sources = (letRhsExpr :: [for _, _, _, _, andExpr, _ in andBangBindings -> andExpr ]) |> List.map (mkSourceExprConditional isFromSource) + let pats = letPat :: [for _, _, _, andPat, _, _ in andBangBindings -> andPat ] + let sourcesRange = sources |> List.map (fun e -> e.Range) |> List.reduce unionRanges + + let numSources = sources.Length + let bindReturnNName = "Bind"+string numSources+"Return" + let bindNName = "Bind"+string numSources + + // Check if this is a Bind2Return etc. + let hasBindReturnN = not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindReturnNName builderTy)) + if hasBindReturnN && Option.isSome (convertSimpleReturnToExpr varSpace innerComp) then + let consumePat = SynPat.Tuple(false, pats, letPat.Range) + + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType()) env tpenv (consumePat, None) + vspecs, envinner) + + Some (transBind q varSpace bindRange bindNName sources consumePat letSpBind innerComp translatedCtxt) + + else + + // Check if this is a Bind2 etc. + let hasBindN = not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindNName builderTy)) + if hasBindN then let consumePat = SynPat.Tuple(false, pats, letPat.Range) // Add the variables to the query variable space, on demand @@ -1204,83 +1223,65 @@ let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, inter vspecs, envinner) Some (transBind q varSpace bindRange bindNName sources consumePat letSpBind innerComp translatedCtxt) - else - // Check if this is a Bind2 etc. - let hasBindN = not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindNName builderTy)) - if hasBindN then - let consumePat = SynPat.Tuple(false, pats, letPat.Range) + // Look for the maximum supported MergeSources, MergeSources3, ... + let mkMergeSourcesName n = if n = 2 then "MergeSources" else "MergeSources"+(string n) - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType()) env tpenv (consumePat, None) - vspecs, envinner) - - Some (transBind q varSpace bindRange bindNName sources consumePat letSpBind innerComp translatedCtxt) - else - - // Look for the maximum supported MergeSources, MergeSources3, ... - let mkMergeSourcesName n = if n = 2 then "MergeSources" else "MergeSources"+(string n) + let maxMergeSources = + let rec loop (n: int) = + let mergeSourcesName = mkMergeSourcesName n + if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad mergeSourcesName builderTy) then + (n-1) + else + loop (n+1) + loop 2 - let maxMergeSources = - let rec loop (n: int) = - let mergeSourcesName = mkMergeSourcesName n - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad mergeSourcesName builderTy) then - (n-1) - else - loop (n+1) - loop 2 + if maxMergeSources = 1 then error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), bindRange)) - if maxMergeSources = 1 then error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), bindRange)) + let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = + let numSourcesAndPats = sourcesAndPats.Length + assert (numSourcesAndPats <> 0) + if numSourcesAndPats = 1 then + sourcesAndPats.[0] - let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = - let numSourcesAndPats = sourcesAndPats.Length - assert (numSourcesAndPats <> 0) - if numSourcesAndPats = 1 then - sourcesAndPats.[0] + elif numSourcesAndPats <= maxMergeSources then - elif numSourcesAndPats <= maxMergeSources then + // Call MergeSources2(e1, e2), MergeSources3(e1, e2, e3) etc + let mergeSourcesName = mkMergeSourcesName numSourcesAndPats - // Call MergeSources2(e1, e2), MergeSources3(e1, e2, e3) etc - let mergeSourcesName = mkMergeSourcesName numSourcesAndPats + if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad mergeSourcesName builderTy) then + error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), bindRange)) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad mergeSourcesName builderTy) then - error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), bindRange)) + let source = mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) + let pat = SynPat.Tuple(false, List.map snd sourcesAndPats, letPat.Range) + source, pat - let source = mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) - let pat = SynPat.Tuple(false, List.map snd sourcesAndPats, letPat.Range) - source, pat + else - else + // Call MergeSourcesMax(e1, e2, e3, e4, (...)) + let nowSourcesAndPats, laterSourcesAndPats = List.splitAt (maxMergeSources - 1) sourcesAndPats + let mergeSourcesName = mkMergeSourcesName maxMergeSources - // Call MergeSourcesMax(e1, e2, e3, e4, (...)) - let nowSourcesAndPats, laterSourcesAndPats = List.splitAt (maxMergeSources - 1) sourcesAndPats - let mergeSourcesName = mkMergeSourcesName maxMergeSources + if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad mergeSourcesName builderTy) then + error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), bindRange)) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad mergeSourcesName builderTy) then - error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), bindRange)) + let laterSource, laterPat = mergeSources laterSourcesAndPats + let source = mkSynCall mergeSourcesName sourcesRange (List.map fst nowSourcesAndPats @ [laterSource]) + let pat = SynPat.Tuple(false, List.map snd nowSourcesAndPats @ [laterPat], letPat.Range) + source, pat - let laterSource, laterPat = mergeSources laterSourcesAndPats - let source = mkSynCall mergeSourcesName sourcesRange (List.map fst nowSourcesAndPats @ [laterSource]) - let pat = SynPat.Tuple(false, List.map snd nowSourcesAndPats @ [laterPat], letPat.Range) - source, pat + let mergedSources, consumePat = mergeSources (List.zip sources pats) + + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType()) env tpenv (consumePat, None) + vspecs, envinner) - let mergedSources, consumePat = mergeSources (List.zip sources pats) - - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType()) env tpenv (consumePat, None) - vspecs, envinner) - - // Build the 'Bind' call - Some (transBind q varSpace bindRange "Bind" [mergedSources] consumePat letSpBind innerComp translatedCtxt) - else - error(Error(FSComp.SR.tcAndBangNotSupported(), comp.Range)) + // Build the 'Bind' call + Some (transBind q varSpace bindRange "Bind" [mergedSources] consumePat letSpBind innerComp translatedCtxt) | SynExpr.Match (spMatch, expr, clauses, m) -> let mMatch = match spMatch with DebugPointAtBinding.Yes mMatch -> mMatch | _ -> m @@ -1307,30 +1308,32 @@ let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, inter let mTry = match spTry with DebugPointAtTry.Yes m -> m.NoteDebugPoint(RangeDebugPointKind.Try) | _ -> mTryToLast if isQuery then error(Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries(), mTry)) + let clauses = clauses |> List.map (fun (SynMatchClause(pat, cond, arrow, clauseComp, patm, sp)) -> SynMatchClause(pat, cond, arrow, transNoQueryOps clauseComp, patm, sp)) let consumeExpr = SynExpr.MatchLambda(true, mTryToLast, clauses, DebugPointAtBinding.NoneAtSticky, mTryToLast) if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryWith" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("TryWith"), mTry)) + if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"), mTry)) Some(translatedCtxt (mkSynCall "TryWith" mTry [mkSynCall "Delay" mTry [mkSynDelay2 (transNoQueryOps innerComp)]; consumeExpr])) - | SynExpr.YieldOrReturnFrom ((isYield, _), yieldExpr, m) -> - let yieldExpr = mkSourceExpr yieldExpr - if isYield then - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "YieldFrom" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("YieldFrom"), m)) - Some (translatedCtxt (mkSynCall "YieldFrom" m [yieldExpr])) + | SynExpr.YieldOrReturnFrom ((true, _), yieldExpr, m) -> + let yieldFromExpr = mkSourceExpr yieldExpr + if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "YieldFrom" builderTy) then + error(Error(FSComp.SR.tcRequireBuilderMethod("YieldFrom"), m)) + Some (translatedCtxt (mkSynCall "YieldFrom" m [yieldFromExpr])) + | SynExpr.YieldOrReturnFrom ((false, _), returnedExpr, m) -> + let returnFromExpr = mkSourceExpr returnedExpr + if isQuery then error(Error(FSComp.SR.tcReturnMayNotBeUsedInQueries(), m)) + if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "ReturnFrom" builderTy) then + errorR(Error(FSComp.SR.tcRequireBuilderMethod("ReturnFrom"), m)) + Some (translatedCtxt returnFromExpr) else - if isQuery then error(Error(FSComp.SR.tcReturnMayNotBeUsedInQueries(), m)) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "ReturnFrom" builderTy) then - errorR(Error(FSComp.SR.tcRequireBuilderMethod("ReturnFrom"), m)) - Some (translatedCtxt yieldExpr) - else - Some (translatedCtxt (mkSynCall "ReturnFrom" m [yieldExpr])) + Some (translatedCtxt (mkSynCall "ReturnFrom" m [returnFromExpr])) | SynExpr.YieldOrReturn ((isYield, _), yieldExpr, m) -> let methName = (if isYield then "Yield" else "Return") @@ -1343,116 +1346,113 @@ let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, inter and consumeCustomOpClauses q (varSpace: LazyWithContext<_, _>) dataCompPrior compClausesExpr lastUsesBind mClause = - // Substitute 'yield ' into the context + // Substitute 'yield ' into the context - let patvs, _env = varSpace.Force comp.Range - let varSpaceSimplePat = mkSimplePatForVarSpace mClause patvs - let varSpacePat = mkPatForVarSpace mClause patvs + let patvs, _env = varSpace.Force comp.Range + let varSpaceSimplePat = mkSimplePatForVarSpace mClause patvs + let varSpacePat = mkPatForVarSpace mClause patvs - match compClausesExpr with - - // Detect one custom operation... This clause will always match at least once... - | OptionalSequential - (CustomOperationClause - (nm, opDatas, - opExpr, mClause, optionalIntoPat), - optionalCont) -> - - let opName, _, _, _, _, _, _, _, methInfo = opDatas.[0] - let isLikeZip = customOperationIsLikeZip nm - let isLikeJoin = customOperationIsLikeJoin nm - let isLikeGroupJoin = customOperationIsLikeZip nm - - // Record the resolution of the custom operation for posterity - let item = Item.CustomOperation (opName, (fun () -> customOpUsageText nm), Some methInfo) - - // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations - // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - - if isLikeZip || isLikeJoin || isLikeGroupJoin then - errorR(Error(FSComp.SR.tcBinaryOperatorRequiresBody(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - match optionalCont with - | None -> - // we are about to drop the 'opExpr' AST on the floor. we've already reported an error. attempt to get name resolutions before dropping it - RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv opExpr - dataCompPrior - | Some contExpr -> consumeCustomOpClauses q varSpace dataCompPrior contExpr lastUsesBind mClause - else + match compClausesExpr with + + // Detect one custom operation... This clause will always match at least once... + | OptionalSequential (CustomOperationClause (nm, opDatas, opExpr, mClause, optionalIntoPat), optionalCont) -> + + let opName, _, _, _, _, _, _, _, methInfo = opDatas.[0] + let isLikeZip = customOperationIsLikeZip nm + let isLikeJoin = customOperationIsLikeJoin nm + let isLikeGroupJoin = customOperationIsLikeZip nm + + // Record the resolution of the custom operation for posterity + let item = Item.CustomOperation (opName, (fun () -> customOpUsageText nm), Some methInfo) + + // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations + // of type variables in the quick info provided in the IDE. + CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + + if isLikeZip || isLikeJoin || isLikeGroupJoin then + errorR(Error(FSComp.SR.tcBinaryOperatorRequiresBody(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + match optionalCont with + | None -> + // we are about to drop the 'opExpr' AST on the floor. we've already reported an error. attempt to get name resolutions before dropping it + RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv opExpr + dataCompPrior + | Some contExpr -> consumeCustomOpClauses q varSpace dataCompPrior contExpr lastUsesBind mClause + else - let maintainsVarSpace = customOperationMaintainsVarSpace nm - let maintainsVarSpaceUsingBind = customOperationMaintainsVarSpaceUsingBind nm - - let expectedArgCount = tryExpectedArgCountForCustomOperator nm - - let dataCompAfterOp = - match opExpr with - | StripApps(SingleIdent nm, args) -> - let argCountsMatch = - match expectedArgCount with - | Some n -> n = args.Length - | None -> cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations - if argCountsMatch then - // Check for the [] attribute on each argument position - let args = args |> List.mapi (fun i arg -> - if isCustomOperationProjectionParameter (i+1) nm then - SynExpr.Lambda (false, false, varSpaceSimplePat, None, arg, None, arg.Range.MakeSynthetic()) - else arg) - mkSynCall methInfo.DisplayName mClause (dataCompPrior :: args) + let maintainsVarSpace = customOperationMaintainsVarSpace nm + let maintainsVarSpaceUsingBind = customOperationMaintainsVarSpaceUsingBind nm + + let expectedArgCount = tryExpectedArgCountForCustomOperator nm + + let dataCompAfterOp = + match opExpr with + | StripApps(SingleIdent nm, args) -> + let argCountsMatch = + match expectedArgCount with + | Some n -> n = args.Length + | None -> cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations + if argCountsMatch then + // Check for the [] attribute on each argument position + let args = args |> List.mapi (fun i arg -> + if isCustomOperationProjectionParameter (i+1) nm then + SynExpr.Lambda (false, false, varSpaceSimplePat, None, arg, None, arg.Range.MakeSynthetic()) + else arg) + mkSynCall methInfo.DisplayName mClause (dataCompPrior :: args) + else + let expectedArgCount = defaultArg expectedArgCount 0 + errorR(Error(FSComp.SR.tcCustomOperationHasIncorrectArgCount(nm.idText, expectedArgCount, args.Length), nm.idRange)) + mkSynCall methInfo.DisplayName mClause ([ dataCompPrior ] @ List.init expectedArgCount (fun i -> arbExpr("_arg" + string i, mClause))) + | _ -> failwith "unreachable" + + match optionalCont with + | None -> + match optionalIntoPat with + | Some intoPat -> errorR(Error(FSComp.SR.tcIntoNeedsRestOfQuery(), intoPat.Range)) + | None -> () + dataCompAfterOp + + | Some contExpr -> + + // select a.Name into name; ... + // distinct into d; ... + // + // Rebind the into pattern and process the rest of the clauses + match optionalIntoPat with + | Some intoPat -> + if not (customOperationAllowsInto nm) then + error(Error(FSComp.SR.tcOperatorDoesntAcceptInto(nm.idText), intoPat.Range)) + + // Rebind using either for ... or let!.... + let rebind = + if maintainsVarSpaceUsingBind then + SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtLet, false, false, intoPat, dataCompAfterOp, [], contExpr, intoPat.Range) else - let expectedArgCount = defaultArg expectedArgCount 0 - errorR(Error(FSComp.SR.tcCustomOperationHasIncorrectArgCount(nm.idText, expectedArgCount, args.Length), nm.idRange)) - mkSynCall methInfo.DisplayName mClause ([ dataCompPrior ] @ List.init expectedArgCount (fun i -> arbExpr("_arg" + string i, mClause))) - | _ -> failwith "unreachable" + SynExpr.ForEach (DebugPointAtFor.No, SeqExprOnly false, false, intoPat, dataCompAfterOp, contExpr, intoPat.Range) - match optionalCont with + trans CompExprTranslationPass.Initial q emptyVarSpace rebind id + + // select a.Name; ... + // distinct; ... + // + // Process the rest of the clauses | None -> - match optionalIntoPat with - | Some intoPat -> errorR(Error(FSComp.SR.tcIntoNeedsRestOfQuery(), intoPat.Range)) - | None -> () - dataCompAfterOp - - | Some contExpr -> - - // select a.Name into name; ... - // distinct into d; ... - // - // Rebind the into pattern and process the rest of the clauses - match optionalIntoPat with - | Some intoPat -> - if not (customOperationAllowsInto nm) then - error(Error(FSComp.SR.tcOperatorDoesntAcceptInto(nm.idText), intoPat.Range)) - - // Rebind using either for ... or let!.... - let rebind = - if maintainsVarSpaceUsingBind then - SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtLet, false, false, intoPat, dataCompAfterOp, [], contExpr, intoPat.Range) - else - SynExpr.ForEach (DebugPointAtFor.No, SeqExprOnly false, false, intoPat, dataCompAfterOp, contExpr, intoPat.Range) - - trans CompExprTranslationPass.Initial q emptyVarSpace rebind id - - // select a.Name; ... - // distinct; ... - // - // Process the rest of the clauses - | None -> - if maintainsVarSpace || maintainsVarSpaceUsingBind then - consumeCustomOpClauses q varSpace dataCompAfterOp contExpr maintainsVarSpaceUsingBind mClause - else - consumeCustomOpClauses q emptyVarSpace dataCompAfterOp contExpr false mClause - - // No more custom operator clauses in compClausesExpr, but there may be clauses like join, yield etc. - // Bind/iterate the dataCompPrior and use compClausesExpr as the body. - | _ -> - // Rebind using either for ... or let!.... - let rebind = - if lastUsesBind then - SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtLet, false, false, varSpacePat, dataCompPrior, [], compClausesExpr, compClausesExpr.Range) - else - SynExpr.ForEach (DebugPointAtFor.No, SeqExprOnly false, false, varSpacePat, dataCompPrior, compClausesExpr, compClausesExpr.Range) - - trans CompExprTranslationPass.Initial q varSpace rebind id + if maintainsVarSpace || maintainsVarSpaceUsingBind then + consumeCustomOpClauses q varSpace dataCompAfterOp contExpr maintainsVarSpaceUsingBind mClause + else + consumeCustomOpClauses q emptyVarSpace dataCompAfterOp contExpr false mClause + + // No more custom operator clauses in compClausesExpr, but there may be clauses like join, yield etc. + // Bind/iterate the dataCompPrior and use compClausesExpr as the body. + | _ -> + // Rebind using either for ... or let!.... + let rebind = + if lastUsesBind then + SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtLet, false, false, varSpacePat, dataCompPrior, [], compClausesExpr, compClausesExpr.Range) + else + SynExpr.ForEach (DebugPointAtFor.No, SeqExprOnly false, false, varSpacePat, dataCompPrior, compClausesExpr, compClausesExpr.Range) + + trans CompExprTranslationPass.Initial q varSpace rebind id + and transNoQueryOps comp = trans CompExprTranslationPass.Initial CustomOperationsMode.Denied emptyVarSpace comp id @@ -1736,8 +1736,8 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = | Some e -> e | None -> pseudoEnumExpr // This expression is not checked with the knowledge it is an IEnumerable, since we permit other enumerable types with GetEnumerator/MoveNext methods, as does C# - let pseudoEnumExpr, arb_ty, tpenv = TcExprOfUnknownType cenv env tpenv pseudoEnumExpr - let enumExpr, enumElemTy = ConvertArbitraryExprToEnumerable cenv arb_ty env pseudoEnumExpr + let pseudoEnumExpr, arbitraryTy, tpenv = TcExprOfUnknownType cenv env tpenv pseudoEnumExpr + let enumExpr, enumElemTy = ConvertArbitraryExprToEnumerable cenv arbitraryTy env pseudoEnumExpr let pat', _, (vspecs: Val list), envinner, tpenv = TcMatchPattern cenv enumElemTy env tpenv (pat, None) let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp @@ -1873,13 +1873,10 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = | SynExpr.Match (spMatch, expr, clauses, _) -> let inputExpr, matchty, tpenv = TcExprOfUnknownType cenv env tpenv expr let tclauses, tpenv = - List.mapFold - (fun tpenv (SynMatchClause(pat, cond, _, innerComp, _, sp)) -> - let pat', cond', vspecs, envinner, tpenv = TcMatchPattern cenv matchty env tpenv (pat, cond) - let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp - TClause(pat', cond', TTarget(vspecs, innerExpr, sp, None), pat'.Range), tpenv) - tpenv - clauses + (tpenv, clauses) ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, _, innerComp, _, sp)) -> + let pat', cond', vspecs, envinner, tpenv = TcMatchPattern cenv matchty env tpenv (pat, cond) + let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp + TClause(pat', cond', TTarget(vspecs, innerExpr, sp, None), pat'.Range), tpenv) let inputExprTy = tyOfExpr cenv.g inputExpr let inputExprMark = inputExpr.Range let matchv, matchExpr = CompilePatternForMatchClauses cenv env inputExprMark inputExprMark true ThrowIncompleteMatchException (Some inputExpr) inputExprTy genOuterTy tclauses @@ -1955,6 +1952,7 @@ let TcSequenceExpressionEntry (cenv: cenv) env (overallTy: OverallTy) tpenv (has errorR(Error(FSComp.SR.tcInvalidObjectSequenceOrRecordExpression(), m)) | _ -> () + if not hasBuilder && not cenv.g.compilingFslib then error(Error(FSComp.SR.tcInvalidSequenceExpressionSyntaxForm(), m)) From 92902b4a3c84bf2c3a42e75b441e82a3ac7c72a4 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 8 Sep 2021 13:04:50 +0100 Subject: [PATCH 2/8] cleanup --- .gitignore | 2 + .vscode/settings.json | 7 - src/fsharp/FSharp.Core/seq.fs | 69 +++++---- src/fsharp/FSharp.Core/seqcore.fs | 239 +++++++++++++++++------------- 4 files changed, 180 insertions(+), 137 deletions(-) delete mode 100644 .vscode/settings.json diff --git a/.gitignore b/.gitignore index 1c78917fc79..9dfe3200c1b 100644 --- a/.gitignore +++ b/.gitignore @@ -122,3 +122,5 @@ nCrunchTemp_* /tests/fsharp/core/members/set-only-property/vb.dll /tests/fsharp/core/members/set-only-property/fs.dll /tests/fsharp/core/members/set-only-property/cs.dll + +.fake \ No newline at end of file diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index 48e4d8b9fb2..00000000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "editor.trimAutoWhitespace": false, - "files.trimTrailingWhitespace": false, - "FSharp.suggestGitignore": false, - "FSharp.workspacePath": "FSharp.sln", - "dotnet-test-explorer.testProjectPath": "tests/*Tests/" -} \ No newline at end of file diff --git a/src/fsharp/FSharp.Core/seq.fs b/src/fsharp/FSharp.Core/seq.fs index 9964349bfcd..1734142d5cd 100644 --- a/src/fsharp/FSharp.Core/seq.fs +++ b/src/fsharp/FSharp.Core/seq.fs @@ -980,46 +980,57 @@ namespace Microsoft.FSharp.Collections // * the prefix followed by elts from the enumerator are the initial sequence. // * the prefix contains only as many elements as the longest enumeration so far. let prefix = ResizeArray<_>() - let enumeratorR = ref None - // None = Unstarted. - // Some(Some e) = Started. - // Some None = Finished. + + // None = Unstarted. + // Some(Some e) = Started. + // Some None = Finished. + let mutable enumeratorR = None + let oneStepTo i = // If possible, step the enumeration to prefix length i (at most one step). // Be speculative, since this could have already happened via another thread. - if not (i < prefix.Count) then // is a step still required? + if i >= prefix.Count then // is a step still required? // If not yet started, start it (create enumerator). - match !enumeratorR with - | None -> enumeratorR := Some (Some (source.GetEnumerator())) - | Some _ -> () - match (!enumeratorR).Value with - | Some enumerator -> if enumerator.MoveNext() then - prefix.Add(enumerator.Current) - else - enumerator.Dispose() // Move failed, dispose enumerator, - enumeratorR := Some None // drop it and record finished. + let optEnumerator = + match enumeratorR with + | None -> + let optEnumerator = Some (source.GetEnumerator()) + enumeratorR <- Some optEnumerator + optEnumerator + | Some optEnumerator -> + optEnumerator + + match optEnumerator with + | Some enumerator -> + if enumerator.MoveNext() then + prefix.Add(enumerator.Current) + else + enumerator.Dispose() // Move failed, dispose enumerator, + enumeratorR <- Some None // drop it and record finished. | None -> () + let result = unfold (fun i -> - // i being the next position to be returned - // A lock is needed over the reads to prefix.Count since the list may be being resized - // NOTE: we could change to a reader/writer lock here - lock enumeratorR (fun () -> - if i < prefix.Count then - Some (prefix.[i],i+1) - else - oneStepTo i - if i < prefix.Count then - Some (prefix.[i],i+1) - else - None)) 0 + // i being the next position to be returned + // A lock is needed over the reads to prefix.Count since the list may be being resized + // NOTE: we could change to a reader/writer lock here + lock prefix (fun () -> + if i < prefix.Count then + Some (prefix.[i],i+1) + else + oneStepTo i + if i < prefix.Count then + Some (prefix.[i],i+1) + else + None)) 0 let cleanup() = - lock enumeratorR (fun () -> + lock prefix (fun () -> prefix.Clear() - match !enumeratorR with + match enumeratorR with | Some (Some e) -> IEnumerator.dispose e | _ -> () - enumeratorR := None) + enumeratorR <- None) + (new CachedSeq<_>(cleanup, result) :> seq<_>) [] diff --git a/src/fsharp/FSharp.Core/seqcore.fs b/src/fsharp/FSharp.Core/seqcore.fs index d4fa9b99de3..963eb4117b1 100644 --- a/src/fsharp/FSharp.Core/seqcore.fs +++ b/src/fsharp/FSharp.Core/seqcore.fs @@ -15,122 +15,155 @@ namespace Microsoft.FSharp.Collections module internal IEnumerator = - let noReset() = raise (new System.NotSupportedException(SR.GetString(SR.resetNotSupported))) - let notStarted() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) - let check started = if not started then notStarted() - let dispose (r : System.IDisposable) = r.Dispose() - - let cast (e : IEnumerator) : IEnumerator<'T> = - { new IEnumerator<'T> with - member _.Current = unbox<'T> e.Current - interface IEnumerator with - member _.Current = unbox<'T> e.Current :> obj - member _.MoveNext() = e.MoveNext() + let noReset() = raise (new System.NotSupportedException(SR.GetString(SR.resetNotSupported))) + let notStarted() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) + let alreadyFinished() = raise (new System.InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + let check started = if not started then notStarted() + let dispose (r : System.IDisposable) = r.Dispose() + + let cast (e : IEnumerator) : IEnumerator<'T> = + { new IEnumerator<'T> with + member _.Current = unbox<'T> e.Current + + interface IEnumerator with + member _.Current = unbox<'T> e.Current :> obj + member _.MoveNext() = e.MoveNext() + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = + match e with + | :? System.IDisposable as e -> e.Dispose() + | _ -> () } + + /// A concrete implementation of an enumerator that returns no values + [] + type EmptyEnumerator<'T>() = + let mutable started = false + interface IEnumerator<'T> with + member _.Current = + check started + (alreadyFinished() : 'T) + + interface System.Collections.IEnumerator with + member _.Current = + check started + (alreadyFinished() : obj) + + member _.MoveNext() = + if not started then started <- true + false + member _.Reset() = noReset() + interface System.IDisposable with - member _.Dispose() = - match e with - | :? System.IDisposable as e -> e.Dispose() - | _ -> () } - - /// A concrete implementation of an enumerator that returns no values - [] - type EmptyEnumerator<'T>() = - let mutable started = false - interface IEnumerator<'T> with - member _.Current = - check started - (alreadyFinished() : 'T) - - interface System.Collections.IEnumerator with - member _.Current = - check started - (alreadyFinished() : obj) - member _.MoveNext() = - if not started then started <- true - false - member _.Reset() = noReset() - interface System.IDisposable with - member _.Dispose() = () + member _.Dispose() = () - let Empty<'T> () = (new EmptyEnumerator<'T>() :> IEnumerator<'T>) + let Empty<'T> () = (new EmptyEnumerator<'T>() :> IEnumerator<'T>) + + [] + type EmptyEnumerable<'T> = - [] - type EmptyEnumerable<'T> = | EmptyEnumerable + interface IEnumerable<'T> with member _.GetEnumerator() = Empty<'T>() + interface IEnumerable with member _.GetEnumerator() = (Empty<'T>() :> IEnumerator) - let readAndClear r = - lock r (fun () -> match !r with None -> None | Some _ as res -> r := None; res) - - let generateWhileSome openf compute closef : IEnumerator<'U> = - let mutable started = false - let mutable curr = None - let state = ref (Some(openf())) - let getCurr() = - check started - match curr with None -> alreadyFinished() | Some x -> x - let start() = if not started then (started <- true) - - let dispose() = readAndClear state |> Option.iter closef - let finish() = try dispose() finally curr <- None - { new IEnumerator<'U> with - member _.Current = getCurr() - interface IEnumerator with - member _.Current = box (getCurr()) - member _.MoveNext() = - start() - match !state with - | None -> false (* we started, then reached the end, then got another MoveNext *) - | Some s -> - match (try compute s with e -> finish(); reraise()) with - | None -> finish(); false - | Some _ as x -> curr <- x; true - - member _.Reset() = noReset() - interface System.IDisposable with - member _.Dispose() = dispose() } - - [] - type Singleton<'T>(v:'T) = - let mutable started = false - interface IEnumerator<'T> with - member _.Current = v - interface IEnumerator with - member _.Current = box v - member _.MoveNext() = if started then false else (started <- true; true) - member _.Reset() = noReset() - interface System.IDisposable with - member _.Dispose() = () - - let Singleton x = (new Singleton<'T>(x) :> IEnumerator<'T>) - - let EnumerateThenFinally f (e : IEnumerator<'T>) = - { new IEnumerator<'T> with - member _.Current = e.Current + type GeneratedEnumerable<'T, 'State>(openf: unit -> 'State, compute: 'State -> 'T option, closef: 'State -> unit) = + let mutable started = false + let mutable curr = None + let state = ref (Some (openf ())) + let getCurr() : 'T = + check started + match curr with + | None -> alreadyFinished() + | Some x -> x + + let readAndClear () = + lock state (fun () -> + match state.Value with + | None -> None + | Some _ as res -> + state.Value <- None + res) + + let start() = + if not started then + started <- true + + let dispose() = + readAndClear() |> Option.iter closef + + let finish() = + try dispose() + finally curr <- None + + interface IEnumerator<'T> with + member _.Current = getCurr() + interface IEnumerator with - member _.Current = (e :> IEnumerator).Current - member _.MoveNext() = e.MoveNext() + member _.Current = box (getCurr()) + member _.MoveNext() = + start() + match state.Value with + | None -> false // we started, then reached the end, then got another MoveNext + | Some s -> + match (try compute s with e -> finish(); reraise()) with + | None -> finish(); false + | Some _ as x -> + curr <- x + true + member _.Reset() = noReset() + interface System.IDisposable with - member _.Dispose() = - try - e.Dispose() - finally - f() - } + member _.Dispose() = dispose() + + [] + type Singleton<'T>(v:'T) = + let mutable started = false + + interface IEnumerator<'T> with + member _.Current = v + + interface IEnumerator with + member _.Current = box v + member _.MoveNext() = if started then false else (started <- true; true) + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = () + + let Singleton x = (new Singleton<'T>(x) :> IEnumerator<'T>) + + let EnumerateThenFinally f (e : IEnumerator<'T>) = + { new IEnumerator<'T> with + member _.Current = e.Current + + interface IEnumerator with + member _.Current = (e :> IEnumerator).Current + member _.MoveNext() = e.MoveNext() + member _.Reset() = noReset() + + interface System.IDisposable with + member _.Dispose() = + try + e.Dispose() + finally + f() + } - let inline checkNonNull argName arg = - if isNull arg then - nullArg argName + let inline checkNonNull argName arg = + if isNull arg then + nullArg argName - let mkSeq f = + let mkSeq f = { new IEnumerable<'U> with member _.GetEnumerator() = f() + interface IEnumerable with member _.GetEnumerator() = (f() :> IEnumerator) } @@ -161,7 +194,7 @@ namespace Microsoft.FSharp.Core.CompilerServices member _.Equals(v1,v2) = gcomparer.Equals(v1.Value,v2.Value) } let Generate openf compute closef = - mkSeq (fun () -> IEnumerator.generateWhileSome openf compute closef) + mkSeq (fun () -> new IEnumerator.GeneratedEnumerable<_,_>(openf, compute, closef) :> IEnumerator<'T>) let GenerateUsing (openf : unit -> ('U :> System.IDisposable)) compute = Generate openf compute (fun (s:'U) -> s.Dispose()) @@ -392,12 +425,16 @@ namespace Microsoft.FSharp.Core.CompilerServices interface IEnumerable<'T> with member x.GetEnumerator() = x.GetFreshEnumerator() + interface IEnumerable with member x.GetEnumerator() = (x.GetFreshEnumerator() :> IEnumerator) + interface IEnumerator<'T> with member x.Current = if redirect then redirectTo.LastGenerated else x.LastGenerated - interface System.IDisposable with + + interface IDisposable with member x.Dispose() = if redirect then redirectTo.Close() else x.Close() + interface IEnumerator with member x.Current = box (if redirect then redirectTo.LastGenerated else x.LastGenerated) From 4ce9f3d7101fb5990bc1f595b0cea724162630bf Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 8 Sep 2021 15:55:19 +0100 Subject: [PATCH 3/8] cleanup uses of ref cells --- src/fsharp/CheckDeclarations.fs | 28 +- src/fsharp/CheckExpressions.fs | 26 +- src/fsharp/CompilerOptions.fs | 4 +- .../FSharp.Compiler.Service.fsproj | 1 + src/fsharp/FSharp.Core/seqcore.fsi | 97 +++--- src/fsharp/IlxGen.fs | 43 ++- src/fsharp/NicePrint.fs | 2 +- src/fsharp/absil/ilread.fs | 305 +++++++++--------- src/fsharp/absil/ilsupp.fs | 12 +- src/fsharp/absil/ilwrite.fs | 91 +++--- src/fsharp/absil/ilwritepdb.fs | 50 +-- src/fsharp/lib.fs | 6 +- src/fsharp/pars.fsy | 12 +- src/fsharp/service/service.fs | 18 +- tests/service/AssemblyContentProviderTests.fs | 8 +- 15 files changed, 357 insertions(+), 346 deletions(-) diff --git a/src/fsharp/CheckDeclarations.fs b/src/fsharp/CheckDeclarations.fs index 4b45fc856ee..28ca2c85c0c 100644 --- a/src/fsharp/CheckDeclarations.fs +++ b/src/fsharp/CheckDeclarations.fs @@ -2156,14 +2156,14 @@ module MutRecBindingChecking = /// Update the contents accessible via the recursive namespace declaration, if any let TcMutRecDefns_UpdateNSContents mutRecNSInfo = match mutRecNSInfo with - | Some (Some (mspecNS: ModuleOrNamespace), mtypeAcc) -> - mspecNS.entity_modul_contents <- MaybeLazy.Strict !mtypeAcc + | Some (Some (mspecNS: ModuleOrNamespace), mtypeAcc: _ ref) -> + mspecNS.entity_modul_contents <- MaybeLazy.Strict mtypeAcc.Value | _ -> () /// Updates the types of the modules to contain the contents so far let TcMutRecDefns_UpdateModuleContents mutRecNSInfo defns = defns |> MutRecShapes.iterModules (fun (MutRecDefnsPhase2DataForModule (mtypeAcc, mspec), _) -> - mspec.entity_modul_contents <- MaybeLazy.Strict !mtypeAcc) + mspec.entity_modul_contents <- MaybeLazy.Strict mtypeAcc.Value) TcMutRecDefns_UpdateNSContents mutRecNSInfo @@ -2206,7 +2206,7 @@ module MutRecBindingChecking = let envForDecls = (envForDecls, opens) ||> List.fold (fun env (target, m, moduleRange, openDeclsRef) -> let env, openDecls = TcOpenDecl cenv m moduleRange env target - openDeclsRef := openDecls + openDeclsRef.Value <- openDecls env) // Add the type definitions being defined let envForDecls = (if report then AddLocalTyconsAndReport cenv.tcSink scopem else AddLocalTycons) cenv.g cenv.amap m tycons envForDecls @@ -5120,7 +5120,7 @@ let rec TcSignatureElementNonMutRec cenv parent typeNames endm (env: TcEnv) synS let envNS = ImplicitlyOpenOwnNamespace cenv.tcSink cenv.g cenv.amap m enclosingNamespacePath envNS // For 'namespace rec' and 'module rec' we add the thing being defined - let mtypNS = !(envNS.eModuleOrNamespaceTypeAccumulator) + let mtypNS = envNS.eModuleOrNamespaceTypeAccumulator.Value let mtypRoot, mspecNSs = BuildRootModuleType enclosingNamespacePath envNS.eCompPath mtypNS let mspecNSOpt = List.tryHead mspecNSs @@ -5151,7 +5151,8 @@ let rec TcSignatureElementNonMutRec cenv parent typeNames endm (env: TcEnv) synS | None -> env, [] // Publish the combined module type - env.eModuleOrNamespaceTypeAccumulator := CombineCcuContentFragments m [!(env.eModuleOrNamespaceTypeAccumulator); mtypRoot] + env.eModuleOrNamespaceTypeAccumulator.Value <- + CombineCcuContentFragments m [env.eModuleOrNamespaceTypeAccumulator.Value; mtypRoot] env return env @@ -5245,7 +5246,7 @@ and TcModuleOrNamespaceSignatureElementsNonMutRec cenv parent env (id, modKind, let! envAtEnd = TcSignatureElements cenv parent endm envForModule xml None defs // mtypeAcc has now accumulated the module type - return !mtypeAcc, envAtEnd + return mtypeAcc.Value, envAtEnd } //------------------------------------------------------------------------- @@ -5389,7 +5390,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem let! mexpr, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModRef mspec)) endm envForModule xml None [] mdefs // Get the inferred type of the decls and record it in the mspec. - mspec.entity_modul_contents <- MaybeLazy.Strict !mtypeAcc + mspec.entity_modul_contents <- MaybeLazy.Strict mtypeAcc.Value let modDefn = TMDefRec(false, [], [], [ModuleOrNamespaceBinding.Module(mspec, mexpr)], m) PublishModuleDefn cenv env mspec let env = AddLocalSubModuleAndReport cenv.tcSink scopem cenv.g cenv.amap m env mspec @@ -5431,7 +5432,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem let envNS = LocateEnv cenv.topCcu env enclosingNamespacePath let envNS = ImplicitlyOpenOwnNamespace cenv.tcSink cenv.g cenv.amap m enclosingNamespacePath envNS - let mtypNS = !(envNS.eModuleOrNamespaceTypeAccumulator) + let mtypNS = envNS.eModuleOrNamespaceTypeAccumulator.Value let mtypRoot, mspecNSs = BuildRootModuleType enclosingNamespacePath envNS.eCompPath mtypNS let mspecNSOpt = List.tryHead mspecNSs @@ -5462,7 +5463,8 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem | None -> env, [] // Publish the combined module type - env.eModuleOrNamespaceTypeAccumulator := CombineCcuContentFragments m [!(env.eModuleOrNamespaceTypeAccumulator); mtypRoot] + env.eModuleOrNamespaceTypeAccumulator.Value <- + CombineCcuContentFragments m [env.eModuleOrNamespaceTypeAccumulator.Value; mtypRoot] env, openDecls let modExprRoot = BuildRootModuleExpr enclosingNamespacePath envNS.eCompPath modExpr @@ -5592,7 +5594,7 @@ and TcMutRecDefsFinish cenv defs m = binds |> List.map ModuleOrNamespaceBinding.Binding | MutRecShape.Module ((MutRecDefnsPhase2DataForModule(mtypeAcc, mspec), _), mdefs) -> let mexpr = TcMutRecDefsFinish cenv mdefs m - mspec.entity_modul_contents <- MaybeLazy.Strict !mtypeAcc + mspec.entity_modul_contents <- MaybeLazy.Strict mtypeAcc.Value [ ModuleOrNamespaceBinding.Module(mspec, mexpr) ]) TMDefRec(true, opens, tycons, binds, m) @@ -5841,7 +5843,7 @@ let TypeCheckOneImplFile let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment x ] let! mexpr, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs - let implFileTypePriorToSig = !mtypeAcc + let implFileTypePriorToSig = mtypeAcc.Value let topAttrs = let mainMethodAttrs, others = topAttrs |> List.partition (fun (possTargets, _) -> possTargets &&& AttributeTargets.Method <> enum 0) @@ -5948,7 +5950,7 @@ let TypeCheckOneSigFile (g, niceNameGen, amap, topCcu, checkForErrors, condition let specs = [ for x in sigFileFrags -> SynModuleSigDecl.NamespaceFragment x ] let! tcEnv = TcSignatureElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None specs - let sigFileType = !mtypeAcc + let sigFileType = mtypeAcc.Value if not (checkForErrors()) then try sigFileType |> IterTyconsOfModuleOrNamespaceType (FinalTypeDefinitionChecksAtEndOfInferenceScope(cenv.infoReader, tcEnv.NameEnv, cenv.tcSink, false, tcEnv.DisplayEnv)) diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 48e93649a01..d4b8e08d9d6 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -544,10 +544,12 @@ let MakeInnerEnvForMember env (v: Val) = | Some _ -> MakeInnerEnvForTyconRef env v.MemberApparentEntity v.IsExtensionMember /// Get the current accumulator for the namespace/module we're in -let GetCurrAccumulatedModuleOrNamespaceType env = !(env.eModuleOrNamespaceTypeAccumulator) +let GetCurrAccumulatedModuleOrNamespaceType env = + env.eModuleOrNamespaceTypeAccumulator.Value /// Set the current accumulator for the namespace/module we're in, updating the inferred contents -let SetCurrAccumulatedModuleOrNamespaceType env x = env.eModuleOrNamespaceTypeAccumulator := x +let SetCurrAccumulatedModuleOrNamespaceType env x = + env.eModuleOrNamespaceTypeAccumulator.Value <- x /// Set up the initial environment accounting for the enclosing "namespace X.Y.Z" definition let LocateEnv ccu env enclosingNamespacePath = @@ -2084,7 +2086,7 @@ module GeneralizationHelpers = | Expr.App (e1, _, _, [], _) -> IsGeneralizableValue g e1 | Expr.TyChoose (_, b, _) -> IsGeneralizableValue g b | Expr.Obj (_, ty, _, _, _, _, _) -> isInterfaceTy g ty || isDelegateTy g ty - | Expr.Link eref -> IsGeneralizableValue g !eref + | Expr.Link eref -> IsGeneralizableValue g eref.Value | _ -> false @@ -3440,7 +3442,7 @@ let EliminateInitializationGraphs // n-ary expressions | Expr.Op (op, _, args, m) -> CheckExprOp st op m; List.iter (CheckExpr (strict st)) args // misc - | Expr.Link eref -> CheckExpr st !eref + | Expr.Link eref -> CheckExpr st eref.Value | Expr.TyChoose (_, b, _) -> CheckExpr st b | Expr.Quote _ -> () | Expr.WitnessArg (_witnessInfo, _m) -> () @@ -3528,7 +3530,8 @@ let EliminateInitializationGraphs let vrhs = (mkLazyDelayed g m ty felazy) if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g AllowTypeDirectedDetupling.Yes vty [] [] vrhs)) - fixupPoints |> List.iter (fun (fp, _) -> fp := mkLazyForce g (!fp).Range ty velazy) + for (fixupPoint, _) in fixupPoints do + fixupPoint.Value <- mkLazyForce g fixupPoint.Value.Range ty velazy [mkInvisibleBind flazy frhs; mkInvisibleBind vlazy vrhs], [mkBind seqPtOpt v (mkLazyForce g m ty velazy)] @@ -3619,8 +3622,8 @@ let CheckAndRewriteObjectCtor g env (ctorLambdaExpr: Expr) = and checkAndRewriteCtorUsage expr = match expr with | Expr.Link eref -> - let e = checkAndRewriteCtorUsage !eref - eref := e + let e = checkAndRewriteCtorUsage eref.Value + eref.Value <- e expr // Type applications are ok, e.g. @@ -4713,8 +4716,13 @@ and TryAdjustHiddenVarNameToCompGenName cenv env (id: Ident) altNameRefCellOpt = match altNameRefCellOpt with | Some ({contents = SynSimplePatAlternativeIdInfo.Undecided altId } as altNameRefCell) -> match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false id.idRange env.eAccessRights env.eNameResEnv TypeNameResolutionInfo.Default [id] with - | Item.NewDef _ -> None // the name is not in scope as a pattern identifier (e.g. union case), so do not use the alternate ID - | _ -> altNameRefCell := SynSimplePatAlternativeIdInfo.Decided altId; Some altId // the name is in scope as a pattern identifier, so use the alternate ID + | Item.NewDef _ -> + // The name is not in scope as a pattern identifier (e.g. union case), so do not use the alternate ID + None + | _ -> + // The name is in scope as a pattern identifier, so use the alternate ID + altNameRefCell.Value <- SynSimplePatAlternativeIdInfo.Decided altId + Some altId | Some {contents = SynSimplePatAlternativeIdInfo.Decided altId } -> Some altId | None -> None diff --git a/src/fsharp/CompilerOptions.fs b/src/fsharp/CompilerOptions.fs index 1f862fbfbfd..0cf6ece074f 100644 --- a/src/fsharp/CompilerOptions.fs +++ b/src/fsharp/CompilerOptions.fs @@ -294,10 +294,10 @@ let ParseCompilerOptions (collectOtherArgument: string -> unit, blocks: Compiler f (getSwitch opt); t | CompilerOption(s, _, OptionSet f, d, _) :: _ when optToken = s && argString = "" -> reportDeprecatedOption d - f := true; t + f.Value <- true; t | CompilerOption(s, _, OptionClear f, d, _) :: _ when optToken = s && argString = "" -> reportDeprecatedOption d - f := false; t + f.Value <- false; t | CompilerOption(s, _, OptionString f, d, _) as compilerOption :: _ when optToken = s -> reportDeprecatedOption d let oa = getOptionArg compilerOption argString diff --git a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index c1e88ab47cf..bf353c83e36 100644 --- a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -11,6 +11,7 @@ $(DefineConstants);COMPILER $(DefineConstants);ENABLE_MONO_SUPPORT $(OtherFlags) /warnon:3218 /warnon:1182 /warnon:3390 --maxerrors:20 --extraoptimizationloops:1 --times + $(OtherFlags) /langversion:preview true $(IntermediateOutputPath)$(TargetFramework)\ $(IntermediateOutputPath)$(TargetFramework)\ diff --git a/src/fsharp/FSharp.Core/seqcore.fsi b/src/fsharp/FSharp.Core/seqcore.fsi index cce9b5dbb3e..6e2f4d30834 100644 --- a/src/fsharp/FSharp.Core/seqcore.fsi +++ b/src/fsharp/FSharp.Core/seqcore.fsi @@ -7,53 +7,42 @@ namespace Microsoft.FSharp.Collections open Microsoft.FSharp.Core open Microsoft.FSharp.Collections module internal IEnumerator = - val noReset : unit -> 'a - val notStarted : unit -> 'a - val alreadyFinished : unit -> 'a - val check : started:bool -> unit - val dispose : r:System.IDisposable -> unit - val cast : - e:System.Collections.IEnumerator -> - System.Collections.Generic.IEnumerator<'T> - [] + val noReset: unit -> 'a + val notStarted: unit -> 'a + val alreadyFinished: unit -> 'a + val check: started: bool -> unit + val dispose: r: IDisposable -> unit + val cast : e: IEnumerator -> IEnumerator<'T> + + [] type EmptyEnumerator<'T> = - class interface System.IDisposable - interface System.Collections.IEnumerator - interface System.Collections.Generic.IEnumerator<'T> - new : unit -> EmptyEnumerator<'T> - end - val Empty : unit -> System.Collections.Generic.IEnumerator<'T> + interface IEnumerator + interface IEnumerator<'T> + new: unit -> EmptyEnumerator<'T> + + val Empty: unit -> IEnumerator<'T> + [] type EmptyEnumerable<'T> = | EmptyEnumerable - with - interface System.Collections.IEnumerable - interface System.Collections.Generic.IEnumerable<'T> - end - - val readAndClear : r:'a option ref -> 'a option - val generateWhileSome : - openf:(unit -> 'a) -> - compute:('a -> 'U option) -> - closef:('a -> unit) -> System.Collections.Generic.IEnumerator<'U> + interface IEnumerable + interface IEnumerable<'T> + [] type Singleton<'T> = - class interface System.IDisposable - interface System.Collections.IEnumerator - interface System.Collections.Generic.IEnumerator<'T> - new : v:'T -> Singleton<'T> - end - val Singleton : x:'T -> System.Collections.Generic.IEnumerator<'T> - val EnumerateThenFinally : - f:(unit -> unit) -> - e:System.Collections.Generic.IEnumerator<'T> -> - System.Collections.Generic.IEnumerator<'T> - val inline checkNonNull : argName:string -> arg:'a -> unit when 'a : null - val mkSeq : - f:(unit -> System.Collections.Generic.IEnumerator<'U>) -> - System.Collections.Generic.IEnumerable<'U> + interface IEnumerator + interface IEnumerator<'T> + new: v: 'T -> Singleton<'T> + + val Singleton: x: 'T -> IEnumerator<'T> + + val inline checkNonNull: argName: string -> arg: 'a -> unit when 'a: null + + val mkSeq : + f: (unit -> IEnumerator<'U>) -> + IEnumerable<'U> namespace Microsoft.FSharp.Core.CompilerServices @@ -69,12 +58,12 @@ namespace Microsoft.FSharp.Core.CompilerServices module RuntimeHelpers = [] - type internal StructBox<'T when 'T : equality> = - new : value:'T -> StructBox<'T> - member Value : 'T - static member Comparer : IEqualityComparer> + type internal StructBox<'T when 'T: equality> = + new: value: 'T -> StructBox<'T> + member Value: 'T + static member Comparer: IEqualityComparer> - val internal mkConcatSeq : sources:(seq<#seq<'T>>) -> seq<'T> + val internal mkConcatSeq: sources: (seq<#seq<'T>>) -> seq<'T> /// The F# compiler emits calls to this function to /// implement the while operator for F# sequence expressions. @@ -83,7 +72,7 @@ namespace Microsoft.FSharp.Core.CompilerServices /// The input sequence. /// /// The result sequence. - val EnumerateWhile : guard:(unit -> bool) -> source:seq<'T> -> seq<'T> + val EnumerateWhile : guard: (unit -> bool) -> source: seq<'T> -> seq<'T> /// The F# compiler emits calls to this function to /// implement the try/finally operator for F# sequence expressions. @@ -92,17 +81,17 @@ namespace Microsoft.FSharp.Core.CompilerServices /// A computation to be included in an enumerator's Dispose method. /// /// The result sequence. - val EnumerateThenFinally : source:seq<'T> -> compensation:(unit -> unit) -> seq<'T> + val EnumerateThenFinally: source: seq<'T> -> compensation: (unit -> unit) -> seq<'T> /// The F# compiler emits calls to this function to implement the compiler-intrinsic - /// conversions from untyped System.Collections.IEnumerable sequences to typed sequences. + /// conversions from untyped IEnumerable sequences to typed sequences. /// /// An initializer function. /// A function to iterate and test if end of sequence is reached. /// A function to retrieve the current element. /// /// The resulting typed sequence. - val EnumerateFromFunctions: create:(unit -> 'T) -> moveNext:('T -> bool) -> current:('T -> 'U) -> seq<'U> + val EnumerateFromFunctions: create: (unit -> 'T) -> moveNext: ('T -> bool) -> current: ('T -> 'U) -> seq<'U> /// The F# compiler emits calls to this function to implement the use operator for F# sequence /// expressions. @@ -111,7 +100,7 @@ namespace Microsoft.FSharp.Core.CompilerServices /// The input sequence. /// /// The result sequence. - val EnumerateUsing : resource:'T -> source:('T -> 'Collection) -> seq<'U> when 'T :> IDisposable and 'Collection :> seq<'U> + val EnumerateUsing: resource: 'T -> source: ('T -> 'Collection) -> seq<'U> when 'T :> IDisposable and 'Collection :> seq<'U> /// Creates an anonymous event with the given handlers. /// @@ -120,7 +109,7 @@ namespace Microsoft.FSharp.Core.CompilerServices /// A function to produce the delegate type the event can trigger. /// /// The initialized event. - val CreateEvent : addHandler : ('Delegate -> unit) -> removeHandler : ('Delegate -> unit) -> createHandler : ((obj -> 'Args -> unit) -> 'Delegate) -> Microsoft.FSharp.Control.IEvent<'Delegate,'Args> + val CreateEvent: addHandler: ('Delegate -> unit) -> removeHandler: ('Delegate -> unit) -> createHandler: ((obj -> 'Args -> unit) -> 'Delegate) -> Microsoft.FSharp.Control.IEvent<'Delegate,'Args> [] /// The F# compiler emits implementations of this type for compiled sequence expressions. @@ -128,19 +117,19 @@ namespace Microsoft.FSharp.Core.CompilerServices /// The F# compiler emits implementations of this type for compiled sequence expressions. /// /// A new sequence generator for the expression. - new : unit -> GeneratedSequenceBase<'T> + new: unit -> GeneratedSequenceBase<'T> /// The F# compiler emits implementations of this type for compiled sequence expressions. /// /// A new enumerator for the sequence. - abstract GetFreshEnumerator : unit -> IEnumerator<'T> + abstract GetFreshEnumerator: unit -> IEnumerator<'T> /// The F# compiler emits implementations of this type for compiled sequence expressions. /// /// A reference to the sequence. /// /// A 0, 1, and 2 respectively indicate Stop, Yield, and Goto conditions for the sequence generator. - abstract GenerateNext : result:byref> -> int + abstract GenerateNext: result: byref> -> int /// The F# compiler emits implementations of this type for compiled sequence expressions. abstract Close: unit -> unit @@ -149,7 +138,7 @@ namespace Microsoft.FSharp.Core.CompilerServices abstract CheckClose: bool /// The F# compiler emits implementations of this type for compiled sequence expressions. - abstract LastGenerated : 'T + abstract LastGenerated: 'T interface IEnumerable<'T> interface IEnumerable interface IEnumerator<'T> diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 5943c5fe2ac..77d332ed110 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -146,9 +146,9 @@ let ReportStatistics (oc: TextWriter) = reports oc let NewCounter nm = - let count = ref 0 - AddReport (fun oc -> if !count <> 0 then oc.WriteLine (string !count + " " + nm)) - (fun () -> incr count) + let mutable count = 0 + AddReport (fun oc -> if count <> 0 then oc.WriteLine (string count + " " + nm)) + (fun () -> count <- count + 1) let CountClosure = NewCounter "closures" @@ -5750,7 +5750,8 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx let genTargetInfoOpt = if generateTargetNow then - incr targetNext // generate the targets in-order only + // Fenerate the targets in-order only + targetNext.Value <- targetNext.Value + 1 Some(GenDecisionTreeTarget cenv cgbuf stackAtTargets targetInfo sequel) else None @@ -5792,7 +5793,8 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx let genTargetInfoOpt = if generateTargetNow then // Here we are generating the target immediately - incr targetNext // generate the targets in-order only + // Generate the targets in-order only + targetNext.Value <- targetNext.Value + 1 cgbuf.SetMarkToHereIfNecessary inplabOpt Some(GenDecisionTreeTarget cenv cgbuf stackAtTargets targetInfo sequel) else @@ -6072,23 +6074,27 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = | Null -> false | _ -> true) - let computeFixupsForOneRecursiveVar boundv forwardReferenceSet fixups thisVars access set e = + let computeFixupsForOneRecursiveVar boundv forwardReferenceSet (fixups: _ ref) thisVars access set e = match e with | Expr.Lambda _ | Expr.TyLambda _ | Expr.Obj _ -> let isLocalTypeFunc = Option.isSome thisVars && (IsNamedLocalTypeFuncVal cenv.g (Option.get thisVars) e) let thisVars = (match e with Expr.Obj _ -> [] | _ when isLocalTypeFunc -> [] | _ -> Option.map mkLocalValRef thisVars |> Option.toList) let canUseStaticField = (match e with Expr.Obj _ -> false | _ -> true) let clo, _, eenvclo = GetIlxClosureInfo cenv m ILBoxity.AsObject isLocalTypeFunc canUseStaticField thisVars {eenv with letBoundVars=(mkLocalValRef boundv) :: eenv.letBoundVars} e - clo.cloFreeVars |> List.iter (fun fv -> + for fv in clo.cloFreeVars do if Zset.contains fv forwardReferenceSet then match StorageForVal cenv.g m fv eenvclo with - | Env (_, ilField, _) -> fixups := (boundv, fv, (fun () -> GenLetRecFixup cenv cgbuf eenv (clo.cloSpec, access, ilField, exprForVal m fv, m))) :: !fixups - | _ -> error (InternalError("GenLetRec: " + fv.LogicalName + " was not in the environment", m)) ) + | Env (_, ilField, _) -> + let fixup = (boundv, fv, (fun () -> GenLetRecFixup cenv cgbuf eenv (clo.cloSpec, access, ilField, exprForVal m fv, m))) + fixups.Value <- fixup :: fixups.Value + | _ -> error (InternalError("GenLetRec: " + fv.LogicalName + " was not in the environment", m)) | Expr.Val (vref, _, _) -> let fv = vref.Deref let needsFixup = Zset.contains fv forwardReferenceSet - if needsFixup then fixups := (boundv, fv, (fun () -> GenExpr cenv cgbuf eenv SPSuppress (set e) discard)) :: !fixups + if needsFixup then + let fixup = (boundv, fv, (fun () -> GenExpr cenv cgbuf eenv SPSuppress (set e) discard)) + fixups.Value <- fixup :: fixups.Value | _ -> failwith "compute real fixup vars" @@ -6114,7 +6120,14 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = let forwardReferenceSet = Zset.remove bind.Var forwardReferenceSet // Execute and discard any fixups that can now be committed - fixups := !fixups |> List.filter (fun (boundv, fv, action) -> if (Zset.contains boundv forwardReferenceSet || Zset.contains fv forwardReferenceSet) then true else (action(); false)) + let newFixups = + fixups.Value |> List.filter (fun (boundv, fv, action) -> + if (Zset.contains boundv forwardReferenceSet || Zset.contains fv forwardReferenceSet) then + true + else + action() + false) + fixups.Value <- newFixups forwardReferenceSet) () @@ -7253,9 +7266,11 @@ and AllocStorageForBinds cenv cgbuf scopeMarks eenv binds = match repr with | Local(_, _, Some (_, g)) | Env(_, _, Some (_, g)) -> - match !g with - | NamedLocalIlxClosureInfoGenerator f -> g := NamedLocalIlxClosureInfoGenerated (f eenv) - | NamedLocalIlxClosureInfoGenerated _ -> () + match g.Value with + | NamedLocalIlxClosureInfoGenerator f -> + g.Value <- NamedLocalIlxClosureInfoGenerated (f eenv) + | NamedLocalIlxClosureInfoGenerated _ -> + () | _ -> () | _ -> ()) diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index d14855a92b1..3689cfcad5d 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -2313,7 +2313,7 @@ module PrintData = wordL (tagLocal v.DisplayName) | Expr.Link rX -> - dataExprWrapL denv isAtomic (!rX) + dataExprWrapL denv isAtomic rX.Value | Expr.Op (TOp.UnionCase c, _, args, _) -> if denv.g.unionCaseRefEq c denv.g.nil_ucref then wordL (tagPunctuation "[]") diff --git a/src/fsharp/absil/ilread.fs b/src/fsharp/absil/ilread.fs index 33882f26276..6e497b1ccc6 100644 --- a/src/fsharp/absil/ilread.fs +++ b/src/fsharp/absil/ilread.fs @@ -574,8 +574,8 @@ let instrs () = // The tables are delayed to avoid building them unnecessarily at startup // Many applications of AbsIL (e.g. a compiler) don't need to read instructions. -let oneByteInstrs = ref None -let twoByteInstrs = ref None +let mutable oneByteInstrs = None +let mutable twoByteInstrs = None let fillInstrs () = let oneByteInstrTable = Array.create 256 I_invalid_instr let twoByteInstrTable = Array.create 256 I_invalid_instr @@ -594,16 +594,16 @@ let fillInstrs () = oneByteInstrTable.[i] <- f List.iter addInstr (instrs()) List.iter (fun (x, mk) -> addInstr (x, I_none_instr (noPrefixes mk))) (noArgInstrs.Force()) - oneByteInstrs := Some oneByteInstrTable - twoByteInstrs := Some twoByteInstrTable + oneByteInstrs <- Some oneByteInstrTable + twoByteInstrs <- Some twoByteInstrTable let rec getOneByteInstr i = - match !oneByteInstrs with + match oneByteInstrs with | None -> fillInstrs(); getOneByteInstr i | Some t -> t.[i] let rec getTwoByteInstr i = - match !twoByteInstrs with + match twoByteInstrs with | None -> fillInstrs(); getTwoByteInstr i | Some t -> t.[i] @@ -732,20 +732,20 @@ type GenericParamsIdx = GenericParamsIdx of numtypars: int * TypeOrMethodDefTag let mkCacheInt32 lowMem _inbase _nm _sz = if lowMem then (fun f x -> f x) else - let cache = ref null - let count = ref 0 + let mutable cache = null + let mutable count = 0 #if STATISTICS - addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " "+ _nm + " cache hits"): string)) + addReport (fun oc -> if count <> 0 then oc.WriteLine ((_inbase + string count + " "+ _nm + " cache hits"): string)) #endif fun f (idx: int32) -> let cache = - match !cache with - | null -> cache := ConcurrentDictionary(Environment.ProcessorCount, 11) + match cache with + | null -> cache <- ConcurrentDictionary(Environment.ProcessorCount, 11) | _ -> () - !cache + cache match cache.TryGetValue idx with | true, res -> - incr count + count <- count + 1 res | _ -> let res = f idx @@ -754,20 +754,22 @@ let mkCacheInt32 lowMem _inbase _nm _sz = let mkCacheGeneric lowMem _inbase _nm _sz = if lowMem then (fun f x -> f x) else - let cache = ref null - let count = ref 0 + let mutable cache = null + let mutable count = 0 #if STATISTICS addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " " + _nm + " cache hits"): string)) #endif fun f (idx :'T) -> let cache = - match !cache with - | null -> cache := ConcurrentDictionary<_, _>(Environment.ProcessorCount, 11 (* sz: int *) ) + match cache with + | null -> + cache <- ConcurrentDictionary<_, _>(Environment.ProcessorCount, 11 (* sz: int *) ) | _ -> () - !cache + cache + match cache.TryGetValue idx with | true, v -> - incr count + count <- count + 1 v | _ -> let res = f idx @@ -852,12 +854,10 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r res else - let res = ref [] - for i = 1 to numRows do + [ for i = 1 to numRows do let rowinfo = rowReader i if keyComparer (keyFunc rowinfo) = 0 then - res := rowConverter rowinfo :: !res - List.rev !res + yield rowConverter rowinfo ] let seekReadOptionalIndexedRow info = @@ -1469,26 +1469,23 @@ let getDataEndPointsDelayed (pectxt: PEReader) ctxtH = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() let dataStartPoints = - let res = ref [] - for i = 1 to ctxt.getNumRows TableNames.FieldRVA do + [ for i = 1 to ctxt.getNumRows TableNames.FieldRVA do let rva, _fidx = seekReadFieldRVARow ctxt mdv i - res := ("field", rva) :: !res - for i = 1 to ctxt.getNumRows TableNames.ManifestResource do + ("field", rva) + for i = 1 to ctxt.getNumRows TableNames.ManifestResource do let offset, _, _, TaggedIndex(_tag, idx) = seekReadManifestResourceRow ctxt mdv i if idx = 0 then let rva = pectxt.resourcesAddr + offset - res := ("manifest resource", rva) :: !res - !res + ("manifest resource", rva) ] + if isNil dataStartPoints then [] else let methodRVAs = - let res = ref [] - for i = 1 to ctxt.getNumRows TableNames.Method do + [ for i = 1 to ctxt.getNumRows TableNames.Method do let rva, _, _, nameIdx, _, _ = seekReadMethodRow ctxt mdv i if rva <> 0 then let nm = readStringHeap ctxt nameIdx - res := (nm, rva) :: !res - !res + (nm, rva) ] ([ pectxt.textSegmentPhysicalLoc + pectxt.textSegmentPhysicalSize pectxt.dataSegmentPhysicalLoc + pectxt.dataSegmentPhysicalSize ] @ @@ -1746,7 +1743,7 @@ and seekReadInterfaceImpls (ctxt: ILMetadataReader) mdv numtypars tidx = fst, simpleIndexCompare tidx, isSorted ctxt TableNames.InterfaceImpl, - (snd >> seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) List.empty)) + (snd >> seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) [])) and seekReadGenericParams ctxt numtypars (a, b): ILGenericParameterDefs = ctxt.seekReadGenericParams (GenericParamsIdx(numtypars, a, b)) @@ -2318,20 +2315,20 @@ and seekReadMethod (ctxt: ILMetadataReader) mdv numtypars (idx: int) = and seekReadParams (ctxt: ILMetadataReader) mdv (retty, argtys) pidx1 pidx2 = - let retRes = ref (mkILReturn retty) + let mutable retRes = mkILReturn retty let paramsRes = argtys |> List.toArray |> Array.map mkILParamAnon for i = pidx1 to pidx2 - 1 do - seekReadParamExtras ctxt mdv (retRes, paramsRes) i - !retRes, List.ofArray paramsRes + seekReadParamExtras ctxt mdv (&retRes, paramsRes) i + retRes, List.ofArray paramsRes -and seekReadParamExtras (ctxt: ILMetadataReader) mdv (retRes, paramsRes) (idx: int) = +and seekReadParamExtras (ctxt: ILMetadataReader) mdv (retRes: byref, paramsRes) (idx: int) = let flags, seq, nameIdx = seekReadParamRow ctxt mdv idx let inOutMasked = (flags &&& 0x00FF) let hasMarshal = (flags &&& 0x2000) <> 0x0 let hasDefault = (flags &&& 0x1000) <> 0x0 let fmReader idx = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal, seekReadFieldMarshalRow ctxt mdv, fst, hfmCompare idx, isSorted ctxt TableNames.FieldMarshal, (snd >> readBlobHeapAsNativeType ctxt)) if seq = 0 then - retRes := { !retRes with + retRes <- { retRes with Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef, idx))) else None) CustomAttrsStored = ctxt.customAttrsReader_ParamDef MetadataIndex = idx} @@ -2376,14 +2373,14 @@ and seekReadMultipleMethodSemantics (ctxt: ILMetadataReader) (flags, id) = |> List.map snd -and seekReadoptional_MethodSemantics ctxt id = +and seekReadOptionalMethodSemantics ctxt id = match seekReadMultipleMethodSemantics ctxt id with | [] -> None | [h] -> Some h | h :: _ -> dprintn "multiple method semantics found"; Some h and seekReadMethodSemantics ctxt id = - match seekReadoptional_MethodSemantics ctxt id with + match seekReadOptionalMethodSemantics ctxt id with | None -> failwith "seekReadMethodSemantics ctxt: no method found" | Some x -> x @@ -2394,7 +2391,7 @@ and seekReadEvent ctxt mdv numtypars idx = attributes = enum(flags), addMethod= seekReadMethodSemantics ctxt (0x0008, TaggedIndex(hs_Event, idx)), removeMethod=seekReadMethodSemantics ctxt (0x0010, TaggedIndex(hs_Event, idx)), - fireMethod=seekReadoptional_MethodSemantics ctxt (0x0020, TaggedIndex(hs_Event, idx)), + fireMethod=seekReadOptionalMethodSemantics ctxt (0x0020, TaggedIndex(hs_Event, idx)), otherMethods = seekReadMultipleMethodSemantics ctxt (0x0004, TaggedIndex(hs_Event, idx)), customAttrsStored=ctxt.customAttrsReader_Event, metadataIndex = idx ) @@ -2421,8 +2418,8 @@ and seekReadEvents (ctxt: ILMetadataReader) numtypars tidx = and seekReadProperty ctxt mdv numtypars idx = let flags, nameIdx, typIdx = seekReadPropertyRow ctxt mdv idx let cc, retty, argtys = readBlobHeapAsPropertySig ctxt numtypars typIdx - let setter= seekReadoptional_MethodSemantics ctxt (0x0001, TaggedIndex(hs_Property, idx)) - let getter = seekReadoptional_MethodSemantics ctxt (0x0002, TaggedIndex(hs_Property, idx)) + let setter= seekReadOptionalMethodSemantics ctxt (0x0001, TaggedIndex(hs_Property, idx)) + let getter = seekReadOptionalMethodSemantics ctxt (0x0002, TaggedIndex(hs_Property, idx)) (* NOTE: the "ThisConv" value on the property is not reliable: better to look on the getter/setter *) (* NOTE: e.g. tlbimp on Office msword.olb seems to set this incorrectly *) let cc2 = @@ -2603,37 +2600,37 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz: int) start s ilOffsetsOfLabels.[lab] <- ilOffset let ibuf = ResizeArray<_>(sz/2) - let curr = ref 0 + let mutable curr = 0 let prefixes = { al=Aligned; tl= Normalcall; vol= Nonvolatile;ro=NormalAddress;constrained=None } - let lastb = ref 0x0 - let lastb2 = ref 0x0 - let b = ref 0x0 + let mutable lastb = 0x0 + let mutable lastb2 = 0x0 + let mutable b = 0x0 let get () = - lastb := seekReadByteAsInt32 pev (start + (!curr)) - incr curr - b := - if !lastb = 0xfe && !curr < sz then - lastb2 := seekReadByteAsInt32 pev (start + (!curr)) - incr curr - !lastb2 + lastb <- seekReadByteAsInt32 pev (start + curr) + curr <- curr + 1 + b <- + if lastb = 0xfe && curr < sz then + lastb2 <- seekReadByteAsInt32 pev (start + curr) + curr <- curr + 1 + lastb2 else - !lastb + lastb - let seqPointsRemaining = ref seqpoints + let mutable seqPointsRemaining = seqpoints - while !curr < sz do + while curr < sz do // registering "+string !curr+" as start of an instruction") - markAsInstructionStart !curr ibuf.Count + markAsInstructionStart curr ibuf.Count // Insert any sequence points into the instruction sequence while - (match !seqPointsRemaining with - | (i, _tag) :: _rest when i <= !curr -> true + (match seqPointsRemaining with + | (i, _tag) :: _rest when i <= curr -> true | _ -> false) do // Emitting one sequence point - let _, tag = List.head !seqPointsRemaining - seqPointsRemaining := List.tail !seqPointsRemaining + let _, tag = List.head seqPointsRemaining + seqPointsRemaining <- List.tail seqPointsRemaining ibuf.Add (I_seqpoint tag) // Read the prefixes. Leave lastb and lastb2 holding the instruction byte(s) @@ -2644,27 +2641,27 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz: int) start s prefixes.ro<-NormalAddress prefixes.constrained<-None get () - while !curr < sz && - !lastb = 0xfe && - (!b = (i_constrained &&& 0xff) || - !b = (i_readonly &&& 0xff) || - !b = (i_unaligned &&& 0xff) || - !b = (i_volatile &&& 0xff) || - !b = (i_tail &&& 0xff)) do + while curr < sz && + lastb = 0xfe && + (b = (i_constrained &&& 0xff) || + b = (i_readonly &&& 0xff) || + b = (i_unaligned &&& 0xff) || + b = (i_volatile &&& 0xff) || + b = (i_tail &&& 0xff)) do begin - if !b = (i_unaligned &&& 0xff) then - let unal = seekReadByteAsInt32 pev (start + (!curr)) - incr curr + if b = (i_unaligned &&& 0xff) then + let unal = seekReadByteAsInt32 pev (start + curr) + curr <- curr + 1 prefixes.al <- if unal = 0x1 then Unaligned1 elif unal = 0x2 then Unaligned2 elif unal = 0x4 then Unaligned4 else (dprintn "bad alignment for unaligned"; Aligned) - elif !b = (i_volatile &&& 0xff) then prefixes.vol <- Volatile - elif !b = (i_readonly &&& 0xff) then prefixes.ro <- ReadonlyAddress - elif !b = (i_constrained &&& 0xff) then - let uncoded = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + elif b = (i_volatile &&& 0xff) then prefixes.vol <- Volatile + elif b = (i_readonly &&& 0xff) then prefixes.ro <- ReadonlyAddress + elif b = (i_constrained &&& 0xff) then + let uncoded = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 let ty = seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) prefixes.constrained <- Some ty else prefixes.tl <- Tailcall @@ -2674,45 +2671,45 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz: int) start s // data for instruction begins at "+string !curr // Read and decode the instruction - if (!curr <= sz) then + if (curr <= sz) then let idecoder = - if !lastb = 0xfe then getTwoByteInstr ( !lastb2) - else getOneByteInstr ( !lastb) + if lastb = 0xfe then getTwoByteInstr lastb2 + else getOneByteInstr lastb let instr = match idecoder with | I_u16_u8_instr f -> - let x = seekReadByte pev (start + (!curr)) |> uint16 - curr := !curr + 1 + let x = seekReadByte pev (start + curr) |> uint16 + curr <- curr + 1 f prefixes x | I_u16_u16_instr f -> - let x = seekReadUInt16 pev (start + (!curr)) - curr := !curr + 2 + let x = seekReadUInt16 pev (start + curr) + curr <- curr + 2 f prefixes x | I_none_instr f -> f prefixes | I_i64_instr f -> - let x = seekReadInt64 pev (start + (!curr)) - curr := !curr + 8 + let x = seekReadInt64 pev (start + curr) + curr <- curr + 8 f prefixes x | I_i32_i8_instr f -> - let x = seekReadSByte pev (start + (!curr)) |> int32 - curr := !curr + 1 + let x = seekReadSByte pev (start + curr) |> int32 + curr <- curr + 1 f prefixes x | I_i32_i32_instr f -> - let x = seekReadInt32 pev (start + (!curr)) - curr := !curr + 4 + let x = seekReadInt32 pev (start + curr) + curr <- curr + 4 f prefixes x | I_r4_instr f -> - let x = seekReadSingle pev (start + (!curr)) - curr := !curr + 4 + let x = seekReadSingle pev (start + curr) + curr <- curr + 4 f prefixes x | I_r8_instr f -> - let x = seekReadDouble pev (start + (!curr)) - curr := !curr + 8 + let x = seekReadDouble pev (start + curr) + curr <- curr + 8 f prefixes x | I_field_instr f -> - let tab, tok = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + let tab, tok = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 let fspec = if tab = TableNames.Field then seekReadFieldDefAsFieldSpec ctxt tok @@ -2723,8 +2720,8 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz: int) start s | I_method_instr f -> // method instruction, curr = "+string !curr - let tab, idx = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + let tab, idx = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 let (VarArgMethodData(enclTy, cc, nm, argtys, varargs, retty, minst)) = if tab = TableNames.Method then seekReadMethodDefOrRef ctxt numtypars (TaggedIndex(mdor_MethodDef, idx)) @@ -2745,42 +2742,42 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz: int) start s let mspec = mkILMethSpecInTy (enclTy, cc, nm, argtys, retty, minst) f prefixes (mspec, varargs) | I_type_instr f -> - let uncoded = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + let uncoded = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 let ty = seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) f prefixes ty | I_string_instr f -> - let tab, idx = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + let tab, idx = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 if tab <> TableNames.UserStrings then dprintn "warning: bad table in user string for ldstr" f prefixes (readUserStringHeap ctxt idx) | I_conditional_i32_instr f -> - let offsDest = (seekReadInt32 pev (start + (!curr))) - curr := !curr + 4 - let dest = !curr + offsDest + let offsDest = (seekReadInt32 pev (start + curr)) + curr <- curr + 4 + let dest = curr + offsDest f prefixes (rawToLabel dest) | I_conditional_i8_instr f -> - let offsDest = int (seekReadSByte pev (start + (!curr))) - curr := !curr + 1 - let dest = !curr + offsDest + let offsDest = int (seekReadSByte pev (start + curr)) + curr <- curr + 1 + let dest = curr + offsDest f prefixes (rawToLabel dest) | I_unconditional_i32_instr f -> - let offsDest = (seekReadInt32 pev (start + (!curr))) - curr := !curr + 4 - let dest = !curr + offsDest + let offsDest = (seekReadInt32 pev (start + curr)) + curr <- curr + 4 + let dest = curr + offsDest f prefixes (rawToLabel dest) | I_unconditional_i8_instr f -> - let offsDest = int (seekReadSByte pev (start + (!curr))) - curr := !curr + 1 - let dest = !curr + offsDest + let offsDest = int (seekReadSByte pev (start + curr)) + curr <- curr + 1 + let dest = curr + offsDest f prefixes (rawToLabel dest) | I_invalid_instr -> - dprintn ("invalid instruction: "+string !lastb+ (if !lastb = 0xfe then ", "+string !lastb2 else "")) + dprintn ("invalid instruction: "+string lastb+ (if lastb = 0xfe then ", "+string lastb2 else "")) I_ret | I_tok_instr f -> - let tab, idx = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + let tab, idx = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 (* REVIEW: this incorrectly labels all MemberRef tokens as ILMethod's: we should go look at the MemberRef sig to determine if it is a field or method *) let token_info = if tab = TableNames.Method || tab = TableNames.MemberRef (* REVIEW: generics or tab = TableNames.MethodSpec *) then @@ -2793,26 +2790,26 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz: int) start s else failwith "bad token for ldtoken" f prefixes token_info | I_sig_instr f -> - let tab, idx = seekReadUncodedToken pev (start + (!curr)) - curr := !curr + 4 + let tab, idx = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 if tab <> TableNames.StandAloneSig then dprintn "strange table for callsig token" let generic, _genarity, cc, retty, argtys, varargs = readBlobHeapAsMethodSig ctxt numtypars (seekReadStandAloneSigRow ctxt mdv idx) if generic then failwith "bad image: a generic method signature is begin used at a calli instruction" f prefixes (mkILCallSig (cc, argtys, retty), varargs) | I_switch_instr f -> - let n = (seekReadInt32 pev (start + (!curr))) - curr := !curr + 4 + let n = (seekReadInt32 pev (start + curr)) + curr <- curr + 4 let offsets = List.init n (fun _ -> - let i = (seekReadInt32 pev (start + (!curr))) - curr := !curr + 4 + let i = (seekReadInt32 pev (start + curr)) + curr <- curr + 4 i) - let dests = List.map (fun offs -> rawToLabel (!curr + offs)) offsets + let dests = List.map (fun offs -> rawToLabel (curr + offs)) offsets f prefixes dests ibuf.Add instr done // Finished reading instructions - mark the end of the instruction stream in case the PDB information refers to it. - markAsInstructionStart !curr ibuf.Count + markAsInstructionStart curr ibuf.Count // Build the function that maps from raw labels (offsets into the bytecode stream) to indexes in the AbsIL instruction stream let lab2pc = ilOffsetsOfLabels @@ -2962,11 +2959,11 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int // Read all the sections that follow the method body. // These contain the exception clauses. - let nextSectionBase = ref (align 4 (codeBase + codeSize)) - let moreSections = ref hasMoreSections - let seh = ref [] - while !moreSections do - let sectionBase = !nextSectionBase + let mutable nextSectionBase = align 4 (codeBase + codeSize) + let mutable moreSections = hasMoreSections + let mutable seh = [] + while moreSections do + let sectionBase = nextSectionBase let sectionFlag = seekReadByte pev sectionBase // fat format for "+nm+", sectionFlag = " + string sectionFlag) let sectionSize, clauses = @@ -3046,16 +3043,16 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int | _ -> sehMap.[key] <- [clause]) clauses ([], sehMap) ||> Seq.fold (fun acc (KeyValue(key, bs)) -> [ for b in bs -> {Range=key; Clause=b}: ILExceptionSpec ] @ acc) - seh := sehClauses - moreSections := (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy - nextSectionBase := sectionBase + sectionSize + seh <- sehClauses + moreSections <- (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy + nextSectionBase <- sectionBase + sectionSize done (* while *) // Convert the linear code format to the nested code format if logging then dprintn "doing localPdbInfos2" let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos if logging then dprintn "done localPdbInfos2, checking code..." - let code = buildILCode nm lab2pc instrs !seh localPdbInfos2 + let code = buildILCode nm lab2pc instrs seh localPdbInfos2 if logging then dprintn "done checking code." { IsZeroInit=initlocals @@ -3082,7 +3079,7 @@ and readBlobHeapAsNativeType ctxt blobIdx = let res, _ = sigptrGetILNativeType ctxt bytes 0 res -and sigptrGetILNativeType ctxt bytes sigptr = +and sigptrGetILNativeType ctxt bytes sigptr : ILNativeType * int = // reading native type blob, sigptr= "+string sigptr) let ntbyte, sigptr = sigptrGetByte bytes sigptr if List.memAssoc ntbyte (Lazy.force ILNativeTypeMap) then @@ -3276,19 +3273,19 @@ let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, p else let offset = seekReadInt32 mdv (pos + 0) let length = seekReadInt32 mdv (pos + 4) - let res = ref true - let fin = ref false - let n = ref 0 + let mutable res = true + let mutable fin = false + let mutable n = 0 // read and compare the stream name byte by byte - while (not !fin) do - let c= seekReadByteAsInt32 mdv (pos + 8 + (!n)) + while not fin do + let c= seekReadByteAsInt32 mdv (pos + 8 + n) if c = 0 then - fin := true - elif !n >= Array.length name || c <> name.[!n] then - res := false - incr n - if !res then Some(offset + metadataPhysLoc, length) - else look (i+1) (align 0x04 (pos + 8 + (!n))) + fin <- true + elif n >= Array.length name || c <> name.[n] then + res <- false + n <- n + 1 + if res then Some(offset + metadataPhysLoc, length) + else look (i+1) (align 0x04 (pos + 8 + n)) look 0 streamHeadersStart let findStream name = @@ -3383,15 +3380,15 @@ let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, p let valid = seekReadInt64 mdv (tablesStreamPhysLoc + 8) let sorted = seekReadInt64 mdv (tablesStreamPhysLoc + 16) let tablesPresent, tableRowCount, startOfTables = - let present = ref [] + let mutable present = [] let numRows = Array.create 64 0 - let prevNumRowIdx = ref (tablesStreamPhysLoc + 24) + let mutable prevNumRowIdx = tablesStreamPhysLoc + 24 for i = 0 to 63 do if (valid &&& (int64 1 <<< i)) <> int64 0 then - present := i :: !present - numRows.[i] <- (seekReadInt32 mdv !prevNumRowIdx) - prevNumRowIdx := !prevNumRowIdx + 4 - List.rev !present, numRows, !prevNumRowIdx + present <- i :: present + numRows.[i] <- (seekReadInt32 mdv prevNumRowIdx) + prevNumRowIdx <- prevNumRowIdx + 4 + List.rev present, numRows, prevNumRowIdx let getNumRows (tab: TableName) = tableRowCount.[tab.Index] let numTables = tablesPresent.Length @@ -3630,7 +3627,7 @@ let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, p guidsBigness=guidsBigness blobsBigness=blobsBigness tableBigness=tableBigness } - ctxtH := Some ctxt + ctxtH.Value <- Some ctxt let ilModule = seekReadModule ctxt reduceMemoryUsage pectxtEager pevEager peinfo (Encoding.UTF8.GetString (ilMetadataVersion, 0, ilMetadataVersion.Length)) 1 let ilAssemblyRefs = lazy [ for i in 1 .. getNumRows TableNames.AssemblyRef do yield seekReadAssemblyRef ctxt i ] diff --git a/src/fsharp/absil/ilsupp.fs b/src/fsharp/absil/ilsupp.fs index b5beb74e823..6e98d486954 100644 --- a/src/fsharp/absil/ilsupp.fs +++ b/src/fsharp/absil/ilsupp.fs @@ -514,8 +514,8 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink member x.Save(ulLinkedResourceBaseRVA: int32, pbLinkedResource: byte[], pUnlinkedResource: byte[], offset: int) = // Dump them to pUnlinkedResource // For each resource write header and data - let size = ref 0 - let unlinkedResourceOffset = ref 0 + let mutable size = 0 + let mutable unlinkedResourceOffset = 0 //resHdr.HeaderSize <- 32 if Unchecked.defaultof <> wzType then resHdr.HeaderSize <- resHdr.HeaderSize + ((cType + 1) * 2) - 4 @@ -524,9 +524,9 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink let SaveChunk(p: byte[], sz: int) = if Unchecked.defaultof <> pUnlinkedResource then - Bytes.blit p 0 pUnlinkedResource (!unlinkedResourceOffset + offset) sz - unlinkedResourceOffset := !unlinkedResourceOffset + sz - size := !size + sz + Bytes.blit p 0 pUnlinkedResource (unlinkedResourceOffset + offset) sz + unlinkedResourceOffset <- unlinkedResourceOffset + sz + size <- size + sz () @@ -569,7 +569,7 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink if dwFiller <> 0 then SaveChunk(bNil, 4 - dwFiller) - !size + size let linkNativeResources (unlinkedResources: byte[] list) (rva: int32) = let resources = diff --git a/src/fsharp/absil/ilwrite.fs b/src/fsharp/absil/ilwrite.fs index 1697acc5b4c..e63d543677b 100644 --- a/src/fsharp/absil/ilwrite.fs +++ b/src/fsharp/absil/ilwrite.fs @@ -627,8 +627,8 @@ type ILTokenMappings = PropertyTokenMap: ILTypeDef list * ILTypeDef -> ILPropertyDef -> int32 EventTokenMap: ILTypeDef list * ILTypeDef -> ILEventDef -> int32 } -let recordRequiredDataFixup requiredDataFixups (buf: ByteBuffer) pos lab = - requiredDataFixups := (pos, lab) :: !requiredDataFixups +let recordRequiredDataFixup (requiredDataFixups: ('T * 'U) list ref) (buf: ByteBuffer) pos lab = + requiredDataFixups.Value <- (pos, lab) :: requiredDataFixups.Value // Write a special value in that we check later when applying the fixup buf.EmitInt32 0xdeaddddd @@ -1586,23 +1586,22 @@ module Codebuf = // or long and adjusting the branch destinations. Record an adjust function to adjust all the other // gumpf that refers to fixed offsets in the code stream. let newCode, newReqdBrFixups, adjuster = - let remainingReqdFixups = ref orderedOrigReqdBrFixups - let origWhere = ref 0 - let newWhere = ref 0 - let doneLast = ref false - let newReqdBrFixups = ref [] - - let adjustments = ref [] - - while (!remainingReqdFixups <> [] || not !doneLast) do - let doingLast = isNil !remainingReqdFixups - let origStartOfNoBranchBlock = !origWhere - let newStartOfNoBranchBlock = !newWhere + let mutable remainingReqdFixups = orderedOrigReqdBrFixups + let mutable origWhere = 0 + let mutable newWhere = 0 + let mutable doneLast = false + let mutable newReqdBrFixups = [] + let mutable adjustments = [] + + while (remainingReqdFixups <> [] || not doneLast) do + let doingLast = isNil remainingReqdFixups + let origStartOfNoBranchBlock = origWhere + let newStartOfNoBranchBlock = newWhere let origEndOfNoBranchBlock = if doingLast then origCode.Length else - let _, origStartOfInstr, _ = List.head !remainingReqdFixups + let _, origStartOfInstr, _ = List.head remainingReqdFixups origStartOfInstr // Copy over a chunk of non-branching code @@ -1611,25 +1610,25 @@ module Codebuf = // Record how to adjust addresses in this range, including the branch instruction // we write below, or the end of the method if we're doing the last bblock - adjustments := (origStartOfNoBranchBlock, origEndOfNoBranchBlock, newStartOfNoBranchBlock) :: !adjustments + adjustments <- (origStartOfNoBranchBlock, origEndOfNoBranchBlock, newStartOfNoBranchBlock) :: adjustments // Increment locations to the branch instruction we're really interested in - origWhere := origEndOfNoBranchBlock - newWhere := !newWhere + nobranch_len + origWhere <- origEndOfNoBranchBlock + newWhere <- newWhere + nobranch_len // Now do the branch instruction. Decide whether the fixup will be short or long in the new code if doingLast then - doneLast := true + doneLast <- true else - let (i, origStartOfInstr, tgs: ILCodeLabel list) = List.head !remainingReqdFixups - remainingReqdFixups := List.tail !remainingReqdFixups + let (i, origStartOfInstr, tgs: ILCodeLabel list) = List.head remainingReqdFixups + remainingReqdFixups <-List.tail remainingReqdFixups if origCode.[origStartOfInstr] <> 0x11uy then failwith "br fixup sanity check failed (1)" let i_length = if fst i = i_switch then 5 else 1 - origWhere := !origWhere + i_length + origWhere <- origWhere + i_length let origEndOfInstr = origStartOfInstr + i_length + 4 * tgs.Length - let newEndOfInstrIfSmall = !newWhere + i_length + 1 - let newEndOfInstrIfBig = !newWhere + i_length + 4 * tgs.Length + let newEndOfInstrIfSmall = newWhere + i_length + 1 + let newEndOfInstrIfBig = newWhere + i_length + 4 * tgs.Length let short = match i, tgs with @@ -1654,28 +1653,28 @@ module Codebuf = newCode.EmitInt32 tgs.Length) false - newWhere := !newWhere + i_length - if !newWhere <> newCode.Position then dprintn "mismatch between newWhere and newCode" + newWhere <- newWhere + i_length + if newWhere <> newCode.Position then dprintn "mismatch between newWhere and newCode" tgs |> List.iter (fun tg -> - let origFixupLoc = !origWhere + let origFixupLoc = origWhere checkFixup32 origCode origFixupLoc 0xdeadbbbb if short then - newReqdBrFixups := (!newWhere, newEndOfInstrIfSmall, tg, true) :: !newReqdBrFixups + newReqdBrFixups <- (newWhere, newEndOfInstrIfSmall, tg, true) :: newReqdBrFixups newCode.EmitIntAsByte 0x98 (* sanity check *) - newWhere := !newWhere + 1 + newWhere <- newWhere + 1 else - newReqdBrFixups := (!newWhere, newEndOfInstrIfBig, tg, false) :: !newReqdBrFixups + newReqdBrFixups <- (newWhere, newEndOfInstrIfBig, tg, false) :: newReqdBrFixups newCode.EmitInt32 0xf00dd00f (* sanity check *) - newWhere := !newWhere + 4 - if !newWhere <> newCode.Position then dprintn "mismatch between newWhere and newCode" - origWhere := !origWhere + 4) + newWhere <- newWhere + 4 + if newWhere <> newCode.Position then dprintn "mismatch between newWhere and newCode" + origWhere <- origWhere + 4) - if !origWhere <> origEndOfInstr then dprintn "mismatch between origWhere and origEndOfInstr" + if origWhere <> origEndOfInstr then dprintn "mismatch between origWhere and origEndOfInstr" let adjuster = - let arr = Array.ofList (List.rev !adjustments) + let arr = Array.ofList (List.rev adjustments) fun addr -> let i = try binaryChop (fun (a1, a2, _) -> if addr < a1 then -1 elif addr > a2 then 1 else 0) arr @@ -1686,7 +1685,7 @@ module Codebuf = addr - (origStartOfNoBranchBlock - newStartOfNoBranchBlock) newCode.AsMemory().ToArray(), - !newReqdBrFixups, + newReqdBrFixups, adjuster // Now adjust everything @@ -3181,11 +3180,11 @@ let writeILMetadataAndCode (generatePdb, desiredMetadataVersion, ilg, emitTailca let stringAddressTable = let tab = Array.create (strings.Length + 1) 0 - let pos = ref 1 + let mutable pos = 1 for i = 1 to strings.Length do - tab.[i] <- !pos + tab.[i] <- pos let s = strings.[i - 1] - pos := !pos + s.Length + pos <- pos + s.Length tab let stringAddress n = @@ -3194,12 +3193,12 @@ let writeILMetadataAndCode (generatePdb, desiredMetadataVersion, ilg, emitTailca let userStringAddressTable = let tab = Array.create (Array.length userStrings + 1) 0 - let pos = ref 1 + let mutable pos = 1 for i = 1 to Array.length userStrings do - tab.[i] <- !pos + tab.[i] <- pos let s = userStrings.[i - 1] let n = s.Length + 1 - pos := !pos + n + ByteBuffer.Z32Size n + pos <- pos + n + ByteBuffer.Z32Size n tab let userStringAddress n = @@ -3208,11 +3207,11 @@ let writeILMetadataAndCode (generatePdb, desiredMetadataVersion, ilg, emitTailca let blobAddressTable = let tab = Array.create (blobs.Length + 1) 0 - let pos = ref 1 + let mutable pos = 1 for i = 1 to blobs.Length do - tab.[i] <- !pos + tab.[i] <- pos let blob = blobs.[i - 1] - pos := !pos + blob.Length + ByteBuffer.Z32Size blob.Length + pos <- pos + blob.Length + ByteBuffer.Z32Size blob.Length tab let blobAddress n = @@ -3483,7 +3482,7 @@ let writeILMetadataAndCode (generatePdb, desiredMetadataVersion, ilg, emitTailca applyFixup32 code locInCode token reportTime showTimes "Fixup Metadata" - entryPointToken, code, codePadding, metadata, data, resources, !requiredDataFixups, pdbData, mappings, guidStart + entryPointToken, code, codePadding, metadata, data, resources, requiredDataFixups.Value, pdbData, mappings, guidStart //--------------------------------------------------------------------- // PHYSICAL METADATA+BLOBS --> PHYSICAL PE FORMAT diff --git a/src/fsharp/absil/ilwritepdb.fs b/src/fsharp/absil/ilwritepdb.fs index a3806811771..dcfed598615 100644 --- a/src/fsharp/absil/ilwritepdb.fs +++ b/src/fsharp/absil/ilwritepdb.fs @@ -758,17 +758,17 @@ let writePdbInfo showTimes f fpdb info cvChunk = try FileSystem.FileDeleteShim fpdb with _ -> () - let pdbw = ref Unchecked.defaultof - - try - pdbw := pdbInitialize f fpdb - with _ -> error(Error(FSComp.SR.ilwriteErrorCreatingPdb fpdb, rangeCmdArgs)) + let pdbw = + try + pdbInitialize f fpdb + with _ -> + error(Error(FSComp.SR.ilwriteErrorCreatingPdb fpdb, rangeCmdArgs)) match info.EntryPoint with | None -> () - | Some x -> pdbSetUserEntryPoint !pdbw x + | Some x -> pdbSetUserEntryPoint pdbw x - let docs = info.Documents |> Array.map (fun doc -> pdbDefineDocument !pdbw doc.File) + let docs = info.Documents |> Array.map (fun doc -> pdbDefineDocument pdbw doc.File) let getDocument i = if i < 0 || i > docs.Length then failwith "getDocument: bad doc number" docs.[i] @@ -779,17 +779,17 @@ let writePdbInfo showTimes f fpdb info cvChunk = let spCounts = info.Methods |> Array.map (fun x -> x.DebugPoints.Length) let allSps = Array.collect (fun x -> x.DebugPoints) info.Methods |> Array.indexed - let spOffset = ref 0 + let mutable spOffset = 0 info.Methods |> Array.iteri (fun i minfo -> - let sps = Array.sub allSps !spOffset spCounts.[i] - spOffset := !spOffset + spCounts.[i] + let sps = Array.sub allSps spOffset spCounts.[i] + spOffset <- spOffset + spCounts.[i] begin match minfo.Range with | None -> () | Some (a,b) -> - pdbOpenMethod !pdbw minfo.MethToken + pdbOpenMethod pdbw minfo.MethToken - pdbSetMethodRange !pdbw + pdbSetMethodRange pdbw (getDocument a.Document) a.Line a.Column (getDocument b.Document) b.Line b.Column @@ -798,17 +798,17 @@ let writePdbInfo showTimes f fpdb info cvChunk = let res = Dictionary() for (_,sp) in sps do let k = sp.Document - let mutable xsR = Unchecked.defaultof<_> - if res.TryGetValue(k,&xsR) then - xsR := sp :: !xsR - else + match res.TryGetValue(k) with + | true, xsR -> + xsR.Value <- sp :: xsR.Value + | _ -> res.[k] <- ref [sp] res spsets - |> Seq.iter (fun kv -> - let spset = !kv.Value + |> Seq.iter (fun (KeyValue(_, vref)) -> + let spset = vref.Value if not spset.IsEmpty then let spset = Array.ofList spset Array.sortInPlaceWith SequencePoint.orderByOffset spset @@ -818,7 +818,7 @@ let writePdbInfo showTimes f fpdb info cvChunk = (sp.Offset, sp.Line, sp.Column,sp.EndLine, sp.EndColumn)) // Use of alloca in implementation of pdbDefineSequencePoints can give stack overflow here if sps.Length < 5000 then - pdbDefineSequencePoints !pdbw (getDocument spset.[0].Document) sps) + pdbDefineSequencePoints pdbw (getDocument spset.[0].Document) sps) // Write the scopes let rec writePdbScope parent sco = @@ -828,21 +828,21 @@ let writePdbInfo showTimes f fpdb info cvChunk = match parent with | Some p -> sco.StartOffset <> p.StartOffset || sco.EndOffset <> p.EndOffset | None -> true - if nested then pdbOpenScope !pdbw sco.StartOffset - sco.Locals |> Array.iter (fun v -> pdbDefineLocalVariable !pdbw v.Name v.Signature v.Index) + if nested then pdbOpenScope pdbw sco.StartOffset + sco.Locals |> Array.iter (fun v -> pdbDefineLocalVariable pdbw v.Name v.Signature v.Index) sco.Children |> Array.iter (writePdbScope (if nested then Some sco else parent)) - if nested then pdbCloseScope !pdbw sco.EndOffset + if nested then pdbCloseScope pdbw sco.EndOffset match minfo.RootScope with | None -> () | Some rootscope -> writePdbScope None rootscope - pdbCloseMethod !pdbw + pdbCloseMethod pdbw end) reportTime showTimes "PDB: Wrote methods" - let res = pdbWriteDebugInfo !pdbw + let res = pdbWriteDebugInfo pdbw for pdbDoc in docs do pdbCloseDocument pdbDoc - pdbClose !pdbw f fpdb + pdbClose pdbw f fpdb reportTime showTimes "PDB: Closed" [| { iddCharacteristics = res.iddCharacteristics diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 9f0440332fa..0a0352a7e2b 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -397,12 +397,12 @@ let inline cacheOptByref (cache: byref<'T option>) f = // REVIEW: this is only used because we want to mutate a record field, // and because you cannot take a byref<_> of such a thing directly, // we cannot use 'cacheOptByref'. If that is changed, this can be removed. -let inline cacheOptRef cache f = - match !cache with +let inline cacheOptRef (cache: _ ref) f = + match cache.Value with | Some v -> v | None -> let res = f() - cache := Some res + cache.Value <- Some res res let inline tryGetCacheValue cache = diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 007c52a0f58..81544ebefcd 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -1733,8 +1733,8 @@ memberCore: let optPropertyType = $3 let isMutable = false (fun visNoLongerUsed memFlagsBuilder attrs rangeStart -> - let hasGet = ref false - let hasSet = ref false + let mutable hasGet = false + let mutable hasSet = false // Iterate over 1 or 2 'get'/'set' entries $4 |> List.choose (fun (optInline, optAttrs, (bindingBuilder, mBindLhs), optReturnType, expr, exprm) -> @@ -1761,18 +1761,18 @@ memberCore: | _ -> raiseParseErrorAt mBindLhs (FSComp.SR.parsInvalidDeclarationSyntax()) go pv if getset = "get" then - if !hasGet then + if hasGet then reportParseErrorAt mBindLhs (FSComp.SR.parsGetAndOrSetRequired()) None else - hasGet := true + hasGet <- true Some SynMemberKind.PropertyGet else if getset = "set" then - if !hasSet then + if hasSet then reportParseErrorAt mBindLhs (FSComp.SR.parsGetAndOrSetRequired()) None else - hasSet := true + hasSet <- true Some SynMemberKind.PropertySet else raiseParseErrorAt mBindLhs (FSComp.SR.parsGetAndOrSetRequired()) diff --git a/src/fsharp/service/service.fs b/src/fsharp/service/service.fs index 329991dbcb4..b347ac8cbbf 100644 --- a/src/fsharp/service/service.fs +++ b/src/fsharp/service/service.fs @@ -140,7 +140,7 @@ module CompileHelpers = errors.ToArray(), result - let createDynamicAssembly (debugInfo: bool, tcImportsRef: TcImports option ref, execute: bool, assemblyBuilderRef: _ option ref) (tcConfig: TcConfig, tcGlobals:TcGlobals, outfile, ilxMainModule) = + let createDynamicAssembly (debugInfo: bool, tcImports: TcImports option, execute: bool, assemblyBuilderRef: _ option ref) (tcConfig: TcConfig, tcGlobals:TcGlobals, outfile, ilxMainModule) = // Create an assembly builder let assemblyName = AssemblyName(Path.GetFileNameWithoutExtension outfile) @@ -163,7 +163,7 @@ module CompileHelpers = // The function used to resolve types while emitting the code let assemblyResolver s = - match tcImportsRef.Value.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef s with + match tcImports.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef s with | Some res -> Some (Choice1Of2 res) | None -> None @@ -185,7 +185,7 @@ module CompileHelpers = Quotations.Expr.RegisterReflectedDefinitions (assemblyBuilder, moduleBuilder.Name, resource.GetBytes().ToArray()) // Save the result - assemblyBuilderRef := Some assemblyBuilder + assemblyBuilderRef.Value <- Some assemblyBuilder let setOutputStreams execute = // Set the output streams, if requested @@ -1133,13 +1133,13 @@ type FSharpChecker(legacyReferenceResolver, CompileHelpers.setOutputStreams execute // References used to capture the results of compilation - let tcImportsRef = ref None + let mutable tcImportsOpt = None let assemblyBuilderRef = ref None - let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) + let tcImportsCapture = Some (fun tcImports -> tcImportsOpt <- Some tcImports) // Function to generate and store the results of compilation let debugInfo = otherFlags |> Array.exists (fun arg -> arg = "-g" || arg = "--debug:+" || arg = "/debug:+") - let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsOpt, execute.IsSome, assemblyBuilderRef)) // Perform the compilation, given the above capturing function. let errorsAndWarnings, result = CompileHelpers.compileFromArgs (ctok, otherFlags, legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) @@ -1160,9 +1160,9 @@ type FSharpChecker(legacyReferenceResolver, CompileHelpers.setOutputStreams execute // References used to capture the results of compilation - let tcImportsRef = ref (None: TcImports option) + let mutable tcImportsOpt : TcImports option = None let assemblyBuilderRef = ref None - let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) + let tcImportsCapture = Some (fun tcImports -> tcImportsOpt <- Some tcImports) let debugInfo = defaultArg debug false let noframework = defaultArg noframework false @@ -1172,7 +1172,7 @@ type FSharpChecker(legacyReferenceResolver, let outFile = Path.Combine(location, assemblyName + ".dll") // Function to generate and store the results of compilation - let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsOpt, execute.IsSome, assemblyBuilderRef)) // Perform the compilation, given the above capturing function. let errorsAndWarnings, result = diff --git a/tests/service/AssemblyContentProviderTests.fs b/tests/service/AssemblyContentProviderTests.fs index db678bf70bb..64759a07d1f 100644 --- a/tests/service/AssemblyContentProviderTests.fs +++ b/tests/service/AssemblyContentProviderTests.fs @@ -35,10 +35,10 @@ let private checker = FSharpChecker.Create() let (=>) (source: string) (expected: string list) = let lines = use reader = new StringReader(source) - [| let line = ref (reader.ReadLine()) - while not (isNull !line) do - yield !line - line := reader.ReadLine() + [| let mutable line = reader.ReadLine() + while not (isNull line) do + yield line + line <- reader.ReadLine() if source.EndsWith "\n" then // last trailing space not returned // http://stackoverflow.com/questions/19365404/stringreader-omits-trailing-linebreak From 44b9ea825a2acbb21fe8f70a222fc32aa9de5fb6 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 9 Sep 2021 13:35:29 +0100 Subject: [PATCH 4/8] fix build, trim NoWarn --- src/fsharp/FSharp.Build/FSharp.Build.fsproj | 3 +-- .../FSharp.Compiler.Interactive.Settings.fsproj | 2 -- .../FSharp.Compiler.Service.fsproj | 8 ++++++-- src/fsharp/FSharp.Core/FSharp.Core.fsproj | 4 +++- .../FSharp.DependencyManager.Nuget.fsproj | 3 +-- src/fsharp/fsc/fsc.fsproj | 4 ++-- src/fsharp/fsi/fsi.fsproj | 4 ++-- src/fsharp/fsiAnyCpu/fsiAnyCpu.fsproj | 4 ++-- src/fsharp/pars.fsy | 10 +++++----- .../FSharp.Compiler.ComponentTests.fsproj | 1 - .../FSharp.Compiler.UnitTests.fsproj | 1 - tests/FSharp.Compiler.UnitTests/FsiTests.fs | 6 +++--- 12 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/fsharp/FSharp.Build/FSharp.Build.fsproj b/src/fsharp/FSharp.Build/FSharp.Build.fsproj index 2b177a3d817..3999f24600b 100644 --- a/src/fsharp/FSharp.Build/FSharp.Build.fsproj +++ b/src/fsharp/FSharp.Build/FSharp.Build.fsproj @@ -7,9 +7,8 @@ netstandard2.0 netstandard2.0 FSharp.Build - $(NoWarn);45;55;62;75;1204 + $(NoWarn);75 true - $(OtherFlags) --maxerrors:20 --extraoptimizationloops:1 $(DefineConstants);LOCALIZATION_FSBUILD NU1701;FS0075 true diff --git a/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj b/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj index 6238ce79e8c..950d3294e9d 100644 --- a/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj +++ b/src/fsharp/FSharp.Compiler.Interactive.Settings/FSharp.Compiler.Interactive.Settings.fsproj @@ -6,9 +6,7 @@ Library netstandard2.0 FSharp.Compiler.Interactive.Settings - $(NoWarn);45;55;62;75;1182;1204 true - $(OtherFlags) --maxerrors:20 --extraoptimizationloops:1 diff --git a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index bf353c83e36..59f4fbb69fd 100644 --- a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -5,12 +5,16 @@ net472;netstandard2.0 Library - $(NoWarn);44;45;54;55;57;61;62;69;65;75;1204;2003;NU5125 + $(NoWarn);44 + $(NoWarn);57 + $(NoWarn);75 + $(NoWarn);1204 + $(NoWarn);NU5125 FSharp.Compiler.Service true $(DefineConstants);COMPILER $(DefineConstants);ENABLE_MONO_SUPPORT - $(OtherFlags) /warnon:3218 /warnon:1182 /warnon:3390 --maxerrors:20 --extraoptimizationloops:1 --times + $(OtherFlags) /warnon:3218 /warnon:1182 /warnon:3390 --extraoptimizationloops:1 --times $(OtherFlags) /langversion:preview true $(IntermediateOutputPath)$(TargetFramework)\ diff --git a/src/fsharp/FSharp.Core/FSharp.Core.fsproj b/src/fsharp/FSharp.Core/FSharp.Core.fsproj index 4fafe661c48..6b1e945d68f 100644 --- a/src/fsharp/FSharp.Core/FSharp.Core.fsproj +++ b/src/fsharp/FSharp.Core/FSharp.Core.fsproj @@ -5,7 +5,9 @@ Library netstandard2.1;netstandard2.0 - $(NoWarn);45;55;62;75;1204 + $(NoWarn);62 + $(NoWarn);75 + $(NoWarn);1204 true $(DefineConstants);FSHARP_CORE BUILDING_WITH_LKG;$(DefineConstants) diff --git a/src/fsharp/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Nuget.fsproj b/src/fsharp/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Nuget.fsproj index 6c1f6fa60bd..f268fa658a3 100644 --- a/src/fsharp/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Nuget.fsproj +++ b/src/fsharp/FSharp.DependencyManager.Nuget/FSharp.DependencyManager.Nuget.fsproj @@ -6,10 +6,9 @@ Library netstandard2.0 FSharp.DependencyManager.Nuget - $(NoWarn);45;55;62;75;1204 true $(DefineConstants);COMPILER - $(OtherFlags) --warnon:1182 --maxerrors:20 --extraoptimizationloops:1 + $(OtherFlags) --warnon:1182 true diff --git a/src/fsharp/fsc/fsc.fsproj b/src/fsharp/fsc/fsc.fsproj index 7fa31fc2151..1bf8a94662c 100644 --- a/src/fsharp/fsc/fsc.fsproj +++ b/src/fsharp/fsc/fsc.fsproj @@ -7,9 +7,9 @@ $(ProtoTargetFramework) net472;net5.0 net5.0 - $(NoWarn);44;45;55;62;75;1204 + $(NoWarn);44 + $(NoWarn);75 true - $(OtherFlags) --maxerrors:20 --extraoptimizationloops:1 true true diff --git a/src/fsharp/fsi/fsi.fsproj b/src/fsharp/fsi/fsi.fsproj index 9fd9b1333bf..92a49762975 100644 --- a/src/fsharp/fsi/fsi.fsproj +++ b/src/fsharp/fsi/fsi.fsproj @@ -7,9 +7,9 @@ $(ProtoTargetFramework) net472;net5.0 net5.0 - $(NoWarn);44;45;55;62;75;1204 + $(NoWarn);44 true - $(OtherFlags) --warnon:1182 --maxerrors:20 --extraoptimizationloops:1 + $(OtherFlags) --warnon:1182 fsi.res true true diff --git a/src/fsharp/fsiAnyCpu/fsiAnyCpu.fsproj b/src/fsharp/fsiAnyCpu/fsiAnyCpu.fsproj index 85e7e6f929a..a95e06a40b2 100644 --- a/src/fsharp/fsiAnyCpu/fsiAnyCpu.fsproj +++ b/src/fsharp/fsiAnyCpu/fsiAnyCpu.fsproj @@ -7,9 +7,9 @@ net472 AnyCPU .exe - $(NoWarn);44;45;55;62;75;1204 + $(NoWarn);44 true - $(OtherFlags) --warnon:1182 --maxerrors:20 --extraoptimizationloops:1 + $(OtherFlags) --warnon:1182 ..\fsi\fsi.res true true diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 81544ebefcd..d4dd38e53d2 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -329,7 +329,7 @@ let rangeOfLongIdent(lid:LongIdent) = %type typedSequentialExprBlock %type atomicExpr %type tyconDefnOrSpfnSimpleRepr -%type <(SynEnumCase, SynUnionCase) Choice list> unionTypeRepr +%type list> unionTypeRepr %type tyconDefnAugmentation %type exconDefn %type exconCore @@ -4119,15 +4119,15 @@ minusExpr: | PLUS_MINUS_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~" + ($1)) $2 } | ADJACENT_PREFIX_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~" + ($1)) $2 } | PERCENT_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~" + ($1)) $2 } | AMP minusExpr { SynExpr.AddressOf (true, $2, rhs parseState 1, unionRanges (rhs parseState 1) $2.Range) } @@ -4166,7 +4166,7 @@ argExpr: { let arg2, hpa2 = $2 if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt arg2.Range (FSComp.SR.parsInvalidPrefixOperator()) if hpa2 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsSuccessiveArgsShouldBeSpacedOrTupled()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) arg2.Range) ("~"^($1)) arg2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) arg2.Range) ("~" + ($1)) arg2 } | atomicExpr { let arg, hpa = $1 diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 5df7e6a3e29..4294da8286d 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -10,7 +10,6 @@ false $(OtherFlags) --warnon:1182 xunit - $(NoWarn);3186;1104;FS0988 diff --git a/tests/FSharp.Compiler.UnitTests/FSharp.Compiler.UnitTests.fsproj b/tests/FSharp.Compiler.UnitTests/FSharp.Compiler.UnitTests.fsproj index dda54a28a49..ee836d5942f 100644 --- a/tests/FSharp.Compiler.UnitTests/FSharp.Compiler.UnitTests.fsproj +++ b/tests/FSharp.Compiler.UnitTests/FSharp.Compiler.UnitTests.fsproj @@ -9,7 +9,6 @@ true $(DefineConstants);ASSUME_PREVIEW_FSHARP_CORE xunit - $(NoWarn);57;3186;1104 diff --git a/tests/FSharp.Compiler.UnitTests/FsiTests.fs b/tests/FSharp.Compiler.UnitTests/FsiTests.fs index a19e329843e..68ea2fea182 100644 --- a/tests/FSharp.Compiler.UnitTests/FsiTests.fs +++ b/tests/FSharp.Compiler.UnitTests/FsiTests.fs @@ -532,15 +532,15 @@ module FsiTests = inherit FSharpFunc() override _.Invoke x = x - type ``Test2FSharp @ Func``() = + type Test2FSharpInheritFunc() = inherit TestFSharpFunc() [] let ``Creation of a bound value succeeds if the value is a type that inherits FSharpFunc`` () = use fsiSession = createFsiSession () - fsiSession.AddBoundValue("test", ``Test2FSharp @ Func``()) + fsiSession.AddBoundValue("test", Test2FSharpInheritFunc()) let boundValue = fsiSession.GetBoundValues() |> List.exactlyOne - Assert.shouldBe typeof<``Test2FSharp @ Func``> boundValue.Value.ReflectionType + Assert.shouldBe typeof boundValue.Value.ReflectionType From 35e176a71cbc791438931d9184620c4783f5a80e Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Sep 2021 13:49:08 +0100 Subject: [PATCH 5/8] fix build --- .../FSharp.Compiler.ComponentTests.fsproj | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 4294da8286d..48044317cdf 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -10,6 +10,7 @@ false $(OtherFlags) --warnon:1182 xunit + $(NoWarn);FS0988 From b2325dcfa8033df3accd66d0f0df9ed473cccef0 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Sep 2021 13:49:43 +0100 Subject: [PATCH 6/8] fix build --- .vscode/settings.json | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 .vscode/settings.json diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000000..48e4d8b9fb2 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "editor.trimAutoWhitespace": false, + "files.trimTrailingWhitespace": false, + "FSharp.suggestGitignore": false, + "FSharp.workspacePath": "FSharp.sln", + "dotnet-test-explorer.testProjectPath": "tests/*Tests/" +} \ No newline at end of file From 80d502019941786ad0c351a2ff482d99f2019717 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Sep 2021 13:51:58 +0100 Subject: [PATCH 7/8] remove preview from FCS build --- .../FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj | 1 - 1 file changed, 1 deletion(-) diff --git a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 59f4fbb69fd..5ee3e8b8780 100644 --- a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -15,7 +15,6 @@ $(DefineConstants);COMPILER $(DefineConstants);ENABLE_MONO_SUPPORT $(OtherFlags) /warnon:3218 /warnon:1182 /warnon:3390 --extraoptimizationloops:1 --times - $(OtherFlags) /langversion:preview true $(IntermediateOutputPath)$(TargetFramework)\ $(IntermediateOutputPath)$(TargetFramework)\ From 215554190f31fe1c105821c9974d30526492d980 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 15 Sep 2021 22:42:00 +0100 Subject: [PATCH 8/8] fix test --- src/fsharp/service/service.fs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/fsharp/service/service.fs b/src/fsharp/service/service.fs index b347ac8cbbf..1a852854828 100644 --- a/src/fsharp/service/service.fs +++ b/src/fsharp/service/service.fs @@ -140,7 +140,7 @@ module CompileHelpers = errors.ToArray(), result - let createDynamicAssembly (debugInfo: bool, tcImports: TcImports option, execute: bool, assemblyBuilderRef: _ option ref) (tcConfig: TcConfig, tcGlobals:TcGlobals, outfile, ilxMainModule) = + let createDynamicAssembly (debugInfo: bool, tcImportsRef: TcImports option ref, execute: bool, assemblyBuilderRef: _ option ref) (tcConfig: TcConfig, tcGlobals:TcGlobals, outfile, ilxMainModule) = // Create an assembly builder let assemblyName = AssemblyName(Path.GetFileNameWithoutExtension outfile) @@ -163,7 +163,7 @@ module CompileHelpers = // The function used to resolve types while emitting the code let assemblyResolver s = - match tcImports.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef s with + match tcImportsRef.Value.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef s with | Some res -> Some (Choice1Of2 res) | None -> None @@ -1133,13 +1133,13 @@ type FSharpChecker(legacyReferenceResolver, CompileHelpers.setOutputStreams execute // References used to capture the results of compilation - let mutable tcImportsOpt = None + let tcImportsRef = ref None let assemblyBuilderRef = ref None - let tcImportsCapture = Some (fun tcImports -> tcImportsOpt <- Some tcImports) + let tcImportsCapture = Some (fun tcImports -> tcImportsRef.Value <- Some tcImports) // Function to generate and store the results of compilation let debugInfo = otherFlags |> Array.exists (fun arg -> arg = "-g" || arg = "--debug:+" || arg = "/debug:+") - let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsOpt, execute.IsSome, assemblyBuilderRef)) + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) // Perform the compilation, given the above capturing function. let errorsAndWarnings, result = CompileHelpers.compileFromArgs (ctok, otherFlags, legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) @@ -1160,9 +1160,9 @@ type FSharpChecker(legacyReferenceResolver, CompileHelpers.setOutputStreams execute // References used to capture the results of compilation - let mutable tcImportsOpt : TcImports option = None + let tcImportsRef = ref (None: TcImports option) let assemblyBuilderRef = ref None - let tcImportsCapture = Some (fun tcImports -> tcImportsOpt <- Some tcImports) + let tcImportsCapture = Some (fun tcImports -> tcImportsRef.Value <- Some tcImports) let debugInfo = defaultArg debug false let noframework = defaultArg noframework false @@ -1172,7 +1172,7 @@ type FSharpChecker(legacyReferenceResolver, let outFile = Path.Combine(location, assemblyName + ".dll") // Function to generate and store the results of compilation - let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsOpt, execute.IsSome, assemblyBuilderRef)) + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) // Perform the compilation, given the above capturing function. let errorsAndWarnings, result =