Optimize format string parsing

src/fsharp/CheckFormatStrings.fs

@@ -10,6 +10,7 @@ open Microsoft.FSharp.Compiler.Tast
 open Microsoft.FSharp.Compiler.Tastops
 open Microsoft.FSharp.Compiler.TcGlobals
 open Microsoft.FSharp.Compiler.ConstraintSolver
+open Microsoft.FSharp.Compiler.NameResolution
 
 type FormatItem = Simple of TType | FuncAndVal 
 
@@ -47,27 +48,21 @@ let newInfo ()=
     addZeros       = false
     precision      = false}
 
-let parseFormatStringInternal (m:range) (g: TcGlobals) (source: string option) fmt bty cty = 
+let parseFormatStringInternal (m:range) (g: TcGlobals) (context: FormatStringCheckContext option) fmt bty cty = 
     // Offset is used to adjust ranges depending on whether input string is regular, verbatim or triple-quote.
     // We construct a new 'fmt' string since the current 'fmt' string doesn't distinguish between "\n" and escaped "\\n".
     let (offset, fmt) = 
-        match source with
-        | Some source ->
-            let source = source.Replace("\r\n", "\n").Replace("\r", "\n")
-            let positions =
-                source.Split('\n')
-                |> Seq.map (fun s -> String.length s + 1)
-                |> Seq.scan (+) 0
-                |> Seq.toArray
-            let length = source.Length
-            if m.EndLine < positions.Length then
-                let startIndex = positions.[m.StartLine-1] + m.StartColumn
-                let endIndex = positions.[m.EndLine-1] + m.EndColumn - 1
-                if startIndex < length-3 && source.[startIndex..startIndex+2] = "\"\"\"" then
-                    (3, source.[startIndex+3..endIndex-3])
-                elif startIndex < length-2 && source.[startIndex..startIndex+1] = "@\"" then
-                    (2, source.[startIndex+2..endIndex-1])
-                else (1, source.[startIndex+1..endIndex-1])
+        match context with
+        | Some context ->
+            let length = context.NormalizedSource.Length
+            if m.EndLine < context.LineEndPositions.Length then
+                let startIndex = context.LineEndPositions.[m.StartLine-1] + m.StartColumn
+                let endIndex = context.LineEndPositions.[m.EndLine-1] + m.EndColumn - 1
+                if startIndex < length-3 && context.NormalizedSource.[startIndex..startIndex+2] = "\"\"\"" then
+                    (3, context.NormalizedSource.[startIndex+3..endIndex-3])
+                elif startIndex < length-2 && context.NormalizedSource.[startIndex..startIndex+1] = "@\"" then
+                    (2, context.NormalizedSource.[startIndex+2..endIndex-1])
+                else (1, context.NormalizedSource.[startIndex+1..endIndex-1])
             else (1, fmt)
         | None -> (1, fmt)
 
@@ -292,8 +287,8 @@ let parseFormatStringInternal (m:range) (g: TcGlobals) (source: string option) f
     let results = parseLoop [] (0, 0, m.StartColumn)
     results, Seq.toList specifierLocations
 
-let ParseFormatString m g source fmt bty cty dty = 
-    let argtys, specifierLocations = parseFormatStringInternal m g source fmt bty cty
+let ParseFormatString m g formatStringCheckContext fmt bty cty dty = 
+    let argtys, specifierLocations = parseFormatStringInternal m g formatStringCheckContext fmt bty cty
     let aty = List.foldBack (-->) argtys dty
     let ety = mkRefTupledTy g argtys
     (aty, ety), specifierLocations 

src/fsharp/CheckFormatStrings.fsi

@@ -8,9 +8,10 @@
 module internal Microsoft.FSharp.Compiler.CheckFormatStrings
 
 open Microsoft.FSharp.Compiler 
+open Microsoft.FSharp.Compiler.NameResolution
 open Microsoft.FSharp.Compiler.Tast 
 open Microsoft.FSharp.Compiler.TcGlobals
 
-val ParseFormatString : Range.range -> TcGlobals -> source: string option -> fmt: string -> bty: TType -> cty: TType -> dty: TType -> (TType * TType) * (Range.range * int) list
+val ParseFormatString : Range.range -> TcGlobals -> formatStringCheckContext: FormatStringCheckContext option -> fmt: string -> bty: TType -> cty: TType -> dty: TType -> (TType * TType) * (Range.range * int) list
 
 val TryCountFormatStringArguments : m:Range.range -> g:TcGlobals -> fmt:string -> bty:TType -> cty:TType -> int option

src/fsharp/NameResolution.fs

@@ -1246,6 +1246,10 @@ type OpenDeclaration =
           AppliedScope = appliedScope
           IsOwnNamespace = isOwnNamespace }
 
+type FormatStringCheckContext =
+    { NormalizedSource: string
+      LineEndPositions: int[] }
+
 /// An abstract type for reporting the results of name resolution and type checking.
 type ITypecheckResultsSink =
     abstract NotifyEnvWithScope : range * NameResolutionEnv * AccessorDomain -> unit
@@ -1254,6 +1258,7 @@ type ITypecheckResultsSink =
     abstract NotifyFormatSpecifierLocation : range * int -> unit
     abstract NotifyOpenDeclaration : OpenDeclaration -> unit
     abstract CurrentSource : string option
+    abstract FormatStringCheckContext : FormatStringCheckContext option
 
 let (|ValRefOfProp|_|) (pi : PropInfo) = pi.ArbitraryValRef
 let (|ValRefOfMeth|_|) (mi : MethInfo) = mi.ArbitraryValRef
@@ -1497,7 +1502,6 @@ type TcSymbolUses(g, capturedNameResolutions : ResizeArray<CapturedNameResolutio
 
     member this.GetFormatSpecifierLocationsAndArity() = formatSpecifierLocations
 
-
 /// An accumulator for the results being emitted into the tcSink.
 type TcResultsSinkImpl(g, ?source: string) =
     let capturedEnvs = ResizeArray<_>()
@@ -1521,6 +1525,18 @@ type TcResultsSinkImpl(g, ?source: string) =
     let capturedOpenDeclarations = ResizeArray<OpenDeclaration>()
     let allowedRange (m:range) = not m.IsSynthetic       
 
+    let formatStringCheckContext =
+        lazy
+            source |> Option.map (fun source ->
+                let source = source.Replace("\r\n", "\n").Replace("\r", "\n")
+                let positions =
+                    source.Split('\n')
+                    |> Seq.map (fun s -> String.length s + 1)
+                    |> Seq.scan (+) 0
+                    |> Seq.toArray
+                { NormalizedSource = source 
+                  LineEndPositions = positions })
+
     member this.GetResolutions() = 
         TcResolutions(capturedEnvs, capturedExprTypings, capturedNameResolutions, capturedMethodGroupResolutions)
 
@@ -1574,7 +1590,8 @@ type TcResultsSinkImpl(g, ?source: string) =
             capturedOpenDeclarations.Add(openDeclaration)
 
         member sink.CurrentSource = source
-
+
+        member sink.FormatStringCheckContext = formatStringCheckContext.Value
 
 /// An abstract type for reporting the results of name resolution and type checking, and which allows
 /// temporary suspension and/or redirection of reporting.

src/fsharp/NameResolution.fsi

@@ -341,6 +341,13 @@ type internal OpenDeclaration =
     /// Create a new instance of OpenDeclaration.
     static member Create : longId: Ident list * modules: ModuleOrNamespaceRef list * appliedScope: range * isOwnNamespace: bool -> OpenDeclaration
 
+/// Line-end normalized source text and an array of line end positions, used for format string parsing
+type FormatStringCheckContext =
+    { /// Line-end normalized source text
+      NormalizedSource: string
+      /// Array of line end positions
+      LineEndPositions: int[] }
+
 /// An abstract type for reporting the results of name resolution and type checking
 type ITypecheckResultsSink =
 
@@ -362,6 +369,9 @@ type ITypecheckResultsSink =
     /// Get the current source
     abstract CurrentSource : string option
 
+    /// Cached line-end normalized source text and an array of line end positions, used for format string parsing
+    abstract FormatStringCheckContext : FormatStringCheckContext option
+
 /// An implementation of ITypecheckResultsSink to collect information during type checking
 type internal TcResultsSinkImpl =
 

src/fsharp/TypeChecker.fs

@@ -1840,7 +1840,8 @@ let MakeAndPublishSimpleVals cenv env m names mergeNamesInOneNameresEnv =
                         member this.NotifyExprHasType(_, _, _, _, _, _) = assert false // no expr typings in MakeSimpleVals
                         member this.NotifyFormatSpecifierLocation(_, _) = ()
                         member this.NotifyOpenDeclaration(_) = ()
-                        member this.CurrentSource = None } 
+                        member this.CurrentSource = None 
+                        member this.FormatStringCheckContext = None } 
 
                 use _h = WithNewTypecheckResultsSink(sink, cenv.tcSink)
                 MakeSimpleVals cenv env names
@@ -6785,10 +6786,10 @@ and TcConstStringExpr cenv overallTy env m tpenv s  =
       let ty' = mkPrintfFormatTy cenv.g aty bty cty dty ety
       if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy ty') then 
         // Parse the format string to work out the phantom types 
-        let source = match cenv.tcSink.CurrentSink with None -> None | Some sink -> sink.CurrentSource
+        let formatStringCheckContext = match cenv.tcSink.CurrentSink with None -> None | Some sink -> sink.FormatStringCheckContext
         let normalizedString = (s.Replace("\r\n", "\n").Replace("\r", "\n"))
 
-        let (aty', ety'), specifierLocations = (try CheckFormatStrings.ParseFormatString m cenv.g source normalizedString bty cty dty with Failure s -> error (Error(FSComp.SR.tcUnableToParseFormatString(s), m)))
+        let (aty', ety'), specifierLocations = (try CheckFormatStrings.ParseFormatString m cenv.g formatStringCheckContext normalizedString bty cty dty with Failure s -> error (Error(FSComp.SR.tcUnableToParseFormatString(s), m)))
 
         match cenv.tcSink.CurrentSink with 
         | None -> ()