Skip to content

Commit 23c2084

Browse files
dsymedsyme
committed
Merge pull request #480 from dsyme/integrate-7
Integrate recent work from Microsoft/VisualFSharp and fsharp/fsharp into this repo
2 parents 14d98da + 377ddef commit 23c2084

File tree

13 files changed

+134
-102
lines changed

13 files changed

+134
-102
lines changed

‎src/fsharp/CheckFormatStrings.fs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ open Microsoft.FSharp.Compiler.AbstractIL
88
open Microsoft.FSharp.Compiler.AbstractIL.Internal
99
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
1010
open Microsoft.FSharp.Compiler.Ast
11+
open Microsoft.FSharp.Compiler.Range
1112
open Microsoft.FSharp.Compiler.ErrorLogger
1213
open Microsoft.FSharp.Compiler.Tast
1314
open Microsoft.FSharp.Compiler.Tastops
@@ -48,7 +49,7 @@ let newInfo ()=
4849
addZeros = false
4950
precision = false}
5051

51-
let parseFormatStringInternal (m:Range.range) g (source: string option) fmt bty cty =
52+
let parseFormatStringInternal (m:range) g (source: string option) fmt bty cty =
5253
// Offset is used to adjust ranges depending on whether input string is regular, verbatim or triple-quote.
5354
// We construct a new 'fmt' string since the current 'fmt' string doesn't distinguish between "\n" and escaped "\\n".
5455
let (offset, fmt) =
@@ -291,16 +292,15 @@ let parseFormatStringInternal (m:Range.range) g (source: string option) fmt bty
291292
results, Seq.toList specifierLocations
292293

293294
let ParseFormatString m g source fmt bty cty dty =
294-
let argtys,ranges = parseFormatStringInternal m g source fmt bty cty
295+
let argtys, specifierLocations = parseFormatStringInternal m g source fmt bty cty
295296
let aty = List.foldBack (-->) argtys dty
296297
let ety = mkTupledTy g argtys
297-
(aty, ety),ranges
298+
(aty, ety), specifierLocations
298299

299300
let TryCountFormatStringArguments m g source fmt bty cty =
300301
try
301-
parseFormatStringInternal m g source fmt bty cty
302-
|> fst
303-
|> List.length
304-
|> Some
302+
let argtys, _specifierLocations = parseFormatStringInternal m g source fmt bty cty
303+
Some argtys.Length
305304
with _ ->
306-
None
305+
None
306+

‎src/fsharp/CompileOps.fs‎

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4373,9 +4373,16 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti
43734373
| None ->
43744374

43754375
if tcConfigP.Get().useMonoResolution then
4376-
let resolved = [tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError assemblyReference |> Option.get]
4377-
resolutions <- resolutions.AddResolutionResults resolved
4378-
ResultD resolved
4376+
let action =
4377+
match mode with
4378+
| ResolveAssemblyReferenceMode.ReportErrors -> CcuLoadFailureAction.RaiseError
4379+
| ResolveAssemblyReferenceMode.Speculative -> CcuLoadFailureAction.ReturnNone
4380+
match tcConfig.ResolveLibWithDirectories action assemblyReference with
4381+
| Some resolved ->
4382+
resolutions <- resolutions.AddResolutionResults [resolved]
4383+
ResultD [resolved]
4384+
| None ->
4385+
ErrorD(AssemblyNotResolved(assemblyReference.Text,assemblyReference.Range))
43794386
else
43804387
// This is a previously unencounterd assembly. Resolve it and add it to the list.
43814388
// But don't cache resolution failures because the assembly may appear on the disk later.
@@ -5256,3 +5263,4 @@ let TypeCheckClosedInputSet (checkForErrors, tcConfig, tcImports, tcGlobals, pre
52565263

52575264

52585265

5266+

‎src/fsharp/CompileOptions.fs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -748,12 +748,10 @@ let vsSpecificFlags (tcConfigB: TcConfigBuilder) =
748748

749749
let internalFlags (tcConfigB:TcConfigBuilder) =
750750
[
751-
CompilerOption("use-incremental-build", tagNone, OptionUnit (fun () -> tcConfigB.useIncrementalBuilder <- true), None, None)
752751
CompilerOption("stamps", tagNone, OptionUnit (fun () -> ()), Some(InternalCommandLineOption("--stamps", rangeCmdArgs)), None);
753752
CompilerOption("ranges", tagNone, OptionSet Tastops.DebugPrint.layoutRanges, Some(InternalCommandLineOption("--ranges", rangeCmdArgs)), None);
754753
CompilerOption("terms" , tagNone, OptionUnit (fun () -> tcConfigB.showTerms <- true), Some(InternalCommandLineOption("--terms", rangeCmdArgs)), None);
755754
CompilerOption("termsfile" , tagNone, OptionUnit (fun () -> tcConfigB.writeTermsToFiles <- true), Some(InternalCommandLineOption("--termsfile", rangeCmdArgs)), None);
756-
CompilerOption("use-incremental-build", tagNone, OptionUnit (fun () -> tcConfigB.useIncrementalBuilder <- true), None, None)
757755
#if DEBUG
758756
CompilerOption("debug-parse", tagNone, OptionUnit (fun () -> Internal.Utilities.Text.Parsing.Flags.debug <- true), Some(InternalCommandLineOption("--debug-parse", rangeCmdArgs)), None);
759757
CompilerOption("ilfiles", tagNone, OptionUnit (fun () -> tcConfigB.writeGeneratedILFiles <- true), Some(InternalCommandLineOption("--ilfiles", rangeCmdArgs)), None);

‎src/fsharp/IlxGen.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6106,7 +6106,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
61066106
(match ilTypeDefKind with ILTypeDefKind.ValueType -> true | _ -> false) &&
61076107
// All structs are sequential by default
61086108
// Structs with no instance fields get size 1, pack 0
6109-
tycon.AllFieldsAsList |> List.exists (fun f -> not f.IsStatic)
6109+
tycon.AllFieldsAsList |> List.forall (fun f -> f.IsStatic)
61106110

61116111
isEmptyStruct && cenv.opts.workAroundReflectionEmitBugs && not tycon.TyparsNoRange.IsEmpty
61126112

‎src/fsharp/PostInferenceChecks.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -528,7 +528,7 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) =
528528
CheckMultipleInterfaceInstantiations cenv interfaces m
529529

530530
// Allow base calls to F# methods
531-
| Expr.App((InnerExprPat(Expr.Val(v,vFlags,_) as f)),fty,tyargs,(Expr.Val(baseVal,_,_)::rest),m)
531+
| Expr.App((InnerExprPat(ExprValWithPossibleTypeInst(v,vFlags,_,_) as f)),fty,tyargs,(Expr.Val(baseVal,_,_)::rest),m)
532532
when ((match vFlags with VSlotDirectCall -> true | _ -> false) &&
533533
baseVal.BaseOrThisInfo = BaseVal) ->
534534
// dprintfn "GOT BASE VAL USE"

‎src/fsharp/TastOps.fsi‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,7 @@ val ensureCcuHasModuleOrNamespaceAtPath : CcuThunk -> Ident list -> CompilationP
6161
val stripExpr : Expr -> Expr
6262

6363
val valsOfBinds : Bindings -> FlatVals
64+
val (|ExprValWithPossibleTypeInst|_|) : Expr -> (ValRef * ValUseFlag * TType list * range) option
6465

6566
//-------------------------------------------------------------------------
6667
// Build decision trees imperatively

‎src/fsharp/TypeChecker.fs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6307,8 +6307,9 @@ and TcConstStringExpr cenv overallTy env m tpenv s =
63076307
if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy ty') then
63086308
// Parse the format string to work out the phantom types
63096309
let source = match cenv.tcSink.CurrentSink with None -> None | Some sink -> sink.CurrentSource
6310+
let normalizedString = (s.Replace("\r\n", "\n").Replace("\r", "\n"))
63106311

6311-
let (aty',ety'), specifierLocations = (try CheckFormatStrings.ParseFormatString m cenv.g source (s.Replace("\r\n", "\n").Replace("\r", "\n")) bty cty dty with Failure s -> error (Error(FSComp.SR.tcUnableToParseFormatString(s),m)))
6312+
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)))
63126313

63136314
match cenv.tcSink.CurrentSink with
63146315
| None -> ()

‎src/fsharp/fsc.fs‎

Lines changed: 95 additions & 71 deletions
Original file line numberDiff line numberDiff line change
@@ -248,7 +248,7 @@ let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexR
248248

249249
List.rev !allSources
250250

251-
let ProcessCommandLineFlags (tcConfigB: TcConfigBuilder, argv) =
251+
let ProcessCommandLineFlags (tcConfigB: TcConfigBuilder, setProcessThreadLocals, lcidFromCodePage, argv) =
252252
let inputFilesRef = ref ([] : string list)
253253
let collect name =
254254
let lower = String.lowercase name
@@ -263,6 +263,13 @@ let ProcessCommandLineFlags (tcConfigB: TcConfigBuilder, argv) =
263263
ParseCompilerOptions (collect, GetCoreFscCompilerOptions tcConfigB, List.tail (PostProcessCompilerArgs abbrevArgs argv))
264264
let inputFiles = List.rev !inputFilesRef
265265

266+
// Check if we have a codepage from the console
267+
match tcConfigB.lcid with
268+
| Some _ -> ()
269+
| None -> tcConfigB.lcid <- lcidFromCodePage
270+
271+
setProcessThreadLocals(tcConfigB)
272+
266273
(* step - get dll references *)
267274
let dllFiles,sourceFiles = List.partition Filename.isDll inputFiles
268275
match dllFiles with
@@ -313,17 +320,10 @@ let GetTcImportsFromCommandLine
313320
// The ParseCompilerOptions function calls imperative function to process "real" args
314321
// Rather than start processing, just collect names, then process them.
315322
try
316-
let sourceFiles = ProcessCommandLineFlags (tcConfigB, argv)
323+
let sourceFiles = ProcessCommandLineFlags (tcConfigB, setProcessThreadLocals, lcidFromCodePage, argv)
317324

318325
let sourceFiles = AdjustForScriptCompile(tcConfigB,sourceFiles,lexResourceManager)
319326

320-
// Check if we have a codepage from the console
321-
match tcConfigB.lcid with
322-
| Some _ -> ()
323-
| None -> tcConfigB.lcid <- lcidFromCodePage
324-
325-
setProcessThreadLocals(tcConfigB)
326-
327327
sourceFiles
328328

329329
with e ->
@@ -373,70 +373,94 @@ let GetTcImportsFromCommandLine
373373
if not tcConfigB.continueAfterParseFailure then
374374
AbortOnError(errorLogger, tcConfig, exiter)
375375

376-
ReportTime tcConfig "Import mscorlib and FSharp.Core.dll"
377-
let foundationalTcConfigP = TcConfigProvider.Constant(tcConfig)
378-
let sysRes,otherRes,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig)
379-
let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes)
380-
381-
// register framework tcImports to be disposed in future
382-
disposables.Register frameworkTcImports
383-
384-
// step - parse sourceFiles
385-
ReportTime tcConfig "Parse inputs"
386-
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse)
387-
let inputs =
388-
try
389-
sourceFiles
390-
|> tcConfig.ComputeCanContainEntryPoint
391-
|> List.zip sourceFiles
392-
// PERF: consider making this parallel, once uses of global state relevant to parsing are cleaned up
393-
|> List.choose (fun (filename:string,isLastCompiland:bool) ->
394-
let pathOfMetaCommandSource = Path.GetDirectoryName(filename)
395-
match ParseOneInputFile(tcConfig,lexResourceManager,["COMPILED"],filename,isLastCompiland,errorLogger,(*retryLocked*)false) with
396-
| Some(input)->Some(input,pathOfMetaCommandSource)
397-
| None -> None
398-
)
399-
with e ->
400-
errorRecoveryNoRange e
401-
SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
402-
exiter.Exit 1
403-
404-
if tcConfig.parseOnly then exiter.Exit 0
405-
if not tcConfig.continueAfterParseFailure then
406-
AbortOnError(errorLogger, tcConfig, exiter)
407-
408-
if tcConfig.printAst then
409-
inputs |> List.iter (fun (input,_filename) -> printf "AST:\n"; printfn "%+A" input; printf "\n")
410-
411-
let tcConfig = (tcConfig,inputs) ||> List.fold ApplyMetaCommandsFromInputToTcConfig
412-
let tcConfigP = TcConfigProvider.Constant(tcConfig)
413-
414-
ReportTime tcConfig "Import non-system references"
415-
let tcGlobals,tcImports =
416-
let tcImports = TcImports.BuildNonFrameworkTcImports(tcConfigP,tcGlobals,frameworkTcImports,otherRes,knownUnresolved)
417-
tcGlobals,tcImports
418-
419-
// register tcImports to be disposed in future
420-
disposables.Register tcImports
421-
422-
if not tcConfig.continueAfterParseFailure then
376+
let tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig =
377+
378+
ReportTime tcConfig "Import mscorlib"
379+
380+
#if INCREMENTAL_BUILD_OPTION
381+
if tcConfig.useIncrementalBuilder then
382+
ReportTime tcConfig "Incremental Parse and Typecheck"
383+
let builder =
384+
new IncrementalFSharpBuild.IncrementalBuilder(tcConfig, directoryBuildingFrom, assemblyName, NiceNameGenerator(), lexResourceManager, sourceFiles,
385+
ensureReactive=false,
386+
errorLogger=errorLogger,
387+
keepGeneratedTypedAssembly=true)
388+
let tcState,topAttribs,typedAssembly,_tcEnv,tcImports,tcGlobals,tcConfig = builder.TypeCheck()
389+
tcGlobals,tcImports,tcImports,tcState.Ccu,typedAssembly,topAttribs,tcConfig
390+
else
391+
#else
392+
begin
393+
#endif
394+
ReportTime tcConfig "Import mscorlib and FSharp.Core.dll"
395+
let foundationalTcConfigP = TcConfigProvider.Constant(tcConfig)
396+
let sysRes,otherRes,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig)
397+
let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes)
398+
399+
// register framework tcImports to be disposed in future
400+
disposables.Register frameworkTcImports
401+
402+
// step - parse sourceFiles
403+
ReportTime tcConfig "Parse inputs"
404+
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse)
405+
let inputs =
406+
try
407+
sourceFiles
408+
|> tcConfig.ComputeCanContainEntryPoint
409+
|> List.zip sourceFiles
410+
// PERF: consider making this parallel, once uses of global state relevant to parsing are cleaned up
411+
|> List.choose (fun (filename:string,isLastCompiland:bool) ->
412+
let pathOfMetaCommandSource = Path.GetDirectoryName(filename)
413+
match ParseOneInputFile(tcConfig,lexResourceManager,["COMPILED"],filename,isLastCompiland,errorLogger,(*retryLocked*)false) with
414+
| Some(input)->Some(input,pathOfMetaCommandSource)
415+
| None -> None
416+
)
417+
with e ->
418+
errorRecoveryNoRange e
419+
SqmLoggerWithConfig tcConfig errorLogger.ErrorNumbers errorLogger.WarningNumbers
420+
exiter.Exit 1
421+
422+
if tcConfig.parseOnly then exiter.Exit 0
423+
if not tcConfig.continueAfterParseFailure then
424+
AbortOnError(errorLogger, tcConfig, exiter)
425+
426+
if tcConfig.printAst then
427+
inputs |> List.iter (fun (input,_filename) -> printf "AST:\n"; printfn "%+A" input; printf "\n")
428+
429+
let tcConfig = (tcConfig,inputs) ||> List.fold ApplyMetaCommandsFromInputToTcConfig
430+
let tcConfigP = TcConfigProvider.Constant(tcConfig)
431+
432+
ReportTime tcConfig "Import non-system references"
433+
let tcGlobals,tcImports =
434+
let tcImports = TcImports.BuildNonFrameworkTcImports(tcConfigP,tcGlobals,frameworkTcImports,otherRes,knownUnresolved)
435+
tcGlobals,tcImports
436+
437+
// register tcImports to be disposed in future
438+
disposables.Register tcImports
439+
440+
if not tcConfig.continueAfterParseFailure then
441+
AbortOnError(errorLogger, tcConfig, exiter)
442+
443+
if tcConfig.importAllReferencesOnly then exiter.Exit 0
444+
445+
ReportTime tcConfig "Typecheck"
446+
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck)
447+
let tcEnv0 = GetInitialTcEnv (Some assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals)
448+
449+
// typecheck
450+
let inputs = inputs |> List.map fst
451+
let tcState,topAttrs,typedAssembly,_tcEnvAtEnd =
452+
TypeCheck(tcConfig,tcImports,tcGlobals,errorLogger,assemblyName,NiceNameGenerator(),tcEnv0,inputs,exiter)
453+
454+
let generatedCcu = tcState.Ccu
423455
AbortOnError(errorLogger, tcConfig, exiter)
456+
ReportTime tcConfig "Typechecked"
424457

425-
if tcConfig.importAllReferencesOnly then exiter.Exit 0
426-
427-
ReportTime tcConfig "Typecheck"
428-
use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck)
429-
let tcEnv0 = GetInitialTcEnv (Some assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals)
430-
431-
// typecheck
432-
let inputs = inputs |> List.map fst
433-
let tcState,topAttrs,typedAssembly,_tcEnvAtEnd =
434-
TypeCheck(tcConfig,tcImports,tcGlobals,errorLogger,assemblyName,NiceNameGenerator(),tcEnv0,inputs,exiter)
435-
436-
let generatedCcu = tcState.Ccu
437-
AbortOnError(errorLogger, tcConfig, exiter)
438-
ReportTime tcConfig "Typechecked"
439-
458+
(tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig)
459+
460+
#if INCREMENTAL_BUILD_OPTION
461+
#else
462+
end
463+
#endif
440464
tcGlobals,tcImports,frameworkTcImports,generatedCcu,typedAssembly,topAttrs,tcConfig,outfile,pdbfile,assemblyName,errorLogger
441465

442466
#if NO_COMPILER_BACKEND

‎src/fsharp/fsc.fsi‎

Lines changed: 3 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -30,11 +30,11 @@ type ILResource with
3030
member internal Bytes : byte[]
3131

3232
/// Proccess the given set of command line arguments
33-
val internal ProcessCommandLineFlags : TcConfigBuilder * argv:string[] -> string list
33+
val internal ProcessCommandLineFlags : TcConfigBuilder * setProcessThreadLocals:(TcConfigBuilder -> unit) * lcidFromCodePage : int option * argv:string[] -> string list
3434

3535
//---------------------------------------------------------------------------
36-
// The entry point used by fsc.exe
37-
36+
// The entry point used by fsc.exe and
37+
// the micro API into the compiler used by the visualfsharp test infrastructure
3838
val mainCompile :
3939
argv: string[] *
4040
bannerAlreadyPrinted: bool *
@@ -60,9 +60,6 @@ val compileOfAst :
6060
dynamicAssemblyCreator: (TcConfig * ILGlobals * ErrorLogger * string * string option * ILModuleDef * SigningInfo -> unit) option
6161
-> unit
6262

63-
//---------------------------------------------------------------------------
64-
// The micro API into the compiler used by the visualfsharp test infrastructure
65-
6663
[<RequireQualifiedAccess>]
6764
type CompilationOutput =
6865
{ Errors : ErrorOrWarning[]

‎src/fsharp/tast.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3632,7 +3632,7 @@ and Binding =
36323632
and ActivePatternElemRef =
36333633
| APElemRef of ActivePatternInfo * ValRef * int
36343634

3635-
member x.ActivePatternInfo = (let (APElemRef(total,_,_)) = x in total)
3635+
member x.ActivePatternInfo = (let (APElemRef(info,_,_)) = x in info)
36363636
member x.ActivePatternVal = (let (APElemRef(_,vref,_)) = x in vref)
36373637
member x.CaseIndex = (let (APElemRef(_,_,n)) = x in n)
36383638

0 commit comments

Comments
 (0)