From efd94e5ceaeab46c23e9c32ebcc507cf28fc34d0 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Mon, 2 Jun 2025 00:00:52 +0100 Subject: [PATCH] Implement the `lock` keyword (#35) --- WoofWare.PawPrint.Test/TestBasicLock.fs | 46 ------------------- WoofWare.PawPrint.Test/TestCases.fs | 33 ++++++++----- .../WoofWare.PawPrint.Test.fsproj | 1 - WoofWare.PawPrint/AbstractMachine.fs | 8 ++++ .../System.Threading.Monitor.fs | 35 +++++++++++++- WoofWare.PawPrint/IlMachineState.fs | 2 +- WoofWare.PawPrint/ManagedHeap.fs | 2 +- 7 files changed, 65 insertions(+), 62 deletions(-) delete mode 100644 WoofWare.PawPrint.Test/TestBasicLock.fs diff --git a/WoofWare.PawPrint.Test/TestBasicLock.fs b/WoofWare.PawPrint.Test/TestBasicLock.fs deleted file mode 100644 index afdf004..0000000 --- a/WoofWare.PawPrint.Test/TestBasicLock.fs +++ /dev/null @@ -1,46 +0,0 @@ -namespace WoofWare.Pawprint.Test - -open System.Collections.Immutable -open System.IO -open FsUnitTyped -open NUnit.Framework -open WoofWare.PawPrint -open WoofWare.PawPrint.ExternImplementations -open WoofWare.PawPrint.Test -open WoofWare.DotnetRuntimeLocator - -[] -module TestBasicLock = - let assy = typeof.Assembly - - [] - let ``Can run BasicLock`` () : unit = - let source = Assembly.getEmbeddedResourceAsString "BasicLock.cs" assy - let image = Roslyn.compile [ source ] - let messages, loggerFactory = LoggerFactory.makeTest () - - let dotnetRuntimes = - DotnetRuntime.SelectForDll assy.Location |> ImmutableArray.CreateRange - - let impls = NativeImpls.PassThru () - - use peImage = new MemoryStream (image) - - try - let terminalState, terminatingThread = - Program.run loggerFactory (Some "BasicLock.cs") peImage dotnetRuntimes impls [] - - let exitCode = - match terminalState.ThreadState.[terminatingThread].MethodState.EvaluationStack.Values with - | [] -> failwith "expected program to return 1, but it returned void" - | head :: _ -> - match head with - | EvalStackValue.Int32 i -> i - | _ -> failwith "TODO" - - exitCode |> shouldEqual 0 - finally - let messages = messages () - - for message in messages do - System.Console.WriteLine $"%O{message}" diff --git a/WoofWare.PawPrint.Test/TestCases.fs b/WoofWare.PawPrint.Test/TestCases.fs index 63de490..1b3dfc2 100644 --- a/WoofWare.PawPrint.Test/TestCases.fs +++ b/WoofWare.PawPrint.Test/TestCases.fs @@ -50,17 +50,6 @@ module TestCases = ] |> List.map (fun i -> CliType.Numeric (CliNumericType.Int32 i)) } - { - FileName = "BasicLock.cs" - ExpectedReturnCode = 10 - NativeImpls = - let mock = MockEnv.make () - - { mock with - System_Threading_Monitor = System_Threading_Monitor.passThru - } - LocalVariablesOfMain = [] - } { FileName = "WriteLine.cs" ExpectedReturnCode = 1 @@ -77,6 +66,28 @@ module TestCases = NativeImpls = MockEnv.make () LocalVariablesOfMain = [ CliType.Numeric (CliNumericType.Int32 1) ] } + { + FileName = "BasicLock.cs" + ExpectedReturnCode = 1 + NativeImpls = + let mock = MockEnv.make () + + { mock with + System_Threading_Monitor = System_Threading_Monitor.passThru + } + LocalVariablesOfMain = + [ + // Four variables: + // locker + CliType.ObjectRef (Some (ManagedHeapAddress 2)) + // a copy of locker, taken so that the contents of the implicit `finally` have a stable copy + CliType.ObjectRef (Some (ManagedHeapAddress 2)) + // out param of `ReliableEnter` + CliType.OfBool true + // return value + CliType.Numeric (CliNumericType.Int32 1) + ] + } { FileName = "TriangleNumber.cs" ExpectedReturnCode = 10 diff --git a/WoofWare.PawPrint.Test/WoofWare.PawPrint.Test.fsproj b/WoofWare.PawPrint.Test/WoofWare.PawPrint.Test.fsproj index c3b1edd..a77ab1e 100644 --- a/WoofWare.PawPrint.Test/WoofWare.PawPrint.Test.fsproj +++ b/WoofWare.PawPrint.Test/WoofWare.PawPrint.Test.fsproj @@ -16,7 +16,6 @@ - diff --git a/WoofWare.PawPrint/AbstractMachine.fs b/WoofWare.PawPrint/AbstractMachine.fs index c94391a..652dfd8 100644 --- a/WoofWare.PawPrint/AbstractMachine.fs +++ b/WoofWare.PawPrint/AbstractMachine.fs @@ -62,6 +62,14 @@ module AbstractMachine = TypeDefn.Void -> let env = ISystem_Threading_Monitor_Env.get impls env.ReliableEnter thread state + | "System.Private.CoreLib", + "System.Threading", + "Monitor", + "Exit", + [ TypeDefn.PrimitiveType PrimitiveType.Object ], + TypeDefn.Void -> + let env = ISystem_Threading_Monitor_Env.get impls + env.Exit 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}" diff --git a/WoofWare.PawPrint/ExternImplementations/System.Threading.Monitor.fs b/WoofWare.PawPrint/ExternImplementations/System.Threading.Monitor.fs index a6835bd..8dd2fd9 100644 --- a/WoofWare.PawPrint/ExternImplementations/System.Threading.Monitor.fs +++ b/WoofWare.PawPrint/ExternImplementations/System.Threading.Monitor.fs @@ -13,6 +13,15 @@ type ISystem_Threading_Monitor = /// The parameter is . abstract ReliableEnter : ThreadId -> IlMachineState -> ExecutionResult + /// Signature: (PrimitiveType Object) -> Void + /// That is, the object whose lock is to be released. + /// + /// Releases an exclusive lock on the specified object. + /// The object on which to release the lock. + /// The parameter is . + /// The current thread does not own the lock for the specified object. + abstract Exit : ThreadId -> IlMachineState -> ExecutionResult + [] module System_Threading_Monitor = let passThru : ISystem_Threading_Monitor = @@ -55,8 +64,10 @@ module System_Threading_Monitor = 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" + | None -> state |> IlMachineState.setSyncBlock addr (Some currentThread) + | Some _ -> + failwith + "TODO: somehow need to block on the monitor; also what happens if this thread already has the lock?" | EvalStackValue.ManagedPointer (ManagedPointerSource.LocalVariable _) -> failwith "TODO: local variable holds object to lock" | lockObj -> failwith $"TODO: lock object in Monitor.ReliableEnter was {lockObj}" @@ -71,6 +82,26 @@ module System_Threading_Monitor = | Heap addr -> failwith "todo: managed heap" (state, WhatWeDid.Executed) |> ExecutionResult.Stepped + + member this.Exit thread state = + let lockObj, state = + state + |> IlMachineState.loadArgument thread 0 + |> IlMachineState.popEvalStack thread + + let state = + match lockObj with + | EvalStackValue.ManagedPointer ManagedPointerSource.Null -> + failwith "TODO: throw ArgumentNullException" + | EvalStackValue.ManagedPointer (ManagedPointerSource.Heap addr) -> + match IlMachineState.getSyncBlock addr state with + | Some t when t = thread -> state |> IlMachineState.setSyncBlock addr None + | _ -> failwith "TODO: throw SynchronizationLockException" + | EvalStackValue.ManagedPointer (ManagedPointerSource.LocalVariable _) -> + failwith "TODO: local variable holds object to lock" + | lockObj -> failwith $"TODO: lock object in Monitor.ReliableEnter was {lockObj}" + + (state, WhatWeDid.Executed) |> ExecutionResult.Stepped } type ISystem_Threading_Monitor_Env = diff --git a/WoofWare.PawPrint/IlMachineState.fs b/WoofWare.PawPrint/IlMachineState.fs index 2b558a2..f713761 100644 --- a/WoofWare.PawPrint/IlMachineState.fs +++ b/WoofWare.PawPrint/IlMachineState.fs @@ -727,7 +727,7 @@ module IlMachineState = { Fields = Map.ofList fields Type = TypeInfoCrate.make typeInfo - SyncBlock = false + SyncBlock = None } let alloc, heap = state.ManagedHeap |> ManagedHeap.AllocateNonArray o diff --git a/WoofWare.PawPrint/ManagedHeap.fs b/WoofWare.PawPrint/ManagedHeap.fs index 12498ed..a826eb2 100644 --- a/WoofWare.PawPrint/ManagedHeap.fs +++ b/WoofWare.PawPrint/ManagedHeap.fs @@ -2,7 +2,7 @@ namespace WoofWare.PawPrint open System.Collections.Immutable -type SyncBlock = bool +type SyncBlock = ThreadId option type AllocatedNonArrayObject = {