Skip to content

Commit

Permalink
changes
Browse files Browse the repository at this point in the history
  • Loading branch information
@safesparrow
safesparrow committed Oct 30, 2022
1 parent ae722fe commit d82c543
Show file tree
Hide file tree
Showing 3 changed files with 187 additions and 73 deletions.
186 changes: 166 additions & 20 deletions src/Compiler/Driver/ParseAndCheckInputs.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1073,6 +1073,8 @@ type TcState =
tcsCreatesGeneratedProvidedTypes = y
}

type State = TcState * bool

/// Create the initial type checking state for compiling an assembly
let GetInitialTcState (m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcImports, tcEnv0, openDecls0) =
ignore tcImports
Expand Down Expand Up @@ -1230,9 +1232,14 @@ let CheckOneInputAux
let m = inp.Range
let amap = tcImports.GetImportMap()

let conditionalDefines =
if tcConfig.noConditionalErasure then
None
else
Some tcConfig.conditionalDefines

match inp with
| ParsedInput.SigFile file ->

let qualNameOfFile = file.QualifiedName

// Check if we've seen this top module signature before.
Expand All @@ -1243,12 +1250,6 @@ let CheckOneInputAux
if Zset.contains qualNameOfFile tcState.tcsRootImpls then
errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail (qualNameOfFile.Text), m))

let conditionalDefines =
if tcConfig.noConditionalErasure then
None
else
Some tcConfig.conditionalDefines

// Typecheck the signature file
let! tcEnv, sigFileType, createsGeneratedProvidedTypes =
CheckOneSigFile
Expand Down Expand Up @@ -1295,12 +1296,6 @@ let CheckOneInputAux
if Zset.contains qualNameOfFile tcState.tcsRootImpls then
errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (qualNameOfFile.Text), m))

let conditionalDefines =
if tcConfig.noConditionalErasure then
None
else
Some tcConfig.conditionalDefines

let hadSig = rootSigOpt.IsSome

match rootSigOpt with
Expand Down Expand Up @@ -1360,17 +1355,17 @@ let CheckOneInputAux
/// Typecheck a single file (or interactive entry into F# Interactive). If skipImplIfSigExists is set to true
/// then implementations with signature files give empty results.
let CheckOneInput
(
checkForErrors,
((checkForErrors,
tcConfig: TcConfig,
tcImports: TcImports,
tcGlobals,
prefixPathOpt,
tcSink,
tcState: TcState,
input: ParsedInput,
skipImplIfSigExists: bool
) =
skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool)
: Cancellable<PartialResult * TcState>
=
cancellable {
let! partialResult, tcState =
CheckOneInputAux(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input, skipImplIfSigExists)
Expand All @@ -1391,6 +1386,159 @@ let CheckOneInput
)
}




/// Typecheck a single file (or interactive entry into F# Interactive)
let CheckOneInputAux'
((checkForErrors,
tcConfig: TcConfig,
tcImports: TcImports,
tcGlobals,
prefixPathOpt,
tcSink,
tcState: TcState,
inp: ParsedInput,
_skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool)
: Cancellable<TcState -> PartialResult * TcState>
=

cancellable {
try
CheckSimulateException tcConfig

let m = inp.Range
let amap = tcImports.GetImportMap()

let conditionalDefines =
if tcConfig.noConditionalErasure then
None
else
Some tcConfig.conditionalDefines

match inp with
| ParsedInput.SigFile file ->
let qualNameOfFile = file.QualifiedName

// Check if we've seen this top module signature before.
if Zmap.mem qualNameOfFile tcState.tcsRootSigs then
errorR (Error(FSComp.SR.buildSignatureAlreadySpecified (qualNameOfFile.Text), m.StartRange))

// Check if the implementation came first in compilation order
if Zset.contains qualNameOfFile tcState.tcsRootImpls then
errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail (qualNameOfFile.Text), m))

// Typecheck the signature file
let! tcEnv, sigFileType, createsGeneratedProvidedTypes =
CheckOneSigFile
(tcGlobals,
amap,
tcState.tcsCcu,
checkForErrors,
conditionalDefines,
tcSink,
tcConfig.internalTestSpanStackReferring)
tcState.tcsTcSigEnv
file

return fun tcState ->
let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs

// Add the signature to the signature env (unless it had an explicit signature)
let ccuSigForFile = CombineCcuContentFragments [ sigFileType; tcState.tcsCcuSig ]

// Open the prefixPath for fsi.exe
let tcEnv, _openDecls1 =
match prefixPathOpt with
| None -> tcEnv, []
| Some prefixPath ->
let m = qualNameOfFile.Range
TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcEnv (prefixPath, m)

let partialResult = tcEnv, EmptyTopAttrs, None, ccuSigForFile

let tcState =
{ tcState with
tcsTcSigEnv = tcEnv
tcsTcImplEnv = tcState.tcsTcImplEnv
tcsRootSigs = rootSigs
tcsCreatesGeneratedProvidedTypes = tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes
}

partialResult, tcState

| ParsedInput.ImplFile file ->
let qualNameOfFile = file.QualifiedName

// Check if we've got an interface for this fragment
let rootSigOpt = tcState.tcsRootSigs.TryFind qualNameOfFile

// Check if we've already seen an implementation for this fragment
if Zset.contains qualNameOfFile tcState.tcsRootImpls then
errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (qualNameOfFile.Text), m))

let hadSig = rootSigOpt.IsSome

// Typecheck the implementation file
let! topAttrs, implFile, tcEnvAtEnd, createsGeneratedProvidedTypes =
CheckOneImplFile(
tcGlobals,
amap,
tcState.tcsCcu,
tcState.tcsImplicitOpenDeclarations,
checkForErrors,
conditionalDefines,
tcSink,
tcConfig.internalTestSpanStackReferring,
tcState.tcsTcImplEnv,
rootSigOpt,
file
)

return fun tcState ->
let ccuSigForFile, tcState =
AddCheckResultsToTcState
(tcGlobals, amap, hadSig, prefixPathOpt, tcSink, tcState.tcsTcImplEnv, qualNameOfFile, implFile.Signature)
tcState

let partialResult = tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile

let tcState =
{ tcState with
tcsCreatesGeneratedProvidedTypes = tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes
}

partialResult, tcState

with e ->
errorRecovery e range0
return fun tcState -> (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState
}


/// Typecheck a single file (or interactive entry into F# Interactive). If skipImplIfSigExists is set to true
/// then implementations with signature files give empty results.
let CheckOneInput'
((checkForErrors,
tcConfig: TcConfig,
tcImports: TcImports,
tcGlobals,
prefixPathOpt,
tcSink,
tcState: TcState,
input: ParsedInput,
skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool)
: Cancellable<TcState -> PartialResult * TcState>
=
cancellable {
let! f =
CheckOneInputAux'(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input, skipImplIfSigExists)
// TODO Handle skipImplIfSigExists
return f
}



// Within a file, equip loggers to locally filter w.r.t. scope pragmas in each input
let DiagnosticsLoggerForInput (tcConfig: TcConfig, input: ParsedInput, oldLogger) =
GetDiagnosticsLoggerFilteringByScopedPragmas(false, input.ScopedPragmas, tcConfig.diagnosticsOptions, oldLogger)
Expand Down Expand Up @@ -1559,9 +1707,7 @@ let CheckMultipleInputsInParallel
}

results, tcState)

type State = TcState * bool


type WorkInput =
{
FileIndex : int
Expand Down
14 changes: 14 additions & 0 deletions src/Compiler/Driver/ParseAndCheckInputs.fsi
View file
Original file line number Diff line number Diff line change
Expand Up @@ -166,6 +166,20 @@ val CheckOneInput:
skipImplIfSigExists: bool ->
Cancellable<(TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType) * TcState>

/// Check one input, returned as an Eventually computation
val CheckOneInput':
checkForErrors: (unit -> bool) *
tcConfig: TcConfig *
tcImports: TcImports *
tcGlobals: TcGlobals *
prefixPathOpt: LongIdent option *
tcSink: NameResolution.TcResultsSink *
tcState: TcState *
input: ParsedInput *
skipImplIfSigExists: bool ->
Cancellable<TcState -> PartialResult * TcState>


/// Finish the checking of multiple inputs
val CheckMultipleInputsFinish:
(TcEnv * TopAttribs * 'T option * 'U) list * TcState -> (TcEnv * TopAttribs * 'T list * 'U list) * TcState
Expand Down
60 changes: 7 additions & 53 deletions tests/FSharp.Compiler.Service.Tests2/ParallelTypeChecking.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -88,31 +88,19 @@ module internal Real =
// In the first linear part of parallel checking, we use a 'checkForErrors' that checks either for errors
// somewhere in the files processed prior to each one, or in the processing of this particular file.
let priorErrors = checkForErrors ()
let amap = tcImports.GetImportMap()
let conditionalDefines =
if tcConfig.noConditionalErasure then
None
else
Some tcConfig.conditionalDefines

let processFile
((input, logger) : ParsedInput * DiagnosticsLogger)
((currentTcState, _) : State)
((currentTcState, currentPriorErrors) : State)
: State -> PartialResult * State =
cancellable {
use _ = UseDiagnosticsLogger logger
// Is it OK that we don't update 'priorErrors' after processing batches?
let checkForErrors2 () = priorErrors || (logger.ErrorCount > 0)

// this is taken mostly from CheckOneInputAux, the case where the impl has no signature file
let file =
match input with
| ParsedInput.ImplFile file -> file
| ParsedInput.SigFile _ -> failwith "not expecting a signature file for now"

let tcSink = TcResultsSink.NoSink

let! tuple, tcState = CheckOneInput(
let! f = CheckOneInput'(
checkForErrors2,
tcConfig,
tcImports,
Expand All @@ -121,50 +109,18 @@ module internal Real =
tcSink,
currentTcState,
input,
false // skipImpFiles...
false // skipImpFiles...
)

// Typecheck the implementation file
let! topAttrs, implFile, tcEnvAtEnd, createsGeneratedProvidedTypes =
CheckOneImplFile(
tcGlobals,
amap,
currentTcState.Ccu,
currentTcState.TcsImplicitOpenDeclarations,
checkForErrors2,
conditionalDefines,
TcResultsSink.NoSink,
tcConfig.internalTestSpanStackReferring,
currentTcState.TcEnvFromImpls,
None,
file
)

return
(fun (state : State) ->
let tcState, _priorErrors = state
let tcState =
tcState.WithCreatesGeneratedProvidedTypes
(tcState.CreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes)
let tcState, priorErrors = state
let (partialResult : PartialResult, tcState) = f tcState

let ccuSigForFile, updatedTcState =
let results =
tcGlobals,
amap,
false,
prefixPathOpt,
tcSink,
tcState.TcEnvFromImpls,
input.QualifiedName,
implFile.Signature

AddCheckResultsToTcState results tcState

let partialResult : PartialResult = tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile
let hasErrors = logger.ErrorCount > 0
// TODO Should we use local _priorErrors or global priorErrors?
let priorOrCurrentErrors = priorErrors || hasErrors
let state : State = updatedTcState, priorOrCurrentErrors

let state : State = tcState, priorOrCurrentErrors
partialResult, state
)
}
Expand Down Expand Up @@ -199,8 +155,6 @@ module internal Real =
partialResults |> Array.toList, tcState
)

CheckMultipleInputsInParallel2 <- CheckMultipleInputsInParallelMy


let typeCheckGraph (graph : FileGraph) : FinalFileResult[] * State =
let parallelism = 4 // cpu count?
Expand Down

0 comments on commit d82c543

Please sign in to comment.