patrick/WoofWare.PawPrint
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.PawPrint synced 2025-10-06 06:28:39 +00:00
Code Issues Packages Projects Releases Wiki Activity

Add infra for Monitor.ReliableEnter (#21)

Browse Source
This commit is contained in:
Patrick Stevens
2025-05-26 21:39:10 +01:00
committed by GitHub
parent 40eca9381d
commit 5fc11b1742
11 changed files with 189 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
WoofWare.PawPrint.Test/TestBasicLock.fs
View File

@@ -21,7 +21,7 @@ module TestBasicLock =
let dotnetRuntimes =
DotnetRuntime.SelectForDll assy.Location |> ImmutableArray.CreateRange
let impls = NativeImpls.Mock ()
let impls = MockEnv.make ()
use peImage = new MemoryStream (image)

23
WoofWare.PawPrint.Test/TestCases.fs
View File

@@ -18,17 +18,22 @@ module TestCases =
{
FileName = "BasicException.cs"
ExpectedReturnCode = 10
NativeImpls = NativeImpls.Mock ()
NativeImpls = MockEnv.make ()
}
{
FileName = "BasicLock.cs"
ExpectedReturnCode = 10
NativeImpls = NativeImpls.Mock ()
NativeImpls =
let mock = MockEnv.make ()
{ mock with
System_Threading_Monitor = System_Threading_Monitor.passThru
}
}
{
FileName = "WriteLine.cs"
ExpectedReturnCode = 1
NativeImpls = NativeImpls.Mock ()
NativeImpls = MockEnv.make ()
}
]
@@ -37,21 +42,21 @@ module TestCases =
{
FileName = "NoOp.cs"
ExpectedReturnCode = 1
NativeImpls = NativeImpls.Mock ()
NativeImpls = MockEnv.make ()
}
{
FileName = "TriangleNumber.cs"
ExpectedReturnCode = 10
NativeImpls = NativeImpls.Mock ()
NativeImpls = MockEnv.make ()
}
{
FileName = "InstaQuit.cs"
ExpectedReturnCode = 1
NativeImpls =
let mock = NativeImpls.Mock ()
let mock = MockEnv.make ()
{ mock with
System_Env =
System_Environment =
{ System_EnvironmentMock.Empty with
GetProcessorCount =
fun thread state ->
@@ -109,13 +114,11 @@ module TestCases =
let dotnetRuntimes =
DotnetRuntime.SelectForDll assy.Location |> ImmutableArray.CreateRange
let impls = NativeImpls.Mock ()
use peImage = new MemoryStream (image)
try
let terminalState, terminatingThread =
Program.run loggerFactory (Some case.FileName) peImage dotnetRuntimes impls []
Program.run loggerFactory (Some case.FileName) peImage dotnetRuntimes case.NativeImpls []
let exitCode =
match terminalState.ThreadState.[terminatingThread].MethodState.EvaluationStack.Values with

15
WoofWare.PawPrint.Test/TestHarness.fs
View File

@@ -17,17 +17,12 @@ type RunResult =
FinalState : IlMachineState
}
type NativeImpls =
{
System_Env : ISystem_Environment
}
interface ISystem_Environment_Env with
member this.System_Environment = this.System_Env
static member Mock () =
[<RequireQualifiedAccess>]
module MockEnv =
let make () : NativeImpls =
{
System_Env = System_EnvironmentMock.Empty
System_Environment = System_EnvironmentMock.Empty
System_Threading_Monitor = System_Threading_MonitorMock.Empty
}
type TestCase =

2
WoofWare.PawPrint.Test/TestHelloWorld.fs
View File

@@ -22,7 +22,7 @@ module TestHelloWorld =
let dotnetRuntimes =
DotnetRuntime.SelectForDll assy.Location |> ImmutableArray.CreateRange
let impls = NativeImpls.Mock ()
let impls = MockEnv.make ()
try
use peImage = new MemoryStream (image)

18
WoofWare.PawPrint/AbstractMachine.fs
View File

@@ -1,18 +1,9 @@
namespace WoofWare.PawPrint
open System.Collections.Immutable
open System.Reflection
open System.Reflection.Metadata
open Microsoft.Extensions.Logging
open Microsoft.FSharp.Core
open WoofWare.PawPrint.ExternImplementations
type ManagedObject =
{
Fields : (string * CliType) list
SyncBlock : unit
}
[<RequireQualifiedAccess>]
module AbstractMachine =
type private Dummy = class end
@@ -61,6 +52,15 @@ module AbstractMachine =
TypeDefn.Void ->
let env = ISystem_Environment_Env.get impls
env._Exit thread state
| "System.Private.CoreLib",
"System.Threading",
"Monitor",
"ReliableEnter",
[ TypeDefn.PrimitiveType PrimitiveType.Object
TypeDefn.Byref (TypeDefn.PrimitiveType PrimitiveType.Boolean) ],
TypeDefn.Void ->
let env = ISystem_Threading_Monitor_Env.get impls
env.ReliableEnter thread state
| assy, ns, typeName, methName, param, retType ->
failwith
$"TODO: tried to IL-interpret a method in {assy} {ns}.{typeName} named {methName} with no implementation; {param} -> {retType}"

5
WoofWare.PawPrint/ExternImplementations/NativeImpls.fs
View File

@@ -3,12 +3,17 @@ namespace WoofWare.PawPrint.ExternImplementations
type NativeImpls =
{
System_Environment : ISystem_Environment
System_Threading_Monitor : ISystem_Threading_Monitor
}
static member PassThru () =
{
System_Environment = System_Environment.passThru
System_Threading_Monitor = System_Threading_Monitor.passThru
}
interface ISystem_Environment_Env with
member this.System_Environment = this.System_Environment
interface ISystem_Threading_Monitor_Env with
member this.System_Threading_Monitor = this.System_Threading_Monitor

81
WoofWare.PawPrint/ExternImplementations/System.Threading.Monitor.fs Normal file
View File

@@ -0,0 +1,81 @@
namespace WoofWare.PawPrint.ExternImplementations
open WoofWare.PawPrint
type ISystem_Threading_Monitor =
/// Signature: (PrimitiveType Object, Byref (PrimitiveType Boolean)) -> Void
///
/// That is, the object on which to wait, and the result of the attempt to acquire the lock.
/// <param name="lockTaken">The result of the attempt to acquire the lock, passed by reference. The input must be <see langword="false" />. The output is <see langword="true" /> if the lock is acquired; otherwise, the output is <see langword="false" />. The output is set even if an exception occurs during the attempt to acquire the lock.
///
/// Note If no exception occurs, the output of this method is always <see langword="true" />.</param>
/// <exception cref="T:System.ArgumentException">The input to <paramref name="lockTaken" /> is <see langword="true" />.</exception>
/// <exception cref="T:System.ArgumentNullException">The <paramref name="obj" /> parameter is <see langword="null" />.</exception>
abstract ReliableEnter : ThreadId -> IlMachineState -> ExecutionResult
[<RequireQualifiedAccess>]
module System_Threading_Monitor =
let passThru : ISystem_Threading_Monitor =
{ new ISystem_Threading_Monitor with
member _.ReliableEnter currentThread state =
let lockObj, state =
state
|> IlMachineState.loadArgument currentThread 0
|> IlMachineState.popEvalStack currentThread
let outVar, state =
state
|> IlMachineState.loadArgument currentThread 1
|> IlMachineState.popEvalStack currentThread
let outVar =
match outVar with
| EvalStackValue.ManagedPointer ManagedPointerSource.Null ->
failwith "null byref was passed to Monitor.ReliableEnter"
| EvalStackValue.ManagedPointer (ManagedPointerSource.Heap _ as outVar) ->
failwith "TODO: passed a heap-allocated bool"
| EvalStackValue.ManagedPointer (ManagedPointerSource.LocalVariable (sourceThread,
methodFrame,
whichVar) as outVar) ->
match
state.ThreadState.[sourceThread].MethodStates.[methodFrame].LocalVariables
.[int<uint16> whichVar]
with
| CliType.Bool b ->
if b <> 0uy then
failwith "TODO: raise ArgumentException"
else
outVar
| c -> failwith $"Bad IL: in ReliableEnter, expected bool, got {c}"
| _ -> failwith $"expected out var of ReliableEnter to be byref<bool>, got {outVar}"
let state =
match lockObj with
| EvalStackValue.ManagedPointer ManagedPointerSource.Null ->
failwith "TODO: throw ArgumentNullException"
| EvalStackValue.ManagedPointer (ManagedPointerSource.Heap addr) ->
match IlMachineState.getSyncBlock addr state with
| false -> state |> IlMachineState.setSyncBlock addr true
| true -> failwith "TODO: somehow need to block on the monitor"
| EvalStackValue.ManagedPointer (ManagedPointerSource.LocalVariable _) ->
failwith "TODO: local variable holds object to lock"
| lockObj -> failwith $"TODO: lock object in Monitor.ReliableEnter was {lockObj}"
// Set result to True
let state =
match outVar with
| Null -> failwith "logic error"
| LocalVariable (sourceThread, methodFrame, whichVar) ->
state
|> IlMachineState.setLocalVariable sourceThread methodFrame whichVar (CliType.OfBool true)
| Heap addr -> failwith "todo: managed heap"
(state, WhatWeDid.Executed) |> ExecutionResult.Stepped
}
type ISystem_Threading_Monitor_Env =
abstract System_Threading_Monitor : ISystem_Threading_Monitor
[<RequireQualifiedAccess>]
module ISystem_Threading_Monitor_Env =
let inline get (env : ISystem_Threading_Monitor_Env) : ISystem_Threading_Monitor = env.System_Threading_Monitor

34
WoofWare.PawPrint/IlMachineState.fs
View File

@@ -656,6 +656,7 @@ module IlMachineState =
{
Fields = Map.ofList fields
Type = TypeInfoCrate.make typeInfo
SyncBlock = false
}
let alloc, heap = state.ManagedHeap |> ManagedHeap.AllocateNonArray o
@@ -890,3 +891,36 @@ module IlMachineState =
"Unexpected interpretation result has a local evaluation stack with more than one element on RET"
|> Some
let setLocalVariable
(thread : ThreadId)
(stackFrame : int)
(varIndex : uint16)
(value : CliType)
(state : IlMachineState)
: IlMachineState
=
{ state with
ThreadState =
state.ThreadState
|> Map.change
thread
(fun existing ->
match existing with
| None -> failwith "tried to set variable in nonactive thread"
| Some existing -> existing |> ThreadState.setLocalVariable stackFrame varIndex value |> Some
)
}
let setSyncBlock
(addr : ManagedHeapAddress)
(syncBlockValue : SyncBlock)
(state : IlMachineState)
: IlMachineState
=
{ state with
ManagedHeap = state.ManagedHeap |> ManagedHeap.SetSyncBlock addr syncBlockValue
}
let getSyncBlock (addr : ManagedHeapAddress) (state : IlMachineState) : SyncBlock =
state.ManagedHeap |> ManagedHeap.GetSyncBlock addr

21
WoofWare.PawPrint/ManagedHeap.fs
View File

@@ -2,10 +2,13 @@ namespace WoofWare.PawPrint
open System.Collections.Immutable
type SyncBlock = bool
type AllocatedNonArrayObject =
{
Fields : Map<string, CliType>
Type : WoofWare.PawPrint.TypeInfoCrate
SyncBlock : SyncBlock
}
type AllocatedArray =
@@ -32,6 +35,24 @@ type ManagedHeap =
StringArrayData = ImmutableArray.Empty
}
static member GetSyncBlock (addr : ManagedHeapAddress) (heap : ManagedHeap) : SyncBlock =
match heap.NonArrayObjects.TryGetValue addr with
| false, _ -> failwith "TODO: getting sync block of array"
| true, v -> v.SyncBlock
static member SetSyncBlock (addr : ManagedHeapAddress) (syncValue : SyncBlock) (heap : ManagedHeap) : ManagedHeap =
match heap.NonArrayObjects.TryGetValue addr with
| false, _ -> failwith "TODO: locked on an array object"
| true, v ->
let newV =
{ v with
SyncBlock = syncValue
}
{ heap with
NonArrayObjects = heap.NonArrayObjects |> Map.add addr newV
}
static member AllocateArray (ty : AllocatedArray) (heap : ManagedHeap) : ManagedHeapAddress * ManagedHeap =
let addr = heap.FirstAvailableAddress

12
WoofWare.PawPrint/ThreadState.fs
View File

@@ -90,3 +90,15 @@ type ThreadState =
{ state with
MethodStates = methodState
}
static member setLocalVariable (stackFrame : int) (localVariable : uint16) (value : CliType) (s : ThreadState) =
let frame = s.MethodStates.[stackFrame]
let newFrame =
{ frame with
LocalVariables = frame.LocalVariables.SetItem (int<uint16> localVariable, value)
}
{ s with
MethodStates = s.MethodStates.SetItem (stackFrame, newFrame)
}

7
WoofWare.PawPrint/WoofWare.PawPrint.fsproj
View File

@@ -41,6 +41,13 @@
<ISystem_Environment>GenerateMock(false)</ISystem_Environment>
</MyriadParams>
</Compile>
<Compile Include="ExternImplementations\System.Threading.Monitor.fs" />
<Compile Include="ExternImplementations\GeneratedSystem.Threading.Monitor.fs">
<MyriadFile>ExternImplementations\System.Threading.Monitor.fs</MyriadFile>
<MyriadParams>
<ISystem_Threading_Monitor>GenerateMock(false)</ISystem_Threading_Monitor>
</MyriadParams>
</Compile>
<Compile Include="ExternImplementations\NativeImpls.fs" />
<Compile Include="AbstractMachine.fs" />
<Compile Include="Program.fs" />