Skip to content

Commit

Permalink
mm
Browse files Browse the repository at this point in the history
  • Loading branch information
@TheAngryByrd
TheAngryByrd committed Nov 18, 2024
1 parent 419216f commit 7676fe7
Show file tree
Hide file tree
Showing 4 changed files with 67 additions and 36 deletions.
6 changes: 4 additions & 2 deletions .vscode/settings.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@
"FSharp.suggestGitignore": false,
"FSharp.enableMSBuildProjectGraph": true,
"FSharp.enableAdaptiveLspServer": true,
"FSharp.workspacePath": "FSharp.Compiler.Service.sln",
"FSharp.workspacePath": "./FSharp.Compiler.Service.sln",
"FSharp.workspaceModePeekDeepLevel": 1,
"FSharp.excludeProjectDirectories": [
".git",
Expand Down Expand Up @@ -53,5 +53,7 @@
}
},
"editor.inlayHints.enabled": "offUnlessPressed",
"dotnet.defaultSolution": "FSharp.Compiler.Service.sln"
"dotnet.defaultSolution": "FSharp.Compiler.Service.sln",
"FSharp.fsac.netCoreDllPath": "C:\\Users\\jimmy\\Repositories\\public\\TheAngryByrd\\FsAutoComplete\\src\\FsAutoComplete\\bin\\Release\\",
"FSharp.fcs.transparentCompiler.enabled": true
}
26 changes: 15 additions & 11 deletions src/Compiler/Facilities/DiagnosticsLogger.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -875,17 +875,21 @@ type StackGuard(maxDepth: int, name: string) =
[<CallerFilePath; Optional; DefaultParameterValue("")>] path: string,
[<CallerLineNumber; Optional; DefaultParameterValue(0)>] line: int
) =
use _ =
Activity.start
"DiagnosticsLogger.StackGuard.Guard"
[|
Activity.Tags.stackGuardName, name
Activity.Tags.stackGuardCurrentDepth, string depth
Activity.Tags.stackGuardMaxDepth, string maxDepth
Activity.Tags.callerMemberName, memberName
Activity.Tags.callerFilePath, path
Activity.Tags.callerLineNumber, string line
|]
ignore memberName
ignore path
ignore line

// use _ =
// Activity.start
// "DiagnosticsLogger.StackGuard.Guard"
// [|
// Activity.Tags.stackGuardName, name
// Activity.Tags.stackGuardCurrentDepth, string depth
// Activity.Tags.stackGuardMaxDepth, string maxDepth
// Activity.Tags.callerMemberName, memberName
// Activity.Tags.callerFilePath, path
// Activity.Tags.callerLineNumber, string line
// |]

depth <- depth + 1

Expand Down
66 changes: 45 additions & 21 deletions src/Compiler/Optimize/LowerStateMachines.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,11 +38,11 @@ type StateMachineConversionFirstPhaseResult =
resumableVars: FreeVars
}

#if DEBUG
// #if DEBUG
let sm_verbose = try not (isNull(System.Environment.GetEnvironmentVariable "FSharp_StateMachineVerbose")) with _ -> false
#else
let sm_verbose = false
#endif
// #else
// let sm_verbose = true
// #endif

let rec (|OptionalResumeAtExpr|) g expr =
match stripDebugPoints expr with
Expand Down Expand Up @@ -197,11 +197,12 @@ type LowerStateMachine(g: TcGlobals) =
| _ ->
(env, expr)

let rec TryReduceApp (env: env) expr (args: Expr list) =
let rec TryReduceApp (env: env) expr (args: Expr list) remake =
if isNil args then None else
match expr with
| Expr.TyLambda _
| Expr.Lambda _ ->
if sm_verbose then printfn "Entering lambda\n%A" (DebugPrint.showExpr expr)
let macroTypars, macroParamsCurried, macroBody, _rty = stripTopLambda (expr, tyOfExpr g expr)
let m = macroBody.Range
if not (isNil macroTypars) then
Expand All @@ -221,9 +222,10 @@ type LowerStateMachine(g: TcGlobals) =
Some expandedExpr
else
if sm_verbose then printfn "application was partial, reducing further args %A" laterArgs
TryReduceApp env expandedExpr laterArgs
TryReduceApp env expandedExpr laterArgs remake

| NewDelegateExpr g (_, macroParams, macroBody, _, _) ->
if sm_verbose then printfn "Entering delegate\n%A" (DebugPrint.showExpr expr)
let m = expr.Range
let macroVal2 = mkLambdas g m [] macroParams (macroBody, tyOfExpr g macroBody)
if args.Length < macroParams.Length then
Expand All @@ -237,28 +239,33 @@ type LowerStateMachine(g: TcGlobals) =
Some expandedExpr
else
if sm_verbose then printfn "application was partial, reducing further args %A" laterArgs
TryReduceApp env expandedExpr laterArgs
TryReduceApp env expandedExpr laterArgs remake

| Expr.Let (bind, bodyExpr, m, _) ->
match TryReduceApp env bodyExpr args with
if sm_verbose then printfn "TryReduceApp Let\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env bodyExpr args remake with
| Some bodyExpr2 -> Some (mkLetBind m bind bodyExpr2)
| None -> None

| Expr.LetRec (binds, bodyExpr, m, _) ->
match TryReduceApp env bodyExpr args with
if sm_verbose then printfn "TryReduceApp LetRec\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env bodyExpr args remake with
| Some bodyExpr2 -> Some (mkLetRecBinds m binds bodyExpr2)
| None -> None

| Expr.Sequential (x1, bodyExpr, sp, m) ->
match TryReduceApp env bodyExpr args with
if sm_verbose then printfn "TryReduceApp Sequential\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env bodyExpr args remake with
| Some bodyExpr2 -> Some (Expr.Sequential (x1, bodyExpr2, sp, m))
| None -> None

// This construct arises from the 'mkDefault' in the 'Throw' case of an incomplete pattern match
| Expr.Const (Const.Zero, m, ty) ->
if sm_verbose then printfn "TryReduceApp Const\n%A" (DebugPrint.showExpr expr)
Some (Expr.Const (Const.Zero, m, ty))

| Expr.Match (spBind, mExpr, dtree, targets, m, ty) ->
if sm_verbose then printfn "TryReduceApp Match\n%A" (DebugPrint.showExpr expr)
let mutable newTyOpt = None
let targets2 =
targets |> Array.choose (fun (TTarget(vs, targetExpr, flags)) ->
Expand All @@ -279,7 +286,7 @@ type LowerStateMachine(g: TcGlobals) =
Some targetExpr2
| _ ->

match TryReduceApp env targetExpr args with
match TryReduceApp env targetExpr args remake with
| Some targetExpr2 ->
newTyOpt <- Some (tyOfExpr g targetExpr2)
Some targetExpr2
Expand All @@ -294,30 +301,39 @@ type LowerStateMachine(g: TcGlobals) =
None

| WhileExpr (sp1, sp2, guardExpr, bodyExpr, m) ->
match TryReduceApp env bodyExpr args with
if sm_verbose then printfn "TryReduceApp While\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env bodyExpr args remake with
| Some bodyExpr2 -> Some (mkWhile g (sp1, sp2, guardExpr, bodyExpr2, m))
| None -> None

| TryFinallyExpr (sp1, sp2, ty, bodyExpr, compensation, m) ->
match TryReduceApp env bodyExpr args with
if sm_verbose then printfn "TryReduceApp TryFinally\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env bodyExpr args remake with
| Some bodyExpr2 -> Some (mkTryFinally g (bodyExpr2, compensation, m, ty, sp1, sp2))
| None -> None

| TryWithExpr (spTry, spWith, resTy, bodyExpr, filterVar, filterExpr, handlerVar, handlerExpr, m) ->
match TryReduceApp env bodyExpr args with
if sm_verbose then printfn "TryReduceApp TryWith\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env bodyExpr args remake with
| Some bodyExpr2 -> Some (mkTryWith g (bodyExpr2, filterVar, filterExpr, handlerVar, handlerExpr, m, resTy, spTry, spWith))
| None -> None

| Expr.DebugPoint (dp, innerExpr) ->
match TryReduceApp env innerExpr args with
if sm_verbose then printfn "TryReduceApp DebugPoint\n%A" (DebugPrint.showExpr expr)
match TryReduceApp env innerExpr args remake with
| Some innerExpr2 -> Some (Expr.DebugPoint (dp, innerExpr2))
| None -> None

// | Expr.App _ ->
// if sm_verbose then printfn "TryReduceApp App\n%A" (DebugPrint.showExpr expr)
// TryReduceExpr env expr args remake

| _ ->
| otherwise ->
if sm_verbose then printfn "failed TryReduceApp\n%A\n%A" (DebugPrint.showExpr otherwise) otherwise
None

// Apply a single expansion of resumable code at the outermost position in an arbitrary expression
let rec TryReduceExpr (env: env) expr args remake =
and TryReduceExpr (env: env) expr args remake =
if sm_verbose then printfn "expanding defns and reducing %A..." expr
//if sm_verbose then printfn "checking %A for possible resumable code application..." expr
match expr with
Expand All @@ -326,11 +342,12 @@ type LowerStateMachine(g: TcGlobals) =
let defn = env.ResumableCodeDefns[defnRef.Deref]
if sm_verbose then printfn "found resumable code %A --> %A" defnRef defn
// Expand the resumable code definition
match TryReduceApp env defn args with
match TryReduceApp env defn args remake with
| Some expandedExpr ->
if sm_verbose then printfn "expanded resumable code %A --> %A..." defnRef expandedExpr
Some expandedExpr
| None ->
if sm_verbose then printfn "failed to expand resumable code %A" defnRef
Some (remake defn)

// defn.Invoke x --> let arg = x in [defn][arg/x]
Expand All @@ -345,11 +362,12 @@ type LowerStateMachine(g: TcGlobals) =

| _ ->
//let (env, expr) = BindResumableCodeDefinitions env expr
match TryReduceApp env expr args with
match TryReduceApp env expr args remake with
| Some expandedExpr ->
if sm_verbose then printfn "reduction = %A, args = %A --> %A..." expr args expandedExpr
Some expandedExpr
| None ->
if sm_verbose then printfn "failed to reduce %A" (DebugPrint.showExpr expr)
None

// Repeated top-down rewrite
Expand Down Expand Up @@ -448,7 +466,8 @@ type LowerStateMachine(g: TcGlobals) =
let res =
match expr with
| ResumableCodeInvoke g (_, _, _, m, _) ->
Result.Error (FSComp.SR.reprResumableCodeInvokeNotReduced(!!m.ToString()))
if sm_verbose then printfn "found delegate invoke in top-level resumable code"
Result.Error (FSComp.SR.reprResumableCodeInvokeNotReduced(m.ToString()))

// Eliminate 'if __useResumableCode ...' within.
| IfUseResumableStateMachinesExpr g (thenExpr, _) ->
Expand Down Expand Up @@ -866,6 +885,9 @@ type LowerStateMachine(g: TcGlobals) =
if frees |> Zset.exists (isExpandVar g) then
let nonfree = frees |> Zset.elements |> List.filter (isExpandVar g) |> List.map (fun v -> v.DisplayName) |> String.concat ","
let msg = FSComp.SR.reprResumableCodeValueHasNoDefinition(nonfree)

if sm_verbose then
printfn "Resumable code value has no definition: %s" msg
fallback msg
else
let pcExprROpt = pcExprOpt |> Option.map (ConvertStateMachineLeafExpression env)
Expand All @@ -886,6 +908,7 @@ type LowerStateMachine(g: TcGlobals) =
let phase1 = ConvertResumableCode env pcValInfo codeExprR
match phase1 with
| Result.Error msg ->
if sm_verbose then printfn "Phase1 failed : %s :\n%s" msg (DebugPrint.showExpr codeExprR)
fallback msg
| Result.Ok phase1 ->

Expand Down Expand Up @@ -914,8 +937,9 @@ type LowerStateMachine(g: TcGlobals) =
let res = remake (moveNextExprWithJumpTable, phase1.stateVars, phase1.thisVars)
LoweredStateMachineResult.Lowered res

| _ ->
| other ->
let msg = FSComp.SR.reprStateMachineInvalidForm()
if sm_verbose then printfn "Not a state machine expr: \n %s" (DebugPrint.showExpr other)
fallback msg

let LowerStateMachineExpr g (overallExpr: Expr) : LoweredStateMachineResult =
Expand Down
5 changes: 3 additions & 2 deletions src/Compiler/Service/FSharpProjectSnapshot.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -560,7 +560,7 @@ and [<Experimental("This FCS API is experimental and subject to change.")>] FSha
referencedProjects: FSharpReferencedProjectSnapshot list,
isIncompleteTypeCheckEnvironment: bool,
useScriptResolutionRules: bool,
loadTime: DateTime,
loadTime: DateTime,
unresolvedReferences: FSharpUnresolvedReferencesSet option,
originalLoadReferences: (range * string * string) list,
stamp: int64 option
Expand Down Expand Up @@ -707,7 +707,8 @@ let rec internal snapshotToOptions (projectSnapshot: ProjectSnapshot) =
type internal Extensions =

[<Extension>]
static member ToOptions(this: ProjectSnapshot) = this |> snapshotToOptions
static member ToOptions(this: ProjectSnapshot) =
this |> snapshotToOptions

[<Extension>]
static member ToOptions(this: FSharpProjectSnapshot) =
Expand Down

0 comments on commit 7676fe7

Please sign in to comment.