[Pkg-cli-apps-commits] [fsharp] 12/71: undo unintentionial changes in code drop
Christopher Halse Rogers
raof-guest at moszumanska.debian.org
Fri Jan 17 05:18:09 UTC 2014
This is an automated email from the git hooks/post-receive script.
raof-guest pushed a commit to tag 3.1.0
in repository fsharp.
commit 4f19594b6f7175ae21c17bc0e053ce7f5fb924ae
Author: Don Syme <donsyme at fastmail.fm>
Date: Thu Oct 3 20:54:09 2013 +0100
undo unintentionial changes in code drop
---
src/absil/ilsupp.fs | 4 -
src/absil/ilsupp.fsi | 1 -
src/absil/ilwrite.fs | 4 -
src/fsharp/ErrorLogger.fs | 6 +-
src/fsharp/FSharp.Build/Fsc.fs | 5 -
src/fsharp/FSharp.Build/Fsc.fsi | 1 -
src/fsharp/ReferenceResolution.fs | 41 ++-
src/fsharp/build.fs | 167 +++--------
src/fsharp/build.fsi | 28 --
src/fsharp/fsc.fs | 569 ++++---------------------------------
src/fsharp/fsc.fsi | 24 --
src/fsharp/fscmain.fs | 279 +++++++++++++++++-
src/utils/CompilerLocationUtils.fs | 2 +
13 files changed, 400 insertions(+), 731 deletions(-)
diff --git a/src/absil/ilsupp.fs b/src/absil/ilsupp.fs
index d014e06..d3870f3 100755
--- a/src/absil/ilsupp.fs
+++ b/src/absil/ilsupp.fs
@@ -1059,10 +1059,6 @@ let pdbInitialize (binaryName:string) (pdbName:string) =
[<assembly:System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Reliability", "CA2001:AvoidCallingProblematicMethods", Scope="member", Target="Microsoft.FSharp.Compiler.AbstractIL.Internal.Support.#pdbClose(Microsoft.FSharp.Compiler.AbstractIL.Internal.Support+PdbWriter)", MessageId="System.GC.Collect")>]
do()
-let pdbCloseDocument(documentWriter : PdbDocumentWriter) =
- Marshal.ReleaseComObject (documentWriter.symDocWriter)
- |> ignore
-
[<System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Reliability", "CA2001:AvoidCallingProblematicMethods", MessageId="System.GC.Collect")>]
let pdbClose (writer:PdbWriter) =
writer.symWriter.Close()
diff --git a/src/absil/ilsupp.fsi b/src/absil/ilsupp.fsi
index 44cd9a5..d6e4f0e 100755
--- a/src/absil/ilsupp.fsi
+++ b/src/absil/ilsupp.fsi
@@ -108,7 +108,6 @@ val pdbInitialize:
string (* .pdb to write *) ->
PdbWriter
val pdbClose: PdbWriter -> unit
-val pdbCloseDocument : PdbDocumentWriter -> unit
val pdbSetUserEntryPoint: PdbWriter -> int32 -> unit
val pdbDefineDocument: PdbWriter -> string -> PdbDocumentWriter
val pdbOpenMethod: PdbWriter -> int32 -> unit
diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs
index 67174d8..1046cf5 100755
--- a/src/absil/ilwrite.fs
+++ b/src/absil/ilwrite.fs
@@ -346,10 +346,6 @@ let WritePdbInfo fixupOverlappingSequencePoints showTimes f fpdb info =
end);
reportTime showTimes "PDB: Wrote methods";
let res = pdbGetDebugInfo !pdbw
-
- for pdbDoc in docs do
- pdbCloseDocument pdbDoc
-
pdbClose !pdbw;
reportTime showTimes "PDB: Closed";
res
diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs
index 7bf7fb1..2efa860 100755
--- a/src/fsharp/ErrorLogger.fs
+++ b/src/fsharp/ErrorLogger.fs
@@ -240,10 +240,8 @@ type ErrorLogger(nameForDebugging:string) =
this.ErrorSinkImpl err
member this.DebugDisplay() = sprintf "ErrorLogger(%s)" nameForDebugging
// record the reported error/warning numbers for SQM purpose
- abstract ErrorNumbers : int list
- abstract WarningNumbers : int list
- default this.ErrorNumbers = []
- default this.WarningNumbers = []
+ abstract ErrorOrWarningNumbers : int list
+ default this.ErrorOrWarningNumbers = []
let DiscardErrorsLogger =
{ new ErrorLogger("DiscardErrorsLogger") with
diff --git a/src/fsharp/FSharp.Build/Fsc.fs b/src/fsharp/FSharp.Build/Fsc.fs
index 78fb412..857b8eb 100755
--- a/src/fsharp/FSharp.Build/Fsc.fs
+++ b/src/fsharp/FSharp.Build/Fsc.fs
@@ -550,11 +550,6 @@ type [<Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1704:Iden
fsc.GenerateCommandLineCommands()
member internal fsc.InternalExecuteTool(pathToTool, responseFileCommands, commandLineCommands) =
fsc.ExecuteTool(pathToTool, responseFileCommands, commandLineCommands)
- member internal fsc.GetCapturedArguments() =
- [|
- yield! capturedArguments
- yield! capturedFilenames
- |]
module Attributes =
//[<assembly: System.Security.SecurityTransparent>]
diff --git a/src/fsharp/FSharp.Build/Fsc.fsi b/src/fsharp/FSharp.Build/Fsc.fsi
index 8633f70..61a8ec4 100755
--- a/src/fsharp/FSharp.Build/Fsc.fsi
+++ b/src/fsharp/FSharp.Build/Fsc.fsi
@@ -13,7 +13,6 @@ type Fsc = class
member internal InternalGenerateFullPathToTool : unit -> System.String
member internal InternalGenerateCommandLineCommands : unit -> System.String
member internal InternalExecuteTool : string * string * string -> int
- member internal GetCapturedArguments : unit -> string[]
member BaseAddress : string with get,set
member CodePage : string with get,set
member DebugSymbols : bool with get,set
diff --git a/src/fsharp/ReferenceResolution.fs b/src/fsharp/ReferenceResolution.fs
index 3f2cc66..639749a 100644
--- a/src/fsharp/ReferenceResolution.fs
+++ b/src/fsharp/ReferenceResolution.fs
@@ -78,7 +78,7 @@ module internal MSBuildResolver =
// 1. List of frameworks
// 2. DeriveTargetFrameworkDirectoriesFor45Plus
// 3. HighestInstalledNetFrameworkVersionMajorMinor
- // 4. GetPathToDotNetFramework
+ // 4. GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch
[<Literal>]
let private Net10 = "v1.0"
[<Literal>]
@@ -98,8 +98,13 @@ module internal MSBuildResolver =
let SupportedNetFrameworkVersions = set [ Net20; Net30; Net35; Net40; Net45; Net451; (*SL only*) "v5.0" ]
- let GetPathToDotNetFramework(v) =
-#if FX_ATLEAST_45
+#if CROSS_PLATFORM_COMPILER
+ // Mono doesn't have GetPathToDotNetFramework. In this case we simply don't search this extra directory.
+ // When the x-plat compiler is run on Mono this is ok since implementation assembly folder is the same as the target framework folder.
+ // When the x-plat compiler is run on Windows/.NET this will curently cause slightly divergent behaviour.
+ let GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch _v = []
+#else
+ let GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch v =
let v =
match v with
| Net11 -> Some TargetDotNetFrameworkVersion.Version11
@@ -116,21 +121,28 @@ module internal MSBuildResolver =
| null -> []
| x -> [x]
| _ -> []
-#else
- // FX_ATLEAST_45 is not defined is required for step when we build compiler with proto compiler and this branch should not be hit
- assert false
- []
#endif
+#if CROSS_PLATFORM_COMPILER
+ // GetPathToDotNetFrameworkReferenceAssemblies is not available on Mono.
+ // We currently use the old values that the F# 2.0 compiler assumed.
+ // When the x-plat compiler is run on Mono this is ok since the asemblies are all in the framework folder
+ // When the x-plat compiler is run on Windows/.NET this will curently cause slightly divergent behaviour this directory
+ // may not be the same as the Microsoft compiler in all cases.
+ let DeriveTargetFrameworkDirectoriesFor40Plus(version) =
+ match version with
+ | Net40 -> ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.0"])
+ | Net45 -> ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.5"])
+ | Net451 -> ReplaceFrameworkVariables([@"{ReferenceAssemblies}\v4.5"])
+ | _ -> []
+#else
let DeriveTargetFrameworkDirectoriesFor40Plus(version) =
// starting with .Net 4.0, the runtime dirs (WindowsFramework) are never used by MSBuild RAR
let v =
match version with
| Net40 -> Some TargetDotNetFrameworkVersion.Version40
-#if FX_ATLEAST_45
| Net45 -> Some TargetDotNetFrameworkVersion.Version45
| Net451 -> Some TargetDotNetFrameworkVersion.Version451
-#endif
| _ -> assert false; None // unknown version - some parts in the code are not synced
match v with
| Some v ->
@@ -138,17 +150,18 @@ module internal MSBuildResolver =
| null -> []
| x -> [x]
| None -> []
+#endif
/// Determine the default "frameworkVersion" (which is passed into MSBuild resolve).
/// This code uses MSBuild to determine version of the highest installed framework.
let HighestInstalledNetFrameworkVersionMajorMinor() =
-#if FX_ATLEAST_45
+#if CROSS_PLATFORM_COMPILER
+ // Mono doesn't have GetPathToDotNetFramework
+ 4, Net40
+#else
if box (ToolLocationHelper.GetPathToDotNetFramework(TargetDotNetFrameworkVersion.Version451)) <> null then 4, Net451
elif box (ToolLocationHelper.GetPathToDotNetFramework(TargetDotNetFrameworkVersion.Version45)) <> null then 4, Net45
else 4, Net40 // version is 4.0 assumed since this code is running.
-#else
- // FX_ATLEAST_45 is not defined is required for step when we build compiler with proto compiler and this branch should not be hit
- 4, Net40
#endif
/// Derive the target framework directories.
@@ -329,7 +342,7 @@ module internal MSBuildResolver =
["{AssemblyFolders}"] @
[outputDirectory] @
["{GAC}"] @
- GetPathToDotNetFramework targetFrameworkVersion // use path to implementation assemblies as the last resort
+ GetPathToDotNetFrameworkForLastResortCompileTimeAssemblySearch targetFrameworkVersion // use path to implementation assemblies as the last resort
rar.SearchPaths <- searchPaths |> Array.ofList
diff --git a/src/fsharp/build.fs b/src/fsharp/build.fs
index 51a8d22..539ce37 100755
--- a/src/fsharp/build.fs
+++ b/src/fsharp/build.fs
@@ -1381,130 +1381,64 @@ let SanitizeFileName fileName implicitIncludeDir =
with _ ->
fileName
-type ErrorLocation =
- {
- Range : range
- File : string
- TextRepresentation : string
- IsEmpty : bool
- }
-
-type CanonicalInformation =
- {
- ErrorNumber : int
- Subcategory : string
- TextRepresentation : string
- }
-
-type DetailedIssueInfo =
- {
- Location : ErrorLocation option
- Canonical : CanonicalInformation
- Message : string
- }
-
-type ErrorOrWarning =
- | Short of bool * string
- | Long of bool * DetailedIssueInfo
-
-/// returns sequence that contains ErrorOrWarning for the given error + ErrorOrWarning for all related errors
-let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err:PhasedError) =
- let outputWhere (showFullPaths,errorStyle) m =
- if m = rangeStartup || m = rangeCmdArgs then
- { Range = m; TextRepresentation = ""; IsEmpty = true; File = "" }
+(* used by fsc.exe and fsi.exe, but not by VS *)
+let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn) os (err:PhasedError) =
+ let outputWhere (showFullPaths,errorStyle) os m =
+ if m = rangeStartup || m = rangeCmdArgs then ()
else
let file = m.FileName
let file = if showFullPaths then
Filename.fullpath implicitIncludeDir file
else
SanitizeFileName file implicitIncludeDir
- let text, m, file =
- match errorStyle with
- | ErrorStyle.EmacsErrors ->
- let file = file.Replace("\\","/")
- (sprintf "File \"%s\", line %d, characters %d-%d: " file m.StartLine m.StartColumn m.EndColumn), m, file
-
- // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output
- | ErrorStyle.DefaultErrors ->
- let file = file.Replace('/',System.IO.Path.DirectorySeparatorChar)
- let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) m.End
- (sprintf "%s(%d,%d): " file m.StartLine m.StartColumn), m, file
-
- // We may also want to change TestErrors to be 1-based
- | ErrorStyle.TestErrors ->
- let file = file.Replace("/","\\")
- let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) )
- sprintf "%s(%d,%d-%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file
-
- | ErrorStyle.GccErrors ->
- let file = file.Replace('/',System.IO.Path.DirectorySeparatorChar)
- sprintf "%s:%d:%d: " file m.StartLine (m.StartColumn + 1), m, file
-
- // Here, we want the complete range information so Project Systems can generate proper squiggles
- | ErrorStyle.VSErrors ->
- // Show prefix only for real files. Otherise, we just want a truncated error like:
- // parse error FS0031 : blah blah
- if m<>range0 && m<>rangeStartup && m<>rangeCmdArgs then
- let file = file.Replace("/","\\")
- let m = mkRange m.FileName (mkPos m.StartLine (m.StartColumn + 1)) (mkPos m.EndLine (m.EndColumn + 1) )
- sprintf "%s(%d,%d,%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file
- else
- "", m, file
- { Range = m; TextRepresentation = text; IsEmpty = false; File = file }
+ match errorStyle with
+ | ErrorStyle.EmacsErrors -> Printf.bprintf os "File \"%s\", line %d, characters %d-%d: " (file.Replace("\\","/")) m.StartLine m.StartColumn m.EndColumn
+ // We're adjusting the columns here to be 1-based - both for parity with C# and for MSBuild, which assumes 1-based columns for error output
+ | ErrorStyle.DefaultErrors -> Printf.bprintf os "%s(%d,%d): " (file.Replace('/',System.IO.Path.DirectorySeparatorChar)) m.StartLine (m.StartColumn + 1)
+ // We may also want to change TestErrors to be 1-based
+ | ErrorStyle.TestErrors -> Printf.bprintf os "%s(%d,%d-%d,%d): " (file.Replace("/","\\")) m.StartLine (m.StartColumn + 1) m.EndLine (m.EndColumn + 1)
+ | ErrorStyle.GccErrors -> Printf.bprintf os "%s:%d:%d: " (file.Replace('/',System.IO.Path.DirectorySeparatorChar)) m.StartLine (m.StartColumn + 1)
+
+ // Here, we want the complete range information so Project Systems can generate proper squiggles
+ | ErrorStyle.VSErrors ->
+ // Show prefix only for real files. Otherise, we just want a truncated error like:
+ // parse error FS0031 : blah blah
+ if m<>range0 && m<>rangeStartup && m<>rangeCmdArgs then
+ Printf.bprintf os "%s(%d,%d,%d,%d): " (file.Replace("/","\\")) m.StartLine (m.StartColumn + 1) m.EndLine (m.EndColumn + 1)
match err.Exception with
| ReportedError _ ->
dprintf "Unexpected ReportedError" (* this should actually never happen *)
- Seq.empty
| StopProcessing ->
dprintf "Unexpected StopProcessing" (* this should actually never happen *)
- Seq.empty
| _ ->
- let errors = ResizeArray()
let report err =
let OutputWhere(err) =
+ Printf.bprintf os "\n";
match RangeOfError err with
- | Some m -> Some(outputWhere (showFullPaths,errorStyle) m)
- | None -> None
+ | Some m -> outputWhere (showFullPaths,errorStyle) os m
+ | None -> ()
let OutputCanonicalInformation(err:PhasedError,subcategory, errorNumber) =
- let text =
- match errorStyle with
- // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness.
- | ErrorStyle.VSErrors -> sprintf "%s %s FS%04d: " subcategory (if warn then "warning" else "error") errorNumber;
- | _ -> sprintf "%s FS%04d: " (if warn then "warning" else "error") (GetErrorNumber err);
- { ErrorNumber = errorNumber; Subcategory = subcategory; TextRepresentation = text}
+ match errorStyle with
+ // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness.
+ | ErrorStyle.VSErrors -> Printf.bprintf os "%s %s FS%04d: " subcategory (if warn then "warning" else "error") errorNumber;
+ | _ -> Printf.bprintf os "%s FS%04d: " (if warn then "warning" else "error") (GetErrorNumber err);
let mainError,relatedErrors = SplitRelatedErrors err
- let where = OutputWhere(mainError)
- let canonical = OutputCanonicalInformation(mainError,err.Subcategory(),GetErrorNumber mainError)
- let message =
- let os = System.Text.StringBuilder()
- OutputPhasedError os mainError flattenErrors;
- os.ToString()
-
- let entry = { Location = where; Canonical = canonical; Message = message }
-
- errors.Add ( ErrorOrWarning.Long( not warn, entry ) )
-
+ OutputWhere(mainError)
+ OutputCanonicalInformation(mainError,err.Subcategory(),GetErrorNumber mainError)
+ OutputPhasedError os mainError flattenErrors;
+
let OutputRelatedError(err) =
match errorStyle with
// Give a canonical string when --vserror.
| ErrorStyle.VSErrors ->
- let relWhere = OutputWhere(mainError) // mainError?
- let relCanonical = OutputCanonicalInformation(err, err.Subcategory(),GetErrorNumber mainError) // Use main error for code
- let relMessage =
- let os = System.Text.StringBuilder()
- OutputPhasedError os err flattenErrors
- os.ToString()
-
- let entry = { Location = relWhere; Canonical = relCanonical; Message = relMessage}
- errors.Add( ErrorOrWarning.Long (not warn, entry) )
-
- | _ ->
- let os = System.Text.StringBuilder()
+ OutputWhere(mainError) // mainError?
+ OutputCanonicalInformation(err, err.Subcategory(),GetErrorNumber mainError) // Use main error for code
OutputPhasedError os err flattenErrors
- errors.Add( ErrorOrWarning.Short((not warn), os.ToString()) )
+ | _ -> Printf.bprintf os "\n"; OutputPhasedError os err flattenErrors
+
relatedErrors |> List.iter OutputRelatedError
@@ -1517,26 +1451,6 @@ let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorS
)
#endif
| x -> report x
-
- errors :> seq<_>
-
-/// used by fsc.exe and fsi.exe, but not by VS
-/// prints error and related errors to the specified StringBuilder
-let rec OutputErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn) os (err:PhasedError) =
-
- let errors = CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorStyle,warn, err)
- for e in errors do
- Printf.bprintf os "\n"
- match e with
- | Short(_, txt) ->
- os.Append txt |> ignore
- | Long(_, details) ->
- match details.Location with
- | Some l when not l.IsEmpty -> os.Append(l.TextRepresentation) |> ignore
- | _ -> ()
- os.Append( details.Canonical.TextRepresentation ) |> ignore
- os.Append( details.Message ) |> ignore
-
let OutputErrorOrWarningContext prefix fileLineFn os err =
match RangeOfError err with
| None -> ()
@@ -1559,17 +1473,21 @@ let OutputErrorOrWarningContext prefix fileLineFn os err =
let GetFSharpCoreLibraryName () = "FSharp.Core"
#if SILVERLIGHT
-let GetFSharpCoreReferenceUsedByCompiler() = typeof<int list>.Assembly.FullName
+let GetFSharpCoreReferenceUsedByCompiler() = GetFSharpCoreLibraryName()
let GetFsiLibraryName () = "FSharp.Compiler.Silverlight"
#else
type internal TypeInThisAssembly = class end
-let GetFSharpCoreReferenceUsedByCompiler() =
+let GetFSharpCoreReferenceUsedByCompiler(useMonoResolution) =
+ // On Mono, there is no good reference resolution
+ if useMonoResolution then
+ GetFSharpCoreLibraryName()+".dll"
+ else
let fsCoreName = GetFSharpCoreLibraryName()
typeof<TypeInThisAssembly>.Assembly.GetReferencedAssemblies()
|> Array.pick (fun name ->
if name.Name = fsCoreName then Some(name.ToString())
else None
- )
+ )
let GetFsiLibraryName () = "FSharp.Compiler.Interactive.Settings"
#endif
@@ -2431,7 +2349,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) =
match fileNameOpt with
| None ->
// if FSharp.Core was not provided explicitly - use version that was referenced by compiler
- AssemblyReference(range0, GetFSharpCoreReferenceUsedByCompiler()), None
+ AssemblyReference(range0, GetFSharpCoreReferenceUsedByCompiler(data.useMonoResolution)), None
| _ -> res
let primaryAssemblyCcuInitializer = data.primaryAssembly.GetSystemRuntimeInitializer(computeKnownDllReference >> fst)
@@ -3038,8 +2956,7 @@ type ErrorLoggerFilteringByScopedPragmas (checkFile,scopedPragmas,errorLogger:Er
Range.posGeq m.Start pragmaRange.Start))
| None -> true
if report then errorLogger.WarnSink(err);
- override x.ErrorNumbers = errorLogger.ErrorNumbers
- override x.WarningNumbers = errorLogger.WarningNumbers
+ override x.ErrorOrWarningNumbers = errorLogger.ErrorOrWarningNumbers
let GetErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) =
(ErrorLoggerFilteringByScopedPragmas(checkFile,scopedPragmas,errorLogger) :> ErrorLogger)
diff --git a/src/fsharp/build.fsi b/src/fsharp/build.fsi
index 370602f..f93cd92 100755
--- a/src/fsharp/build.fsi
+++ b/src/fsharp/build.fsi
@@ -94,34 +94,6 @@ val SanitizeFileName : filename:string -> implicitIncludeDir:string -> string
val OutputErrorOrWarning : implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * warning:bool -> StringBuilder -> PhasedError -> unit
val OutputErrorOrWarningContext : prefix:string -> fileLineFunction:(string -> int -> string) -> StringBuilder -> PhasedError -> unit
-type ErrorLocation =
- {
- Range : range
- File : string
- TextRepresentation : string
- IsEmpty : bool
- }
-
-type CanonicalInformation =
- {
- ErrorNumber : int
- Subcategory : string
- TextRepresentation : string
- }
-
-type DetailedIssueInfo =
- {
- Location : ErrorLocation option
- Canonical : CanonicalInformation
- Message : string
- }
-
-type ErrorOrWarning =
- | Short of bool * string
- | Long of bool * DetailedIssueInfo
-
-val CollectErrorOrWarning : implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * warning:bool * PhasedError -> seq<ErrorOrWarning>
-
//----------------------------------------------------------------------------
// Options and configuration
//--------------------------------------------------------------------------
diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs
index 316cac8..1a8b9bd 100755
--- a/src/fsharp/fsc.fs
+++ b/src/fsharp/fsc.fs
@@ -76,95 +76,26 @@ open Microsoft.FSharp.Compiler.ExtensionTyping
// Reporting - warnings, errors
//----------------------------------------------------------------------------
-type ErrorLoggerThatAccumulatesErrors private (implicitIncludeDir, showFullPaths, flatErrors, errorStyle, globalWarnLevel, specificWarnOn, specificWarnOff, specificWarnAsError, specificWarnAsWarn, globalWarnAsError) =
- inherit ErrorLogger("ErrorLoggerThatAccumulatesErrors")
- let messages = ResizeArray()
- let mutable errorsCount = 0
- new(tcConfigB : TcConfigBuilder) =
- ErrorLoggerThatAccumulatesErrors(
- tcConfigB.implicitIncludeDir,
- tcConfigB.showFullPaths,
- tcConfigB.flatErrors,
- tcConfigB.errorStyle,
- tcConfigB.globalWarnLevel,
- tcConfigB.specificWarnOn,
- tcConfigB.specificWarnOff,
- tcConfigB.specificWarnAsError,
- tcConfigB.specificWarnAsWarn,
- tcConfigB.globalWarnAsError
- )
- new(tcConfig : TcConfig) =
- ErrorLoggerThatAccumulatesErrors(
- tcConfig.implicitIncludeDir,
- tcConfig.showFullPaths,
- tcConfig.flatErrors,
- tcConfig.errorStyle,
- tcConfig.globalWarnLevel,
- tcConfig.specificWarnOn,
- tcConfig.specificWarnOff,
- tcConfig.specificWarnAsError,
- tcConfig.specificWarnAsWarn,
- tcConfig.globalWarnAsError
- )
- member this.ProcessMessage(err, isError) =
- let writer = new System.IO.StringWriter()
-
- let writeError err =
- writeViaBufferWithEnvironmentNewLines writer (OutputErrorOrWarning (implicitIncludeDir, showFullPaths, flatErrors, errorStyle, false)) err
-
- let isError =
- if isError then
- writeError err
- true
- else
- if (ReportWarningAsError globalWarnLevel specificWarnOff specificWarnOn specificWarnAsError specificWarnAsWarn globalWarnAsError err) then
- writeError err
- true
- elif ReportWarning globalWarnLevel specificWarnOff specificWarnOn err then
- writeViaBufferWithEnvironmentNewLines writer (OutputErrorOrWarning (implicitIncludeDir, showFullPaths, flatErrors, errorStyle, true)) err
- false
- else
- false // will not be used
- let text = writer.ToString()
- if text.Length <> 0 then Some (isError, text) else None
-
- member this.GetMessages() = List.ofSeq messages
- override this.ErrorSinkImpl(err) =
- errorsCount <- errorsCount + 1
- messages.Add(this.ProcessMessage(err, true).Value)
- override this.WarnSinkImpl(warn) =
- match this.ProcessMessage (warn, false) with
- | Some ((isError, _) as res) ->
- if isError then errorsCount <- errorsCount + 1
- messages.Add(res)
- | _ -> ()
-
- override this.ErrorCount = errorsCount
-
-[<AbstractClass>]
-type ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB:TcConfigBuilder, exiter : Exiter, caption) =
- inherit ErrorLogger(caption)
+/// Create an error logger that counts and prints errors
+let ErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exiter) =
let errors = ref 0
- let errorNumbers = ref []
- let warningNumbers = ref []
-
- abstract HandleIssue : tcConfigB : TcConfigBuilder * error : PhasedError * isWarning : bool -> unit
- abstract HandleTooManyErrors : text : string -> unit
+ let errorOrWarnings = ref []
- override x.ErrorCount = !errors
- override x.ErrorSinkImpl(err) =
+ { new ErrorLogger("ErrorLoggerThatQuitsAfterMaxErrors") with
+ member x.ErrorSinkImpl(err) =
if !errors >= tcConfigB.maxErrors then
- x.HandleTooManyErrors(FSComp.SR.fscTooManyErrors())
+ DoWithErrorColor true (fun () -> Printf.eprintfn "%s" (FSComp.SR.fscTooManyErrors()))
#if SQM_SUPPORT
- SqmLoggerWithConfigBuilder tcConfigB !errorNumbers !warningNumbers
+ SqmLoggerWithConfigBuilder tcConfigB !errorOrWarnings
#endif
exiter.Exit 1
- x.HandleIssue(tcConfigB, err, false)
+ DoWithErrorColor false (fun () ->
+ (writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,false)) err; stderr.WriteLine()));
incr errors
- errorNumbers := (GetErrorNumber err) :: !errorNumbers
+ errorOrWarnings := (GetErrorNumber err) :: !errorOrWarnings
match err.Exception with
| InternalError _
@@ -175,31 +106,18 @@ type ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB:TcConfigBuilder, exiter : Exit
| None -> System.Diagnostics.Debug.Assert(false,sprintf "Bug seen in compiler: %s" (err.ToString()))
| _ ->
()
-
- override x.WarnSinkImpl(err) =
- if (ReportWarningAsError tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn tcConfigB.specificWarnAsError tcConfigB.specificWarnAsWarn tcConfigB.globalWarnAsError err) then
- x.ErrorSink(err)
- elif ReportWarning tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn err then
- x.HandleIssue(tcConfigB, err, true)
- warningNumbers := (GetErrorNumber err) :: !warningNumbers
-
- override x.WarningNumbers = !warningNumbers
- override x.ErrorNumbers = !errorNumbers
-
-/// Create an error logger that counts and prints errors
-let ConsoleErrorLoggerThatQuitsAfterMaxErrors (tcConfigB:TcConfigBuilder, exiter : Exiter) : ErrorLogger =
- upcast {
- new ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter, "ConsoleErrorLoggerThatQuitsAfterMaxErrors") with
-
- member this.HandleTooManyErrors(text : string) =
- DoWithErrorColor true (fun () -> Printf.eprintfn "%s" text)
-
- member this.HandleIssue(tcConfigB, err, isWarning) =
- DoWithErrorColor isWarning (fun () ->
- (writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,isWarning)) err;
- stderr.WriteLine())
- );
- }
+ member x.WarnSinkImpl(err) =
+ DoWithErrorColor true (fun () ->
+ if (ReportWarningAsError tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn tcConfigB.specificWarnAsError tcConfigB.specificWarnAsWarn tcConfigB.globalWarnAsError err) then
+ x.ErrorSink(err)
+ elif ReportWarning tcConfigB.globalWarnLevel tcConfigB.specificWarnOff tcConfigB.specificWarnOn err then
+ writeViaBufferWithEnvironmentNewLines stderr (OutputErrorOrWarning (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,true)) err;
+ errorOrWarnings := (GetErrorNumber err) :: !errorOrWarnings
+ stderr.WriteLine())
+ override x.ErrorOrWarningNumbers = !errorOrWarnings
+ member x.ErrorCount = !errors }
+
+let ErrorLoggerInitial (tcConfigB:TcConfigBuilder, exiter : Exiter) = ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
// val TypeCheck : TcConfig * TcImports * TcGlobals * ErrorLogger * string * NiceNameGenerator * TypeChecker.TcEnv * Input list * Exiter ->
// TcState * TypeChecker.TopAttribs * Tast.TypedAssembly * TypeChecker.TcEnv
@@ -212,13 +130,13 @@ let TypeCheck (tcConfig,tcImports,tcGlobals,errorLogger:ErrorLogger,assemblyName
with e ->
errorRecovery e rangeStartup
#if SQM_SUPPORT
- SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorOrWarningNumbers
#endif
exiter.Exit 1
/// This error logger delays the messages it recieves. At the end, call ForwardDelayedErrorsAndWarnings
/// to send the held messages.
-type DelayAndForwardErrorLogger(exiter : Exiter, errorLoggerProvider : ErrorLoggerProvider) =
+type DelayAndForwardErrorLogger(exiter : Exiter) =
inherit ErrorLogger("DelayAndForwardErrorLogger")
let mapToErrorNumber items =
items |> Seq.map (fun (err,_) -> GetErrorNumber err) |> Seq.toList
@@ -238,16 +156,10 @@ type DelayAndForwardErrorLogger(exiter : Exiter, errorLoggerProvider : ErrorLogg
// Clear errors just reported. Keep errors count.
delayed.Clear()
member x.ForwardDelayedErrorsAndWarnings(tcConfigB:TcConfigBuilder) =
- let errorLogger = errorLoggerProvider.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
+ let errorLogger = ErrorLoggerInitial(tcConfigB, exiter)
x.ForwardDelayedErrorsAndWarnings(errorLogger)
member x.FullErrorCount = !errors
- override x.WarningNumbers = delayed |> Seq.filter(fun (_, flag) -> flag = false) |> mapToErrorNumber
- override x.ErrorNumbers = delayed |> Seq.filter(fun (_, flag) -> flag = true) |> mapToErrorNumber
-
-and [<AbstractClass>]
- ErrorLoggerProvider() =
- member this.CreateDelayAndForwardLogger(exiter) = DelayAndForwardErrorLogger(exiter, this)
- abstract CreateErrorLoggerThatQuitsAfterMaxErrors : tcConfigBuilder : TcConfigBuilder * exiter : Exiter -> ErrorLogger
+ override x.ErrorOrWarningNumbers = delayed |> Seq.map (fun (err,_) -> GetErrorNumber err) |> Seq.toList
/// Check for .fsx and, if present, compute the load closure for of #loaded files.
let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexResourceManager) =
@@ -291,23 +203,9 @@ let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexR
let abortOnError (errorLogger:ErrorLogger, _tcConfig:TcConfig, exiter : Exiter) =
if errorLogger.ErrorCount > 0 then
#if SQM_SUPPORT
- SqmLoggerWithConfig _tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+ SqmLoggerWithConfig _tcConfig errorLogger.ErrorOrWarningNumbers
#endif
- exiter.Exit 1
-
-type DelayedDisposables() =
- let items = Stack<System.IDisposable>()
- member this.Register(i) = items.Push i
- interface System.IDisposable with
- member this.Dispose() =
- let l = List.ofSeq items
- items.Clear()
- for i in l do
- try i.Dispose() with _ -> ()
-
-type DefaultLoggerProvider() =
- inherit ErrorLoggerProvider()
- override this.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter) = ConsoleErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter)
+ exiter.Exit 1
// The project system needs to be able to somehow crack open assemblies to look for type providers in order to pop up the security dialog when necessary when a user does 'Build'.
// Rather than have the PS re-code that logic, it re-uses the existing code in the very front end of the compiler that parses the command-line and imports the referenced assemblies.
@@ -321,9 +219,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
setProcessThreadLocals : TcConfigBuilder -> unit,
displayBannerIfNeeded : TcConfigBuilder -> unit,
optimizeForMemory : bool,
- exiter : Exiter,
- errorLoggerProvider : ErrorLoggerProvider,
- disposables : DelayedDisposables)
+ exiter : Exiter)
: TcGlobals * TcImports * TcImports * Tast.CcuThunk * Tast.TypedAssembly * TypeChecker.TopAttribs * TcConfig * string * string option * string * ErrorLogger
=
@@ -335,7 +231,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
SetTailcallSwitch tcConfigB On
// Now install a delayed logger to hold all errors from flags until after all flags have been parsed (for example, --vserrors)
- let delayForFlagsLogger = errorLoggerProvider.CreateDelayAndForwardLogger(exiter)// DelayAndForwardErrorLogger(exiter)
+ let delayForFlagsLogger = DelayAndForwardErrorLogger(exiter)
let _unwindEL_1 = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayForFlagsLogger)
// Share intern'd strings across all lexing/parsing
@@ -386,7 +282,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
e ->
errorRecovery e rangeStartup
#if SQM_SUPPORT
- SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers
#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
@@ -402,7 +298,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
with e ->
errorRecovery e rangeStartup
#if SQM_SUPPORT
- SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers
#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
@@ -410,7 +306,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
// DecideNames may give "no inputs" error. Abort on error at this point. bug://3911
if not tcConfigB.continueAfterParseFailure && delayForFlagsLogger.FullErrorCount > 0 then
#if SQM_SUPPORT
- SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers
#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
@@ -421,12 +317,12 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
TcConfig.Create(tcConfigB,validate=false)
with e ->
#if SQM_SUPPORT
- SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorNumbers delayForFlagsLogger.WarningNumbers
+ SqmLoggerWithConfigBuilder tcConfigB delayForFlagsLogger.ErrorOrWarningNumbers
#endif
delayForFlagsLogger.ForwardDelayedErrorsAndWarnings(tcConfigB)
exiter.Exit 1
- let errorLogger = errorLoggerProvider.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
+ let errorLogger = ErrorLoggerThatQuitsAfterMaxErrors(tcConfigB, exiter)
// Install the global error logger and never remove it. This logger does have all command-line flags considered.
let _unwindEL_2 = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger)
@@ -449,7 +345,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
ensureReactive=false,
errorLogger=errorLogger,
keepGeneratedTypedAssembly=true)
- let tcState,topAttribs,typedAssembly,_tcEnv,tcImports,tcGlobals,tcConfig = builder.TypeCheck()
+ let tcState,topAttribs,typedAssembly,_tcEnv,tcImports,tcGlobals,tcConfig = builder.TypeCheck()
tcGlobals,tcImports,tcImports,tcState.Ccu,typedAssembly,topAttribs,tcConfig
else
@@ -459,9 +355,6 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
let sysRes,otherRes,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig)
let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes)
- // register framework tcImports to be disposed in future
- disposables.Register frameworkTcImports
-
// step - parse sourceFiles
ReportTime tcConfig "Parse inputs"
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse)
@@ -480,7 +373,7 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
with e ->
errorRecoveryNoRange e
#if SQM_SUPPORT
- SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorOrWarningNumbers
#endif
exiter.Exit 1
@@ -499,9 +392,6 @@ let getTcImportsFromCommandLine(displayPSTypeProviderSecurityDialogBlockingUI :
let tcImports = TcImports.BuildNonFrameworkTcImports(displayPSTypeProviderSecurityDialogBlockingUI,tcConfigP,tcGlobals,frameworkTcImports,otherRes,knownUnresolved)
tcGlobals,tcImports
- // register tcImports to be disposed in future
- disposables.Register tcImports
-
if not tcConfig.continueAfterParseFailure then
abortOnError(errorLogger, tcConfig, exiter)
@@ -531,8 +421,6 @@ let runFromCommandLineToImportingAssemblies(displayPSTypeProviderSecurityDialogB
directoryBuildingFrom : string,
exiter : Exiter) =
- use d = new DelayedDisposables() // ensure that any resources that can be allocated in getTcImportsFromCommandLine will be correctly disposed
-
let tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger =
getTcImportsFromCommandLine(Some displayPSTypeProviderSecurityDialogBlockingUI, argv, defaultFSharpBinariesDir, directoryBuildingFrom, None, (fun _ -> ()),
(fun tcConfigB ->
@@ -546,9 +434,7 @@ let runFromCommandLineToImportingAssemblies(displayPSTypeProviderSecurityDialogB
tcConfigB.framework<-false
),
true, // optimizeForMemory - want small memory footprint in VS
- exiter,
- DefaultLoggerProvider(), // this function always use default set of loggers
- d)
+ exiter)
// we don't care about the result, we just called 'getTcImportsFromCommandLine' to have the effect of popping up the dialog if the TP is unknown
ignore(tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger)
@@ -753,7 +639,7 @@ let EncodeInterfaceData(tcConfig:TcConfig,tcGlobals,exportRemapping,_errorLogger
with e ->
errorRecoveryNoRange e
#if SQM_SUPPORT
- SqmLoggerWithConfig tcConfig _errorLogger.ErrorNumbers _errorLogger.WarningNumbers
+ SqmLoggerWithConfig tcConfig _errorLogger.ErrorOrWarningNumbers
#endif
exiter.Exit 1
@@ -1829,7 +1715,7 @@ module FileWriter =
with e ->
errorRecoveryNoRange e
#if SQM_SUPPORT
- SqmLoggerWithConfig tcConfig _errorLogger.ErrorNumbers _errorLogger.WarningNumbers
+ SqmLoggerWithConfig tcConfig _errorLogger.ErrorOrWarningNumbers
#endif
exiter.Exit 1
@@ -1888,13 +1774,7 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig) tcGlobals topAttrs =
| None -> tcConfig.container
SigningInfo (delaysign,signer,container)
-
-/// Checks if specified file name is absolute path. If yes - returns the name as is, otherwise makes full path using tcConfig.implicitIncludeDir as base.
-let expandFileNameIfNeeded (tcConfig : TcConfig) name =
- if FileSystem.IsPathRootedShim name then name
- else
- System.IO.Path.Combine(tcConfig.implicitIncludeDir, name)
-
+
//----------------------------------------------------------------------------
// main - split up to make sure that we can GC the
// dead data at the end of each phase. We explicitly communicate arguments
@@ -1904,7 +1784,7 @@ let expandFileNameIfNeeded (tcConfig : TcConfig) name =
[<NoEquality; NoComparison>]
type Args<'a> = Args of 'a
-let main0(argv,bannerAlreadyPrinted,exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DelayedDisposables) =
+let main1(argv,bannerAlreadyPrinted,exiter:Exiter) =
// See Bug 735819
let lcidFromCodePage =
@@ -1945,18 +1825,9 @@ let main0(argv,bannerAlreadyPrinted,exiter:Exiter, errorLoggerProvider : ErrorLo
Microsoft.FSharp.Compiler.Fscopts.DisplayBannerText tcConfigB
),
false, // optimizeForMemory - fsc.exe can use as much memory as it likes to try to compile as fast as possible
- exiter,
- errorLoggerProvider,
- disposables
-
+ exiter
)
- tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger, exiter
-
-// TcGlobals * TcImports * TcImports * CcuThunk * TypedAssembly * TopAttribs * TcConfig * string * string * string* ErrorLogger* Exiter
-let main1(tcGlobals,tcImports : TcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig : TcConfig, outfile,pdbfile,assemblyName,errorLogger, exiter : Exiter) =
-
-
if tcConfig.typeCheckOnly then exiter.Exit 0
use unwindPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.CodeGen)
@@ -1993,10 +1864,7 @@ let main1(tcGlobals,tcImports : TcImports,frameworkTcImports,generatedCcu,typedA
if tcConfig.xmlDocOutputFile.IsSome then
XmlDocWriter.computeXmlDocSigs (tcGlobals,generatedCcu)
ReportTime tcConfig ("Write XML docs");
- tcConfig.xmlDocOutputFile |> Option.iter ( fun xmlFile ->
- let xmlFile = expandFileNameIfNeeded tcConfig xmlFile
- XmlDocWriter.writeXmlDoc (assemblyName,generatedCcu,xmlFile)
- )
+ tcConfig.xmlDocOutputFile |> Option.iter (fun xmlFile -> XmlDocWriter.writeXmlDoc (assemblyName,generatedCcu,xmlFile))
ReportTime tcConfig ("Write HTML docs");
end;
@@ -2132,7 +2000,7 @@ let main3(Args(tcConfig,errorLogger:ErrorLogger,staticLinker,ilGlobals,ilxMainMo
with e ->
errorRecoveryNoRange e
#if SQM_SUPPORT
- SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorOrWarningNumbers
#endif
exiter.Exit 1
@@ -2143,9 +2011,7 @@ let main3(Args(tcConfig,errorLogger:ErrorLogger,staticLinker,ilGlobals,ilxMainMo
let main4(Args(tcConfig,errorLogger:ErrorLogger,ilGlobals,ilxMainModule,outfile,pdbfile,signingInfo,exiter)) =
ReportTime tcConfig "Write .NET Binary"
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Output)
- let outfile = expandFileNameIfNeeded tcConfig outfile
-
- let pdbfile = pdbfile |> Option.map ((expandFileNameIfNeeded tcConfig) >> FileSystem.GetFullPathShim)
+ let pdbfile = pdbfile |> Option.map Path.GetFullPath
match dynamicAssemblyCreator with
| None -> FileWriter.EmitIL (tcConfig,ilGlobals,errorLogger,outfile,pdbfile,ilxMainModule,signingInfo,exiter)
| Some da -> da (tcConfig,ilGlobals,errorLogger,outfile,pdbfile,ilxMainModule,signingInfo);
@@ -2161,355 +2027,20 @@ let main4(Args(tcConfig,errorLogger:ErrorLogger,ilGlobals,ilxMainModule,outfile,
dprintfn "%s" a.FullName
#if SQM_SUPPORT
- SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
+ SqmLoggerWithConfig tcConfig errorLogger.ErrorOrWarningNumbers
#endif
#endif
ReportTime tcConfig "Exiting"
-let compile arg =
- main1 arg
+let mainCompile (argv,bannerAlreadyPrinted,exiter:Exiter) =
+ // Don's note: "GC of intermediate data is really, really important here"
+ main1 (argv,bannerAlreadyPrinted,exiter)
|> main2
|> main2b
|> main2c
|> main3
|> main4
-let typecheckAndCompile(argv,bannerAlreadyPrinted,exiter:Exiter, errorLoggerProvider) =
- // Don's note: "GC of intermediate data is really, really important here"
- use d = new DelayedDisposables()
- main0(argv,bannerAlreadyPrinted,exiter, errorLoggerProvider, d)
- |> compile
-
-let mainCompile (argv,bannerAlreadyPrinted,exiter:Exiter) =
- typecheckAndCompile(argv, bannerAlreadyPrinted, exiter, DefaultLoggerProvider())
-
-type CompilationOutput =
- {
- Errors : seq<ErrorOrWarning>
- Warnings : seq<ErrorOrWarning>
- }
-
-type InProcCompiler() =
- member this.Compile(argv) =
-
- let errors = ResizeArray()
- let warnings = ResizeArray()
-
- let loggerProvider = {
- new ErrorLoggerProvider() with
- member log.CreateErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter) =
- upcast {
- new ErrorLoggerThatQuitsAfterMaxErrors(tcConfigBuilder, exiter, "InProcCompilerErrorLoggerThatQuitsAfterMaxErrors") with
- member this.HandleTooManyErrors(text) = warnings.Add(ErrorOrWarning.Short(false, text))
- member this.HandleIssue(tcConfigBuilder, err, isWarning) =
- let errs = CollectErrorOrWarning(tcConfigBuilder.implicitIncludeDir, tcConfigBuilder.showFullPaths, tcConfigBuilder.flatErrors, tcConfigBuilder.errorStyle, isWarning, err)
- let container = if isWarning then warnings else errors
- container.AddRange(errs)
- }
- }
- let exitCode = ref 0
- let exiter = {
- new Exiter with
- member this.Exit n = exitCode := n; raise StopProcessing
- }
- try
- typecheckAndCompile(argv, false, exiter, loggerProvider)
- with
- | StopProcessing -> ()
- | ReportedError _ | WrappedError(ReportedError _,_) ->
- exitCode := 1
- ()
-
- let output = { Warnings = warnings; Errors = errors}
- !exitCode = 0, output
-
-/// Collect the output from the stdout and stderr streams, character by character,
-/// recording the console color used along the way.
-type OutputCollector() =
- let output = ResizeArray()
- let outWriter isOut =
- { new TextWriter() with
- member x.Write(c:char) =
- lock output (fun () ->
-#if SILVERLIGHT
- output.Add (isOut, None ,c))
-#else
- output.Add (isOut, (try Some System.Console.ForegroundColor with _ -> None) ,c))
-#endif
- member x.Encoding = Encoding.UTF8 }
-#if FX_ATLEAST_SILVERLIGHT_50
-#else
- do ignore outWriter
- do System.Console.SetOut (outWriter true)
- do System.Console.SetError (outWriter false)
-#endif
- member x.GetTextAndClear() = lock output (fun () -> let res = output.ToArray() in output.Clear(); res)
-
-#if SILVERLIGHT
-#else
-/// Implement the optional resident compilation service
-module FSharpResidentCompiler =
-
- open System
- open System.Diagnostics
- open System.Runtime.Remoting.Channels
- open System.Runtime.Remoting
- open System.Runtime.Remoting.Lifetime
-
- /// The compilation server, which runs in the server process. Accessed by clients using .NET remoting.
- type FSharpCompilationServer(exiter:Exiter) =
- inherit MarshalByRefObject()
-
- static let onWindows =
- match System.Environment.OSVersion.Platform with
- | PlatformID.Win32NT | PlatformID.Win32S | PlatformID.Win32Windows | PlatformID.WinCE -> true
- | _ -> false
-
- // The channel/socket name is qualified by the user name (and domain on windows)
- static let domainName = if onWindows then Environment.GetEnvironmentVariable "USERDOMAIN" else ""
- static let userName = Environment.GetEnvironmentVariable (if onWindows then "USERNAME" else "USER")
- // Use different base channel names on mono and CLR as a CLR remoting process can't talk
- // to a mono server
- static let baseChannelName = if runningOnMono then "FSCChannelMono" else "FSCChannel"
- static let channelName = baseChannelName + "_" + domainName + "_" + userName
- static let serverName = if runningOnMono then "FSCServerMono" else "FSCSever"
- static let mutable serverExists = true
-
- let outputCollector = new OutputCollector()
-
- // This background agent ensures all compilation requests sent to the server are serialized
- let agent = MailboxProcessor<_>.Start(fun inbox ->
- async {
- while true do
- let! (pwd,argv, reply: AsyncReplyChannel<_>) = inbox.Receive()
- if !progress then printfn "server agent: got compilation request, argv = %A" argv
- let exitCode =
- try
- Environment.CurrentDirectory <- pwd
- mainCompile (argv, true, exiter);
- if !progress then printfn "server: finished compilation request, argv = %A" argv
- 0
- with e ->
- if !progress then printfn "server: finished compilation request with errors, argv = %A, e = %s" argv (e.ToString())
- stopProcessingRecovery e range0
- 1
- let output = outputCollector.GetTextAndClear()
- if !progress then printfn "ouput: %A" output
- if !progress then printfn "sending reply..."
- reply.Reply(output, exitCode)
- if !progress then printfn "collecting..."
- GC.Collect(3)
- if !progress then printfn "considering exit..."
- // Exit the server if there are no outstanding requests and the
- // current memory usage after collection is over 200MB
- if inbox.CurrentQueueLength = 0 && GC.GetTotalMemory(true) > 200L * 1024L * 1024L then
- Environment.Exit 0
- })
-
- member x.Run() =
- while serverExists do
- if !progress then printfn "server: startup thread sleeping..."
- System.Threading.Thread.Sleep 1000
-
- abstract Ping : unit -> string
- abstract Compile : string * string[] -> (bool * System.ConsoleColor option * char) [] * int
- default x.Ping() = "ping"
- default x.Compile (pwd,argv) =
- if !progress then printfn "server: got compilation request, (pwd, argv) = %A" (pwd, argv)
- let res = agent.PostAndReply(fun reply -> (pwd,argv,reply))
- if !progress then printfn "server: got response, response = %A" res
- res
-
- override x.Finalize() =
- serverExists <- false
-
- // This is called on the server object by .NET remoting to initialize the lifetime characteristics
- // of the server object.
- override x.InitializeLifetimeService() =
- let lease = (base.InitializeLifetimeService() :?> ILease)
- if (lease.CurrentState = LeaseState.Initial) then
- lease.InitialLeaseTime <- TimeSpan.FromDays(1.0);
- lease.SponsorshipTimeout <- TimeSpan.FromMinutes(2.0);
- lease.RenewOnCallTime <- TimeSpan.FromDays(1.0);
- box lease
-
- static member RunServer(exiter:Exiter) =
- progress := !progress || condition "FSHARP_SERVER_PROGRESS"
- if !progress then printfn "server: initializing server object"
- let server = new FSharpCompilationServer(exiter)
- let chan = new Ipc.IpcChannel(channelName)
- ChannelServices.RegisterChannel(chan,false);
- RemotingServices.Marshal(server,serverName) |> ignore
-
- // On Unix, the file permissions of the implicit socket need to be set correctly to make this
- // private to the user.
- if runningOnMono then
- try
- let monoPosix = System.Reflection.Assembly.Load("Mono.Posix, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756")
- let monoUnixFileInfo = monoPosix.GetType("Mono.Unix.UnixFileSystemInfo")
- let socketName = Path.Combine(FileSystem.GetTempPathShim(), channelName)
- let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box socketName |],System.Globalization.CultureInfo.InvariantCulture)
- // Add 0x00000180 (UserReadWriteExecute) to the access permissions on Unix
- monoUnixFileInfo.InvokeMember("set_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| box 0x00000180 |],System.Globalization.CultureInfo.InvariantCulture) |> ignore
-#if DEBUG
- if !progress then printfn "server: good, set permissions on socket name '%s'" socketName
- let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box socketName |],System.Globalization.CultureInfo.InvariantCulture)
- let currPermissions = monoUnixFileInfo.InvokeMember("get_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| |],System.Globalization.CultureInfo.InvariantCulture) |> unbox<int>
- if !progress then printfn "server: currPermissions = '%o' (octal)" currPermissions
-#endif
- with e ->
-#if DEBUG
- printfn "server: failed to set permissions on socket, perhaps on windows? Is is not needed there."
-#endif
- ()
- // Fail silently
- server.Run()
-
- static member private ConnectToServer() =
- Activator.GetObject(typeof<FSharpCompilationServer>,"ipc://" + channelName + "/" + serverName)
- :?> FSharpCompilationServer
-
- static member TryCompileUsingServer(fscServerExe,argv) =
- // Enable these lines to write a log file, e.g. when running under xbuild
- //let os = System.IO.File.CreateText "/tmp/fsc-client-log"
- //let printfn fmt = Printf.kfprintf (fun () -> fprintfn os ""; os.Flush()) os fmt
- progress := !progress || condition "FSHARP_SERVER_PROGRESS"
- let pwd = System.Environment.CurrentDirectory
- let clientOpt =
- if !progress then printfn "client: creating client"
- // Detect the absence of the channel via the exception. Probably not the best way.
- // Different exceptions get thrown here on Mono and Windows.
- let client = FSharpCompilationServer.ConnectToServer()
- try
- if !progress then printfn "client: attempting to connect to existing service (1)"
- client.Ping() |> ignore
- if !progress then printfn "client: connected to existing service"
- Some client
- with _ ->
- if !progress then printfn "client: error while creating client, starting client instead"
- let procInfo =
- if runningOnMono then
- let shellName, useShellExecute =
- match System.Environment.GetEnvironmentVariable("FSC_MONO") with
- | null ->
- if onWindows then
- // e.g. "C:\Program Files\Mono-2.6.1\lib\mono\2.0\mscorlib.dll" --> "C:\Program Files\Mono-2.6.1\bin\mono.exe"
- Path.Combine(Path.GetDirectoryName (typeof<Object>.Assembly.Location), @"..\..\..\bin\mono.exe"), false
- else
- "mono-sgen", true
- | path -> path, true
-
- ProcessStartInfo(FileName = shellName,
- Arguments = fscServerExe + " /server",
- CreateNoWindow = true,
- UseShellExecute = useShellExecute)
- else
- ProcessStartInfo(FileName=fscServerExe,
- Arguments = "/server",
- CreateNoWindow = true,
- UseShellExecute = false)
-
- let cmdProcess = new Process(StartInfo=procInfo)
-
- //let exitE = cmdProcess.Exited |> Observable.map (fun x -> x)
-
- cmdProcess.Start() |> ignore
- //exitE.Add(fun _ -> if !progress then eprintfn "client: the server has exited")
- cmdProcess.EnableRaisingEvents <- true;
-
- // Create the client proxy and attempt to connect to the server
- let rec tryAcccesServer nRemaining =
- if !progress then printfn "client: trying to access server, nRemaining = '%d'" nRemaining
- if nRemaining = 0 then
- // Failed to connect to server, give up
- None
- else
- try
- if !progress then printfn "client: attempting to connect to existing service (2)"
- client.Ping() |> ignore
- if !progress then printfn "client: connected to existing service"
- Some client
- // Detect the absence of the channel via the exception. Probably not the best way.
- // Different exceptions get thrown here on Mono and Windows.
- with _ (* System.Runtime.Remoting.RemotingException *) ->
- // Sleep a bit
- System.Threading.Thread.Sleep 50
- tryAcccesServer (nRemaining - 1)
-
- tryAcccesServer 20
-
- match clientOpt with
- | Some client ->
- if !progress then printfn "client: calling client.Compile(%A)" argv
- // Install the global error logger and never remove it. This logger does have all command-line flags considered.
- try
- let (output, exitCode) =
- try client.Compile (pwd, argv)
- with e ->
- printfn "server error: %s" (e.ToString())
- raise (Error (FSComp.SR.fscRemotingError(), rangeStartup))
-
- if !progress then printfn "client: returned from client.Compile(%A), res = %d" argv exitCode
- use holder =
- try let originalConsoleColor = Console.ForegroundColor
- { new System.IDisposable with member x.Dispose() = Console.ForegroundColor <- originalConsoleColor }
- with _ -> null
- let mutable prevConsoleColor = try Console.ForegroundColor with _ -> ConsoleColor.Black
- for (isOut, consoleColorOpt, c:char) in output do
- try match consoleColorOpt with
- | Some consoleColor ->
- if prevConsoleColor <> consoleColor then
- Console.ForegroundColor <- consoleColor;
- | None -> ()
- with _ -> ()
- c |> (if isOut then System.Console.Out.Write else System.Console.Error.Write)
- Some exitCode
- with err ->
- let sb = System.Text.StringBuilder()
- OutputErrorOrWarning (pwd,true,false,ErrorStyle.DefaultErrors,true) sb (PhasedError.Create(err,BuildPhase.Compile))
- eprintfn "%s" (sb.ToString())
- // We continue on and compile in-process - the server appears to have died half way through.
- None
- | None ->
- None
-
-
-let main (fscServerExe, argv) =
- let inline hasArgument name args =
- args |> Array.exists (fun x -> x = ("--" + name) || x = ("/" + name))
- let inline stripArgument name args =
- args |> Array.filter (fun x -> x <> ("--" + name) && x <> ("/" + name))
-
- // Check for --pause as the very first step so that a compiler can be attached here.
- if hasArgument "pause" argv then
- System.Console.WriteLine("Press any key to continue...")
- System.Console.ReadKey() |> ignore
-
- if runningOnMono && hasArgument "resident" argv then
- let argv = stripArgument "resident" argv
-
- if not (hasArgument "nologo" argv) then
- printfn "%s" (FSComp.SR.buildProductName(FSharpEnvironment.FSharpTeamVersionNumber))
- printfn "%s" (FSComp.SR.optsCopyright())
-
- let exitCodeOpt = FSharpResidentCompiler.FSharpCompilationServer.TryCompileUsingServer (fscServerExe, argv)
- match exitCodeOpt with
- | Some exitCode -> exitCode
- | None ->
- mainCompile (argv, true, QuitProcessExiter)
- 0
-
- elif runningOnMono && hasArgument "server" argv then
- // Install the right exiter so we can catch "StopProcessing" without exiting the server
- let exiter = { new Exiter with member x.Exit n = raise StopProcessing }
- FSharpResidentCompiler.FSharpCompilationServer.RunServer(exiter)
- 0
-
- else
- mainCompile (argv, false, QuitProcessExiter)
- 0
-
-#endif // SILVERLIGHT
#endif // NO_COMPILER_BACKEND
diff --git a/src/fsharp/fsc.fsi b/src/fsharp/fsc.fsi
index 4a3b017..ed04f12 100755
--- a/src/fsharp/fsc.fsi
+++ b/src/fsharp/fsc.fsi
@@ -2,37 +2,13 @@ module internal Microsoft.FSharp.Compiler.Driver
open Microsoft.FSharp.Compiler.ErrorLogger
open Microsoft.FSharp.Compiler.Build
-open Microsoft.FSharp.Compiler.Env
-open Microsoft.FSharp.Compiler.Tast
-open Microsoft.FSharp.Compiler.TypeChecker
/// the F# project system calls this to pop up type provider security dialog if needed
val internal runFromCommandLineToImportingAssemblies : (string -> unit) * string[] * string * string * Exiter -> unit
#if NO_COMPILER_BACKEND
#else
-
-[<Class>]
-type ErrorLoggerThatAccumulatesErrors =
- inherit ErrorLogger
- new : TcConfigBuilder -> ErrorLoggerThatAccumulatesErrors
- new : TcConfig -> ErrorLoggerThatAccumulatesErrors
- member GetMessages : unit -> (bool * string) list
- member ProcessMessage : PhasedError * bool -> (bool * string) option
-
-
/// fsc.exe calls this
-val compile : TcGlobals * TcImports * TcImports * CcuThunk * TypedAssembly * TopAttribs * TcConfig * string * string option * string* ErrorLogger* Exiter -> unit
val mainCompile : argv : string[] * bannerAlreadyPrinted : bool * exiter : Exiter -> unit
-type CompilationOutput =
- {
- Errors : seq<ErrorOrWarning>
- Warnings : seq<ErrorOrWarning>
- }
-
-type InProcCompiler =
- new : unit -> InProcCompiler
- member Compile : args : string[] -> bool * CompilationOutput
-
#endif
diff --git a/src/fsharp/fscmain.fs b/src/fsharp/fscmain.fs
index 8753b61..b542174 100755
--- a/src/fsharp/fscmain.fs
+++ b/src/fsharp/fscmain.fs
@@ -32,6 +32,282 @@ type TypeInThisAssembly() = member x.Dummy = 1
[<Dependency("FSharp.Compiler",LoadHint.Always)>]
do ()
+/// Collect the output from the stdout and stderr streams, character by character,
+/// recording the console color used along the way.
+type OutputCollector() =
+ let output = ResizeArray()
+ let outWriter isOut =
+ { new TextWriter() with
+ member x.Write(c:char) =
+ lock output (fun () ->
+ output.Add (isOut, (try Some System.Console.ForegroundColor with _ -> None) ,c))
+ member x.Encoding = Encoding.UTF8 }
+ member x.GetTextAndClear() = lock output (fun () -> let res = output.ToArray() in output.Clear(); res)
+
+/// Implement the optional resident compilation service
+module FSharpResidentCompiler =
+
+ open System
+ open System.Diagnostics
+ open System.Runtime.Remoting.Channels
+ open System.Runtime.Remoting
+ open System.Runtime.Remoting.Lifetime
+
+ /// The compilation server, which runs in the server process. Accessed by clients using .NET remoting.
+ type FSharpCompilationServer(exiter:Exiter) =
+ inherit MarshalByRefObject()
+
+ static let onWindows =
+ match System.Environment.OSVersion.Platform with
+ | PlatformID.Win32NT | PlatformID.Win32S | PlatformID.Win32Windows | PlatformID.WinCE -> true
+ | _ -> false
+
+ // The channel/socket name is qualified by the user name (and domain on windows)
+ static let domainName = if onWindows then Environment.GetEnvironmentVariable "USERDOMAIN" else ""
+ static let userName = Environment.GetEnvironmentVariable (if onWindows then "USERNAME" else "USER")
+ // Use different base channel names on mono and CLR as a CLR remoting process can't talk
+ // to a mono server
+ static let baseChannelName = if runningOnMono then "FSCChannelMono" else "FSCChannel"
+ static let channelName = baseChannelName + "_" + domainName + "_" + userName
+ static let serverName = if runningOnMono then "FSCServerMono" else "FSCSever"
+ static let mutable serverExists = true
+
+ let outputCollector = new OutputCollector()
+
+ // This background agent ensures all compilation requests sent to the server are serialized
+ let agent = MailboxProcessor<_>.Start(fun inbox ->
+ async {
+ while true do
+ let! (pwd,argv, reply: AsyncReplyChannel<_>) = inbox.Receive()
+ if !progress then printfn "server agent: got compilation request, argv = %A" argv
+ let exitCode =
+ try
+ Environment.CurrentDirectory <- pwd
+ mainCompile (argv, true, exiter);
+ if !progress then printfn "server: finished compilation request, argv = %A" argv
+ 0
+ with e ->
+ if !progress then printfn "server: finished compilation request with errors, argv = %A, e = %s" argv (e.ToString())
+ stopProcessingRecovery e range0
+ 1
+ let output = outputCollector.GetTextAndClear()
+ if !progress then printfn "ouput: %A" output
+ if !progress then printfn "sending reply..."
+ reply.Reply(output, exitCode)
+ if !progress then printfn "collecting..."
+ GC.Collect(3)
+ if !progress then printfn "considering exit..."
+ // Exit the server if there are no outstanding requests and the
+ // current memory usage after collection is over 200MB
+ if inbox.CurrentQueueLength = 0 && GC.GetTotalMemory(true) > 200L * 1024L * 1024L then
+ Environment.Exit 0
+ })
+
+ member x.Run() =
+ while serverExists do
+ if !progress then printfn "server: startup thread sleeping..."
+ System.Threading.Thread.Sleep 1000
+
+ abstract Ping : unit -> string
+ abstract Compile : string * string[] -> (bool * System.ConsoleColor option * char) [] * int
+ default x.Ping() = "ping"
+ default x.Compile (pwd,argv) =
+ if !progress then printfn "server: got compilation request, (pwd, argv) = %A" (pwd, argv)
+ let res = agent.PostAndReply(fun reply -> (pwd,argv,reply))
+ if !progress then printfn "server: got response, response = %A" res
+ res
+
+ override x.Finalize() =
+ serverExists <- false
+
+ // This is called on the server object by .NET remoting to initialize the lifetime characteristics
+ // of the server object.
+ override x.InitializeLifetimeService() =
+ let lease = (base.InitializeLifetimeService() :?> ILease)
+ if (lease.CurrentState = LeaseState.Initial) then
+ lease.InitialLeaseTime <- TimeSpan.FromDays(1.0);
+ lease.SponsorshipTimeout <- TimeSpan.FromMinutes(2.0);
+ lease.RenewOnCallTime <- TimeSpan.FromDays(1.0);
+ box lease
+
+ static member RunServer(exiter:Exiter) =
+ progress := !progress || condition "FSHARP_SERVER_PROGRESS"
+ if !progress then printfn "server: initializing server object"
+ let server = new FSharpCompilationServer(exiter)
+ let chan = new Ipc.IpcChannel(channelName)
+ ChannelServices.RegisterChannel(chan,false);
+ RemotingServices.Marshal(server,serverName) |> ignore
+
+ // On Unix, the file permissions of the implicit socket need to be set correctly to make this
+ // private to the user.
+ if runningOnMono then
+ try
+ let monoPosix = System.Reflection.Assembly.Load("Mono.Posix, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756")
+ let monoUnixFileInfo = monoPosix.GetType("Mono.Unix.UnixFileSystemInfo")
+ let socketName = Path.Combine(FileSystem.GetTempPathShim(), channelName)
+ let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box socketName |],System.Globalization.CultureInfo.InvariantCulture)
+ // Add 0x00000180 (UserReadWriteExecute) to the access permissions on Unix
+ monoUnixFileInfo.InvokeMember("set_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| box 0x00000180 |],System.Globalization.CultureInfo.InvariantCulture) |> ignore
+#if DEBUG
+ if !progress then printfn "server: good, set permissions on socket name '%s'" socketName
+ let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box socketName |],System.Globalization.CultureInfo.InvariantCulture)
+ let currPermissions = monoUnixFileInfo.InvokeMember("get_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| |],System.Globalization.CultureInfo.InvariantCulture) |> unbox<int>
+ if !progress then printfn "server: currPermissions = '%o' (octal)" currPermissions
+#endif
+ with e ->
+#if DEBUG
+ printfn "server: failed to set permissions on socket, perhaps on windows? Is is not needed there."
+#endif
+ ()
+ // Fail silently
+ server.Run()
+
+ static member private ConnectToServer() =
+ Activator.GetObject(typeof<FSharpCompilationServer>,"ipc://" + channelName + "/" + serverName)
+ :?> FSharpCompilationServer
+
+ static member TryCompileUsingServer(fscServerExe,argv) =
+ // Enable these lines to write a log file, e.g. when running under xbuild
+ //let os = System.IO.File.CreateText "/tmp/fsc-client-log"
+ //let printfn fmt = Printf.kfprintf (fun () -> fprintfn os ""; os.Flush()) os fmt
+ progress := !progress || condition "FSHARP_SERVER_PROGRESS"
+ let pwd = System.Environment.CurrentDirectory
+ let clientOpt =
+ if !progress then printfn "client: creating client"
+ // Detect the absence of the channel via the exception. Probably not the best way.
+ // Different exceptions get thrown here on Mono and Windows.
+ let client = FSharpCompilationServer.ConnectToServer()
+ try
+ if !progress then printfn "client: attempting to connect to existing service (1)"
+ client.Ping() |> ignore
+ if !progress then printfn "client: connected to existing service"
+ Some client
+ with _ ->
+ if !progress then printfn "client: error while creating client, starting client instead"
+ let procInfo =
+ if runningOnMono then
+ let shellName, useShellExecute =
+ match System.Environment.GetEnvironmentVariable("FSC_MONO") with
+ | null ->
+ if onWindows then
+ // e.g. "C:\Program Files\Mono-2.6.1\lib\mono\2.0\mscorlib.dll" --> "C:\Program Files\Mono-2.6.1\bin\mono.exe"
+ Path.Combine(Path.GetDirectoryName (typeof<Object>.Assembly.Location), @"..\..\..\bin\mono.exe"), false
+ else
+ "mono-sgen", true
+ | path -> path, true
+
+ ProcessStartInfo(FileName = shellName,
+ Arguments = fscServerExe + " /server",
+ CreateNoWindow = true,
+ UseShellExecute = useShellExecute)
+ else
+ ProcessStartInfo(FileName=fscServerExe,
+ Arguments = "/server",
+ CreateNoWindow = true,
+ UseShellExecute = false)
+
+ let cmdProcess = new Process(StartInfo=procInfo)
+
+ //let exitE = cmdProcess.Exited |> Observable.map (fun x -> x)
+
+ cmdProcess.Start() |> ignore
+ //exitE.Add(fun _ -> if !progress then eprintfn "client: the server has exited")
+ cmdProcess.EnableRaisingEvents <- true;
+
+ // Create the client proxy and attempt to connect to the server
+ let rec tryAcccesServer nRemaining =
+ if !progress then printfn "client: trying to access server, nRemaining = '%d'" nRemaining
+ if nRemaining = 0 then
+ // Failed to connect to server, give up
+ None
+ else
+ try
+ if !progress then printfn "client: attempting to connect to existing service (2)"
+ client.Ping() |> ignore
+ if !progress then printfn "client: connected to existing service"
+ Some client
+ // Detect the absence of the channel via the exception. Probably not the best way.
+ // Different exceptions get thrown here on Mono and Windows.
+ with _ (* System.Runtime.Remoting.RemotingException *) ->
+ // Sleep a bit
+ System.Threading.Thread.Sleep 50
+ tryAcccesServer (nRemaining - 1)
+
+ tryAcccesServer 20
+
+ match clientOpt with
+ | Some client ->
+ if !progress then printfn "client: calling client.Compile(%A)" argv
+ // Install the global error logger and never remove it. This logger does have all command-line flags considered.
+ try
+ let (output, exitCode) =
+ try client.Compile (pwd, argv)
+ with e ->
+ printfn "server error: %s" (e.ToString())
+ raise (Error (FSComp.SR.fscRemotingError(), rangeStartup))
+
+ if !progress then printfn "client: returned from client.Compile(%A), res = %d" argv exitCode
+ use holder =
+ try let originalConsoleColor = Console.ForegroundColor
+ { new System.IDisposable with member x.Dispose() = Console.ForegroundColor <- originalConsoleColor }
+ with _ -> null
+ let mutable prevConsoleColor = try Console.ForegroundColor with _ -> ConsoleColor.Black
+ for (isOut, consoleColorOpt, c:char) in output do
+ try match consoleColorOpt with
+ | Some consoleColor ->
+ if prevConsoleColor <> consoleColor then
+ Console.ForegroundColor <- consoleColor;
+ | None -> ()
+ with _ -> ()
+ c |> (if isOut then System.Console.Out.Write else System.Console.Error.Write)
+ Some exitCode
+ with err ->
+ let sb = System.Text.StringBuilder()
+ OutputErrorOrWarning (pwd,true,false,ErrorStyle.DefaultErrors,true) sb (PhasedError.Create(err,BuildPhase.Compile))
+ eprintfn "%s" (sb.ToString())
+ // We continue on and compile in-process - the server appears to have died half way through.
+ None
+ | None ->
+ None
+
+
+let runMain argv =
+ let inline hasArgument name args =
+ args |> Array.exists (fun x -> x = ("--" + name) || x = ("/" + name))
+ let inline stripArgument name args =
+ args |> Array.filter (fun x -> x <> ("--" + name) && x <> ("/" + name))
+
+ // Check for --pause as the very first step so that a compiler can be attached here.
+ if hasArgument "pause" argv then
+ System.Console.WriteLine("Press any key to continue...")
+ System.Console.ReadKey() |> ignore
+
+ if runningOnMono && hasArgument "resident" argv then
+ let argv = stripArgument "resident" argv
+
+ if not (hasArgument "nologo" argv) then
+ printfn "%s" (FSComp.SR.buildProductName(FSharpEnvironment.FSharpTeamVersionNumber))
+ printfn "%s" (FSComp.SR.optsCopyright())
+
+ let fscServerExe = typeof<TypeInThisAssembly>.Assembly.Location
+ let exitCodeOpt = FSharpResidentCompiler.FSharpCompilationServer.TryCompileUsingServer (fscServerExe, argv)
+ match exitCodeOpt with
+ | Some exitCode -> exitCode
+ | None ->
+ mainCompile (argv, true, QuitProcessExiter)
+ 0
+
+ elif runningOnMono && hasArgument "server" argv then
+ // Install the right exiter so we can catch "StopProcessing" without exiting the server
+ let exiter = { new Exiter with member x.Exit n = raise StopProcessing }
+ FSharpResidentCompiler.FSharpCompilationServer.RunServer(exiter)
+ 0
+
+ else
+ mainCompile (argv, false, QuitProcessExiter)
+ 0
+
+
[<EntryPoint>]
let main(argv) =
System.Runtime.GCSettings.LatencyMode <- System.Runtime.GCLatencyMode.Batch
@@ -39,8 +315,7 @@ let main(argv) =
if not runningOnMono then Lib.UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *)
try
- let fscServerExe = typeof<TypeInThisAssembly>.Assembly.Location
- Driver.main(fscServerExe, Array.append [| "fsc.exe" |] argv);
+ runMain(Array.append [| "fsc.exe" |] argv);
with e ->
errorRecovery e Microsoft.FSharp.Compiler.Range.range0;
1
diff --git a/src/utils/CompilerLocationUtils.fs b/src/utils/CompilerLocationUtils.fs
index c118fb0..e6b4213 100755
--- a/src/utils/CompilerLocationUtils.fs
+++ b/src/utils/CompilerLocationUtils.fs
@@ -319,10 +319,12 @@ module internal FSharpEnvironment =
// Check if the framework version 4.5 or above is installed at the given key entry
let IsNetFx45OrAboveInstalledAt subkey =
+ try
useKey subkey (fun regkey ->
match regkey with
| null -> false
| _ -> regkey.GetValue("Release", 0) :?> int |> (fun s -> s >= 0x50000)) // 0x50000 implies 4.5.0
+ with _ -> false
// Check if the framework version 4.5 or above is installed
let IsNetFx45OrAboveInstalled =
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-cli-apps/packages/fsharp.git
More information about the Pkg-cli-apps-commits
mailing list