diff --git a/WoofWare.PawPrint.Test/TestBasicLock.fs b/WoofWare.PawPrint.Test/TestBasicLock.fs index 3a72bfc..afdf004 100644 --- a/WoofWare.PawPrint.Test/TestBasicLock.fs +++ b/WoofWare.PawPrint.Test/TestBasicLock.fs @@ -5,6 +5,7 @@ open System.IO open FsUnitTyped open NUnit.Framework open WoofWare.PawPrint +open WoofWare.PawPrint.ExternImplementations open WoofWare.PawPrint.Test open WoofWare.DotnetRuntimeLocator @@ -21,7 +22,7 @@ module TestBasicLock = let dotnetRuntimes = DotnetRuntime.SelectForDll assy.Location |> ImmutableArray.CreateRange - let impls = MockEnv.make () + let impls = NativeImpls.PassThru () use peImage = new MemoryStream (image) diff --git a/WoofWare.PawPrint.Test/TestCases.fs b/WoofWare.PawPrint.Test/TestCases.fs index 6203963..fed90e1 100644 --- a/WoofWare.PawPrint.Test/TestCases.fs +++ b/WoofWare.PawPrint.Test/TestCases.fs @@ -41,7 +41,7 @@ module TestCases = { FileName = "WriteLine.cs" ExpectedReturnCode = 1 - NativeImpls = MockEnv.make () + NativeImpls = NativeImpls.PassThru () LocalVariablesOfMain = [] } ] diff --git a/WoofWare.PawPrint.Test/TestHelloWorld.fs b/WoofWare.PawPrint.Test/TestHelloWorld.fs index 2781f60..9f1c8f2 100644 --- a/WoofWare.PawPrint.Test/TestHelloWorld.fs +++ b/WoofWare.PawPrint.Test/TestHelloWorld.fs @@ -6,6 +6,7 @@ open System.IO open FsUnitTyped open NUnit.Framework open WoofWare.PawPrint +open WoofWare.PawPrint.ExternImplementations open WoofWare.PawPrint.Test open WoofWare.DotnetRuntimeLocator @@ -15,14 +16,14 @@ module TestHelloWorld = [] let ``Can run Hello World`` () : unit = - let source = Assembly.getEmbeddedResourceAsString "HelloWorld.cs" assy + let source = Assembly.getEmbeddedResourceAsString "WriteLine.cs" assy let image = Roslyn.compile [ source ] let messages, loggerFactory = LoggerFactory.makeTest () let dotnetRuntimes = DotnetRuntime.SelectForDll assy.Location |> ImmutableArray.CreateRange - let impls = MockEnv.make () + let impls = NativeImpls.PassThru () try use peImage = new MemoryStream (image) diff --git a/WoofWare.PawPrint/AbstractMachine.fs b/WoofWare.PawPrint/AbstractMachine.fs index 342802e..c94391a 100644 --- a/WoofWare.PawPrint/AbstractMachine.fs +++ b/WoofWare.PawPrint/AbstractMachine.fs @@ -22,10 +22,11 @@ module AbstractMachine = match instruction.ExecutingMethod.Instructions with | None -> let targetAssy = - state.LoadedAssembly (snd instruction.ExecutingMethod.DeclaringType) + state.LoadedAssembly instruction.ExecutingMethod.DeclaringType.Assembly |> Option.get - let targetType = targetAssy.TypeDefs.[fst instruction.ExecutingMethod.DeclaringType] + let targetType = + targetAssy.TypeDefs.[instruction.ExecutingMethod.DeclaringType.Definition.Get] let outcome = match @@ -80,10 +81,10 @@ module AbstractMachine = | true, executingInstruction -> let executingInType = - match state.LoadedAssembly (snd instruction.ExecutingMethod.DeclaringType) with + match state.LoadedAssembly instruction.ExecutingMethod.DeclaringType.Assembly with | None -> "" | Some assy -> - match assy.TypeDefs.TryGetValue (fst instruction.ExecutingMethod.DeclaringType) with + match assy.TypeDefs.TryGetValue instruction.ExecutingMethod.DeclaringType.Definition.Get with | true, v -> v.Name | false, _ -> "" diff --git a/WoofWare.PawPrint/Assembly.fs b/WoofWare.PawPrint/Assembly.fs index 839127a..5bea963 100644 --- a/WoofWare.PawPrint/Assembly.fs +++ b/WoofWare.PawPrint/Assembly.fs @@ -61,7 +61,7 @@ type DumpedAssembly = /// /// Dictionary of all method definitions in this assembly, keyed by their handle. /// - Methods : IReadOnlyDictionary + Methods : IReadOnlyDictionary> /// /// Dictionary of all member references in this assembly, keyed by their handle. diff --git a/WoofWare.PawPrint/BasicCliType.fs b/WoofWare.PawPrint/BasicCliType.fs index a6cce9c..02046f3 100644 --- a/WoofWare.PawPrint/BasicCliType.fs +++ b/WoofWare.PawPrint/BasicCliType.fs @@ -144,7 +144,7 @@ module CliType = match signatureTypeKind with | SignatureTypeKind.Unknown -> failwith "todo" | SignatureTypeKind.ValueType -> - let typeDef = assy.TypeDefs.[typeDefinitionHandle] + let typeDef = assy.TypeDefs.[typeDefinitionHandle.Get] let fields = typeDef.Fields diff --git a/WoofWare.PawPrint/ComparableSignatureHeader.fs b/WoofWare.PawPrint/ComparableSignatureHeader.fs new file mode 100644 index 0000000..fa19193 --- /dev/null +++ b/WoofWare.PawPrint/ComparableSignatureHeader.fs @@ -0,0 +1,36 @@ +namespace WoofWare.PawPrint + +open System +open System.Reflection.Metadata + +[] +[] +type ComparableSignatureHeader = + private + { + _Inner : SignatureHeader + } + + member this.Get = this._Inner + + override this.Equals (other : obj) = + match other with + | :? ComparableSignatureHeader as other -> this._Inner.RawValue = other._Inner.RawValue + | _ -> false + + override this.GetHashCode () = this._Inner.RawValue.GetHashCode () + + interface IComparable with + member this.CompareTo (other : ComparableSignatureHeader) = + this._Inner.RawValue.CompareTo other._Inner.RawValue + + interface IComparable with + member this.CompareTo (other : obj) = + match other with + | :? ComparableSignatureHeader as other -> (this :> IComparable).CompareTo other + | _ -> failwith "invalid comparison" + + static member Make x : ComparableSignatureHeader = + { + _Inner = x + } diff --git a/WoofWare.PawPrint/ComparableTypeDefinitionHandle.fs b/WoofWare.PawPrint/ComparableTypeDefinitionHandle.fs new file mode 100644 index 0000000..fc34bd6 --- /dev/null +++ b/WoofWare.PawPrint/ComparableTypeDefinitionHandle.fs @@ -0,0 +1,37 @@ +namespace WoofWare.PawPrint + +open System +open System.Reflection.Metadata + +[] +[] +type ComparableTypeDefinitionHandle = + private + { + _Inner : TypeDefinitionHandle + } + + override this.Equals (other) = + match other with + | :? ComparableTypeDefinitionHandle as other -> this._Inner.GetHashCode () = other._Inner.GetHashCode () + | _ -> false + + override this.GetHashCode () : int = this._Inner.GetHashCode () + + interface IComparable with + member this.CompareTo (other : ComparableTypeDefinitionHandle) : int = + this._Inner.GetHashCode().CompareTo (other._Inner.GetHashCode ()) + + interface IComparable with + member this.CompareTo (other : obj) : int = + match other with + | :? ComparableTypeDefinitionHandle as other -> + (this :> IComparable).CompareTo other + | _ -> failwith "invalid comparison" + + static member Make (h : TypeDefinitionHandle) = + { + _Inner = h + } + + member this.Get = this._Inner diff --git a/WoofWare.PawPrint/ConcreteType.fs b/WoofWare.PawPrint/ConcreteType.fs new file mode 100644 index 0000000..2b02f61 --- /dev/null +++ b/WoofWare.PawPrint/ConcreteType.fs @@ -0,0 +1,93 @@ +namespace WoofWare.PawPrint + +open System +open System.Reflection +open System.Reflection.Metadata + +type FakeUnit = private | FakeUnit + +/// A type which has been concretised, runtime-representable, etc. +[] +[] +type ConcreteType<'typeGeneric when 'typeGeneric : comparison and 'typeGeneric :> IComparable<'typeGeneric>> = + private + { + _AssemblyName : AssemblyName + _Definition : ComparableTypeDefinitionHandle + _Generics : 'typeGeneric list + } + + member this.Assembly : AssemblyName = this._AssemblyName + member this.Definition : ComparableTypeDefinitionHandle = this._Definition + member this.Generics : 'typeGeneric list = this._Generics + + override this.Equals (other : obj) : bool = + match other with + | :? ConcreteType<'typeGeneric> as other -> + this._Generics = other._Generics + && this._Definition = other._Definition + && this._AssemblyName.FullName = other._AssemblyName.FullName + | _ -> false + + override this.GetHashCode () : int = + hash (this._AssemblyName.FullName, this._Definition, this._Generics) + + interface IComparable> with + member this.CompareTo (other : ConcreteType<'typeGeneric>) : int = + let comp = this._AssemblyName.FullName.CompareTo other._AssemblyName.FullName + + if comp = 0 then + let comp = + (this._Definition :> IComparable).CompareTo other._Definition + + if comp = 0 then + let thisGen = (this._Generics : 'typeGeneric list) :> IComparable<'typeGeneric list> + thisGen.CompareTo other._Generics + else + comp + else + comp + + interface IComparable with + member this.CompareTo other = + match other with + | :? ConcreteType<'typeGeneric> as other -> + (this :> IComparable>).CompareTo other + | _ -> failwith "bad comparison" + +type RuntimeConcreteType = ConcreteType + +[] +module ConcreteType = + let make (assemblyName : AssemblyName) (defn : TypeDefinitionHandle) (generics : TypeDefn list) = + { + _AssemblyName = assemblyName + _Definition = ComparableTypeDefinitionHandle.Make defn + _Generics = generics + } + + let make' + (assemblyName : AssemblyName) + (defn : TypeDefinitionHandle) + (genericParamCount : int) + : ConcreteType + = + { + _AssemblyName = assemblyName + _Definition = ComparableTypeDefinitionHandle.Make defn + _Generics = List.replicate genericParamCount FakeUnit.FakeUnit + } + + let mapGeneric<'a, 'b + when 'a : comparison and 'a :> IComparable<'a> and 'b : equality and 'b : comparison and 'b :> IComparable<'b>> + (f : int -> 'a -> 'b) + (x : ConcreteType<'a>) + : ConcreteType<'b> + = + let generics = x._Generics |> List.mapi f + + { + _AssemblyName = x._AssemblyName + _Definition = x._Definition + _Generics = generics + } diff --git a/WoofWare.PawPrint/EvalStack.fs b/WoofWare.PawPrint/EvalStack.fs index e4241f2..b0ff251 100644 --- a/WoofWare.PawPrint/EvalStack.fs +++ b/WoofWare.PawPrint/EvalStack.fs @@ -75,7 +75,10 @@ module EvalStackValue = | CliNumericType.Int64 int64 -> failwith "todo" | CliNumericType.NativeInt int64 -> failwith "todo" | CliNumericType.NativeFloat f -> failwith "todo" - | CliNumericType.Int8 b -> failwith "todo" + | CliNumericType.Int8 _ -> + match popped with + | EvalStackValue.Int32 i -> CliType.Numeric (CliNumericType.Int8 (i % 256 |> int8)) + | i -> failwith $"TODO: %O{i}" | CliNumericType.Int16 s -> failwith "todo" | CliNumericType.UInt8 b -> failwith "todo" | CliNumericType.UInt16 s -> failwith "todo" diff --git a/WoofWare.PawPrint/IlMachineState.fs b/WoofWare.PawPrint/IlMachineState.fs index 6a39ef7..2b558a2 100644 --- a/WoofWare.PawPrint/IlMachineState.fs +++ b/WoofWare.PawPrint/IlMachineState.fs @@ -1,5 +1,6 @@ namespace WoofWare.PawPrint +open System open System.Collections.Immutable open System.IO open System.Reflection @@ -21,16 +22,12 @@ type IlMachineState = _LoadedAssemblies : ImmutableDictionary /// Tracks initialization state of types across assemblies TypeInitTable : TypeInitTable - Statics : ImmutableDictionary> + /// For each type, specialised to each set of generic args, a map of string field name to static value contained therein. + Statics : ImmutableDictionary> DotnetRuntimeDirs : string ImmutableArray } - member this.SetStatic - (ty : TypeDefinitionHandle * AssemblyName) - (field : string) - (value : CliType) - : IlMachineState - = + member this.SetStatic (ty : RuntimeConcreteType) (field : string) (value : CliType) : IlMachineState = let statics = match this.Statics.TryGetValue ty with | false, _ -> this.Statics.Add (ty, ImmutableDictionary.Create().Add (field, value)) @@ -40,31 +37,29 @@ type IlMachineState = Statics = statics } - member this.WithTypeBeginInit (thread : ThreadId) (handle : TypeDefinitionHandle, assy : AssemblyName) = + member this.WithTypeBeginInit (thread : ThreadId) (ty : RuntimeConcreteType) = this.Logger.LogDebug ( - "Beginning initialisation of type {TypeName}, handle {TypeDefinitionHandle} from assy {AssemblyHash}", - this.LoadedAssembly(assy).Value.TypeDefs.[handle].Name, - handle.GetHashCode (), - assy.GetHashCode () + "Beginning initialisation of type {s_Assembly}.{TypeName}, handle {TypeDefinitionHandle}", + ty.Assembly.FullName, + this.LoadedAssembly(ty.Assembly).Value.TypeDefs.[ty.Definition.Get].Name, + ty.Definition.Get.GetHashCode () ) - let typeInitTable = - this.TypeInitTable |> TypeInitTable.beginInitialising thread (handle, assy) + let typeInitTable = this.TypeInitTable |> TypeInitTable.beginInitialising thread ty { this with TypeInitTable = typeInitTable } - member this.WithTypeEndInit (thread : ThreadId) (handle : TypeDefinitionHandle, assy : AssemblyName) = + member this.WithTypeEndInit (thread : ThreadId) (ty : RuntimeConcreteType) = this.Logger.LogDebug ( - "Marking complete initialisation of type {TypeName}, handle {TypeDefinitionHandle} from assy {AssemblyHash}", - this.LoadedAssembly(assy).Value.TypeDefs.[handle].Name, - handle.GetHashCode (), - assy.GetHashCode () + "Marking complete initialisation of type {s_Assembly}.{TypeName}, handle {TypeDefinitionHandle}", + ty.Assembly.FullName, + this.LoadedAssembly(ty.Assembly).Value.TypeDefs.[ty.Definition.Get].Name, + ty.Definition.Get.GetHashCode () ) - let typeInitTable = - this.TypeInitTable |> TypeInitTable.markInitialised thread (handle, assy) + let typeInitTable = this.TypeInitTable |> TypeInitTable.markInitialised thread ty { this with TypeInitTable = typeInitTable @@ -75,11 +70,13 @@ type IlMachineState = _LoadedAssemblies = this._LoadedAssemblies.Add (name.FullName, value) } - member this.LoadedAssembly (name : AssemblyName) : DumpedAssembly option = - match this._LoadedAssemblies.TryGetValue name.FullName with + member this.LoadedAssembly' (fullName : string) : DumpedAssembly option = + match this._LoadedAssemblies.TryGetValue fullName with | false, _ -> None | true, v -> Some v + member this.LoadedAssembly (name : AssemblyName) : DumpedAssembly option = this.LoadedAssembly' name.FullName + /// Returns also the original assembly name. member this.WithThreadSwitchedToAssembly (assy : AssemblyName) (thread : ThreadId) : IlMachineState * AssemblyName = let mutable existing = Unchecked.defaultof @@ -263,7 +260,7 @@ module IlMachineState = | None -> state, assy, generic, Some args - | TypeDefn.FromDefinition (defn, _typeKind) -> state, assy, assy.TypeDefs.[defn], None + | TypeDefn.FromDefinition (defn, _typeKind) -> state, assy, assy.TypeDefs.[defn.Get], None | s -> failwith $"TODO: resolveTypeFromDefn unimplemented for {s}" let resolveTypeFromSpec @@ -303,11 +300,11 @@ module IlMachineState = let callMethod (loggerFactory : ILoggerFactory) - (wasInitialising : (TypeDefinitionHandle * AssemblyName) option) + (wasInitialising : RuntimeConcreteType option) (wasConstructing : ManagedHeapAddress option) (wasClassConstructor : bool) - (generics : ImmutableArray option) - (methodToCall : WoofWare.PawPrint.MethodInfo) + (methodGenerics : ImmutableArray option) + (methodToCall : WoofWare.PawPrint.MethodInfo) (thread : ThreadId) (threadState : ThreadState) (state : IlMachineState) @@ -321,7 +318,7 @@ module IlMachineState = loggerFactory (state.ActiveAssembly thread) ty - (generics |> Option.defaultValue ImmutableArray.Empty) + (methodGenerics |> Option.defaultValue ImmutableArray.Empty) state state, zero :: zeros @@ -353,6 +350,7 @@ module IlMachineState = state._LoadedAssemblies (state.ActiveAssembly thread) methodToCall + methodGenerics (args.ToImmutable ()) (Some { @@ -369,7 +367,7 @@ module IlMachineState = let state, _, _ = loadAssembly loggerFactory - (state.LoadedAssembly (snd methodToCall.DeclaringType) |> Option.get) + (state.LoadedAssembly methodToCall.DeclaringType.Assembly |> Option.get) toLoad.Handle state @@ -413,6 +411,7 @@ module IlMachineState = state._LoadedAssemblies (state.ActiveAssembly thread) methodToCall + methodGenerics (args.ToImmutable ()) (Some { @@ -429,7 +428,7 @@ module IlMachineState = let state, _, _ = loadAssembly loggerFactory - (state.LoadedAssembly (snd methodToCall.DeclaringType) |> Option.get) + (state.LoadedAssembly methodToCall.DeclaringType.Assembly |> Option.get) toLoad.Handle state @@ -453,18 +452,14 @@ module IlMachineState = let rec loadClass (loggerFactory : ILoggerFactory) - (typeDefHandle : TypeDefinitionHandle) - (assemblyName : AssemblyName) + (ty : RuntimeConcreteType) (currentThread : ThreadId) (state : IlMachineState) : StateLoadResult = - if typeDefHandle.IsNil then - failwith "Called `loadClass` with a nil typedef" - let logger = loggerFactory.CreateLogger "LoadClass" - match TypeInitTable.tryGet (typeDefHandle, assemblyName) state.TypeInitTable with + match TypeInitTable.tryGet ty state.TypeInitTable with | Some TypeInitState.Initialized -> // Type already initialized; nothing to do StateLoadResult.NothingToDo state @@ -480,19 +475,19 @@ module IlMachineState = // We have work to do! let state, origAssyName = - state.WithThreadSwitchedToAssembly assemblyName currentThread + state.WithThreadSwitchedToAssembly ty.Assembly currentThread - let sourceAssembly = state.LoadedAssembly assemblyName |> Option.get + let sourceAssembly = state.LoadedAssembly ty.Assembly |> Option.get let typeDef = - match sourceAssembly.TypeDefs.TryGetValue typeDefHandle with - | false, _ -> failwith $"Failed to find type definition {typeDefHandle} in {assemblyName.Name}" + match sourceAssembly.TypeDefs.TryGetValue ty.Definition.Get with + | false, _ -> failwith $"Failed to find type definition {ty.Definition.Get} in {ty.Assembly.FullName}" | true, v -> v logger.LogDebug ("Resolving type {TypeDefNamespace}.{TypeDefName}", typeDef.Namespace, typeDef.Name) // First mark as in-progress to detect cycles - let state = state.WithTypeBeginInit currentThread (typeDefHandle, assemblyName) + let state = state.WithTypeBeginInit currentThread ty // Check if the type has a base type that needs initialization let firstDoBaseClass = @@ -500,17 +495,17 @@ module IlMachineState = | Some baseTypeInfo -> // Determine if base type is in the same or different assembly match baseTypeInfo with - | ForeignAssemblyType (baseAssemblyName, baseTypeHandle) -> - logger.LogDebug ( - "Resolved base type of {TypeDefNamespace}.{TypeDefName} to foreign assembly {ForeignAssemblyName}", - typeDef.Namespace, - typeDef.Name, - baseAssemblyName.Name - ) + | ForeignAssemblyType _ -> failwith "TODO" + //logger.LogDebug ( + // "Resolved base type of {TypeDefNamespace}.{TypeDefName} to foreign assembly {ForeignAssemblyName}", + // typeDef.Namespace, + // typeDef.Name, + // baseAssemblyName.Name + //) - match loadClass loggerFactory baseTypeHandle baseAssemblyName currentThread state with - | FirstLoadThis state -> Error state - | NothingToDo state -> Ok state + //match loadClass loggerFactory baseTypeHandle baseAssemblyName currentThread state with + //| FirstLoadThis state -> Error state + //| NothingToDo state -> Ok state | TypeDef typeDefinitionHandle -> logger.LogDebug ( "Resolved base type of {TypeDefNamespace}.{TypeDefName} to this assembly, typedef", @@ -518,7 +513,10 @@ module IlMachineState = typeDef.Name ) - match loadClass loggerFactory typeDefinitionHandle assemblyName currentThread state with + // TypeDef won't have any generics; it would be a TypeSpec if it did + let ty = ConcreteType.make ty.Assembly typeDefinitionHandle [] + + match loadClass loggerFactory ty currentThread state with | FirstLoadThis state -> Error state | NothingToDo state -> Ok state | TypeRef typeReferenceHandle -> @@ -534,7 +532,10 @@ module IlMachineState = targetType.Name ) - match loadClass loggerFactory targetType.TypeDefHandle assy.Name currentThread state with + // TypeRef won't have any generics; it would be a TypeSpec if it did + let ty = ConcreteType.make assy.Name targetType.TypeDefHandle [] + + match loadClass loggerFactory ty currentThread state with | FirstLoadThis state -> Error state | NothingToDo state -> Ok state | TypeSpec typeSpecificationHandle -> failwith "TODO: TypeSpec base type loading unimplemented" @@ -552,20 +553,23 @@ module IlMachineState = |> List.tryFind (fun method -> method.Name = ".cctor" && method.IsStatic && method.Parameters.IsEmpty) match cctor with - | Some ctorMethod -> + | Some cctorMethod -> // Call the class constructor! Note that we *don't* use `callMethodInActiveAssembly`, because that // performs class loading, but we're already in the middle of loading this class. // TODO: factor out the common bit. let currentThreadState = state.ThreadState.[currentThread] + let cctorMethod = + cctorMethod |> MethodInfo.mapTypeGenerics (fun i _ -> ty.Generics.[i]) + callMethod loggerFactory - (Some (typeDefHandle, assemblyName)) + (Some ty) None true // constructor is surely not generic None - ctorMethod + cctorMethod currentThread currentThreadState state @@ -573,7 +577,7 @@ module IlMachineState = | None -> // No constructor, just continue. // Mark the type as initialized. - let state = state.WithTypeEndInit currentThread (typeDefHandle, assemblyName) + let state = state.WithTypeEndInit currentThread ty // Restore original assembly context if needed state.WithThreadSwitchedToAssembly origAssyName currentThread @@ -583,13 +587,13 @@ module IlMachineState = let ensureTypeInitialised (loggerFactory : ILoggerFactory) (thread : ThreadId) - (ty : TypeDefinitionHandle * AssemblyName) + (ty : RuntimeConcreteType) (state : IlMachineState) : IlMachineState * WhatWeDid = match TypeInitTable.tryGet ty state.TypeInitTable with | None -> - match loadClass loggerFactory (fst ty) (snd ty) thread state with + match loadClass loggerFactory ty thread state with | NothingToDo state -> state, WhatWeDid.Executed | FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit | Some TypeInitState.Initialized -> state, WhatWeDid.Executed @@ -603,8 +607,8 @@ module IlMachineState = let callMethodInActiveAssembly (loggerFactory : ILoggerFactory) (thread : ThreadId) - (generics : TypeDefn ImmutableArray option) - (methodToCall : WoofWare.PawPrint.MethodInfo) + (methodGenerics : TypeDefn ImmutableArray option) + (methodToCall : WoofWare.PawPrint.MethodInfo) (weAreConstructingObj : ManagedHeapAddress option) (state : IlMachineState) : IlMachineState * WhatWeDid @@ -616,7 +620,16 @@ module IlMachineState = match typeInit with | WhatWeDid.Executed -> - callMethod loggerFactory None weAreConstructingObj false generics methodToCall thread threadState state, + callMethod + loggerFactory + None + weAreConstructingObj + false + methodGenerics + methodToCall + thread + threadState + state, WhatWeDid.Executed | _ -> state, typeInit @@ -844,7 +857,7 @@ module IlMachineState = (assy : DumpedAssembly) (m : MemberReferenceHandle) (state : IlMachineState) - : IlMachineState * AssemblyName * Choice + : IlMachineState * AssemblyName * Choice, WoofWare.PawPrint.FieldInfo> = // TODO: do we need to initialise the parent class here? let mem = assy.Members.[m] @@ -887,7 +900,7 @@ module IlMachineState = | [] -> failwith $"Could not find member {memberName} with the right signature on {targetType.Namespace}.{targetType.Name}" - | [ x ] -> x + | [ x ] -> x |> MethodInfo.mapTypeGenerics (fun i _ -> targetType.Generics.[i]) | _ -> failwith $"Multiple overloads matching signature for call to {targetType.Namespace}.{targetType.Name}'s {memberName}!" @@ -922,9 +935,8 @@ module IlMachineState = { threadStateAtEndOfMethod with ActiveMethodState = returnState.JumpTo ActiveAssembly = - snd - threadStateAtEndOfMethod.MethodStates.[returnState.JumpTo].ExecutingMethod - .DeclaringType + threadStateAtEndOfMethod.MethodStates.[returnState.JumpTo].ExecutingMethod.DeclaringType + .Assembly } } diff --git a/WoofWare.PawPrint/MethodInfo.fs b/WoofWare.PawPrint/MethodInfo.fs index 308a320..b81658a 100644 --- a/WoofWare.PawPrint/MethodInfo.fs +++ b/WoofWare.PawPrint/MethodInfo.fs @@ -145,12 +145,12 @@ type MethodInstructions = /// Represents detailed information about a method in a .NET assembly. /// This is a strongly-typed representation of MethodDefinition from System.Reflection.Metadata. /// -type MethodInfo = +type MethodInfo<'typeGenerics when 'typeGenerics :> IComparable<'typeGenerics> and 'typeGenerics : comparison> = { /// /// The type that declares this method, along with its assembly information. /// - DeclaringType : TypeDefinitionHandle * AssemblyName + DeclaringType : ConcreteType<'typeGenerics> /// /// The metadata token handle that uniquely identifies this method in the assembly. @@ -212,6 +212,26 @@ type MethodInfo = [] module MethodInfo = + let mapTypeGenerics<'a, 'b + when 'a :> IComparable<'a> and 'a : comparison and 'b : comparison and 'b :> IComparable<'b>> + (f : int -> 'a -> 'b) + (m : MethodInfo<'a>) + : MethodInfo<'b> + = + { + DeclaringType = m.DeclaringType |> ConcreteType.mapGeneric f + Handle = m.Handle + Name = m.Name + Instructions = m.Instructions + Parameters = m.Parameters + Generics = m.Generics + Signature = m.Signature + CustomAttributes = m.CustomAttributes + MethodAttributes = m.MethodAttributes + ImplAttributes = m.ImplAttributes + IsStatic = m.IsStatic + } + type private Dummy = class end type private MethodBody = @@ -558,7 +578,7 @@ module MethodInfo = (peReader : PEReader) (metadataReader : MetadataReader) (methodHandle : MethodDefinitionHandle) - : MethodInfo option + : MethodInfo option = let logger = loggerFactory.CreateLogger "MethodInfo" let assemblyName = metadataReader.GetAssemblyDefinition().GetAssemblyName () @@ -592,6 +612,9 @@ module MethodInfo = let declaringType = methodDef.GetDeclaringType () + let declaringTypeGenericParams = + metadataReader.GetTypeDefinition(declaringType).GetGenericParameters().Count + let attrs = let result = ImmutableArray.CreateBuilder () let attrs = methodDef.GetCustomAttributes () @@ -611,7 +634,7 @@ module MethodInfo = GenericParameter.readAll metadataReader (methodDef.GetGenericParameters ()) { - DeclaringType = (declaringType, assemblyName) + DeclaringType = ConcreteType.make' assemblyName declaringType declaringTypeGenericParams Handle = methodHandle Name = methodName Instructions = methodBody @@ -624,3 +647,47 @@ module MethodInfo = ImplAttributes = implAttrs } |> Some + + let rec resolveBaseType + (methodGenerics : TypeDefn ImmutableArray option) + (executingMethod : MethodInfo) + (td : TypeDefn) + : ResolvedBaseType + = + match td with + | TypeDefn.Void -> failwith "Void isn't a type that appears at runtime and has no base type" + | TypeDefn.PrimitiveType ty -> + match ty with + | PrimitiveType.SByte + | PrimitiveType.Byte + | PrimitiveType.Int16 + | PrimitiveType.UInt16 + | PrimitiveType.Int32 + | PrimitiveType.UInt32 + | PrimitiveType.Int64 + | PrimitiveType.UInt64 + | PrimitiveType.Single + | PrimitiveType.Double + | PrimitiveType.Char + | PrimitiveType.Boolean -> ResolvedBaseType.ValueType + | PrimitiveType.String -> ResolvedBaseType.Object + | PrimitiveType.TypedReference -> failwith "todo" + | PrimitiveType.IntPtr -> failwith "todo" + | PrimitiveType.UIntPtr -> failwith "todo" + | PrimitiveType.Object -> failwith "todo" + | TypeDefn.Array (elt, shape) -> failwith "todo" + | TypeDefn.Pinned typeDefn -> failwith "todo" + | TypeDefn.Pointer typeDefn -> failwith "todo" + | TypeDefn.Byref typeDefn -> failwith "todo" + | TypeDefn.OneDimensionalArrayLowerBoundZero elements -> failwith "todo" + | TypeDefn.Modified (original, afterMod, modificationRequired) -> failwith "todo" + | TypeDefn.FromReference (typeRef, signatureTypeKind) -> failwith "todo" + | TypeDefn.FromDefinition (comparableTypeDefinitionHandle, signatureTypeKind) -> failwith "todo" + | TypeDefn.GenericInstantiation (generic, args) -> failwith "todo" + | TypeDefn.FunctionPointer typeMethodSignature -> failwith "todo" + | TypeDefn.GenericTypeParameter index -> + resolveBaseType methodGenerics executingMethod executingMethod.DeclaringType.Generics.[index] + | TypeDefn.GenericMethodParameter index -> + match methodGenerics with + | None -> failwith "unexpectedly asked for a generic method parameter when we had none" + | Some generics -> resolveBaseType methodGenerics executingMethod generics.[index] diff --git a/WoofWare.PawPrint/MethodState.fs b/WoofWare.PawPrint/MethodState.fs index 2889463..6cff217 100644 --- a/WoofWare.PawPrint/MethodState.fs +++ b/WoofWare.PawPrint/MethodState.fs @@ -1,14 +1,12 @@ namespace WoofWare.PawPrint open System.Collections.Immutable -open System.Reflection -open System.Reflection.Metadata type MethodReturnState = { /// Index in the MethodStates array of a ThreadState JumpTo : int - WasInitialisingType : (TypeDefinitionHandle * AssemblyName) option + WasInitialisingType : RuntimeConcreteType option /// The Newobj instruction means we need to push a reference immediately after Ret. WasConstructingObj : ManagedHeapAddress option } @@ -21,11 +19,12 @@ and MethodState = IlOpIndex : int EvaluationStack : EvalStack Arguments : CliType ImmutableArray - ExecutingMethod : WoofWare.PawPrint.MethodInfo + ExecutingMethod : WoofWare.PawPrint.MethodInfo /// We don't implement the local memory pool right now LocalMemoryPool : unit /// On return, we restore this state. This should be Some almost always; an exception is the entry point. ReturnState : MethodReturnState option + Generics : ImmutableArray option } static member jumpProgramCounter (bytes : int) (state : MethodState) = @@ -104,7 +103,8 @@ and MethodState = static member Empty (loadedAssemblies : ImmutableDictionary) (containingAssembly : DumpedAssembly) - (method : WoofWare.PawPrint.MethodInfo) + (method : WoofWare.PawPrint.MethodInfo) + (methodGenerics : ImmutableArray option) (args : ImmutableArray) (returnState : MethodReturnState option) : Result @@ -154,5 +154,6 @@ and MethodState = ExecutingMethod = method LocalMemoryPool = () ReturnState = returnState + Generics = methodGenerics } |> Ok diff --git a/WoofWare.PawPrint/Program.fs b/WoofWare.PawPrint/Program.fs index a415ce1..04d21d2 100644 --- a/WoofWare.PawPrint/Program.fs +++ b/WoofWare.PawPrint/Program.fs @@ -65,6 +65,10 @@ module Program = if mainMethod.Signature.GenericParameterCount > 0 then failwith "Refusing to execute generic main method" + let mainMethod = + mainMethod + |> MethodInfo.mapTypeGenerics (fun _ -> failwith "Refusing to execute generic main method") + let state, mainThread = IlMachineState.initial loggerFactory dotnetRuntimeDirs dumped // The thread's state is slightly fake: we will need to put arguments onto the stack before actually @@ -78,6 +82,7 @@ module Program = s._LoadedAssemblies dumped mainMethod + None (ImmutableArray.CreateRange [ CliType.ObjectRef None ]) None with @@ -87,11 +92,7 @@ module Program = let rec loadInitialState (state : IlMachineState) = match state - |> IlMachineState.loadClass - loggerFactory - (fst mainMethod.DeclaringType) - (snd mainMethod.DeclaringType) - mainThread + |> IlMachineState.loadClass loggerFactory mainMethod.DeclaringType mainThread with | StateLoadResult.NothingToDo ilMachineState -> ilMachineState | StateLoadResult.FirstLoadThis ilMachineState -> loadInitialState ilMachineState @@ -126,6 +127,7 @@ module Program = state._LoadedAssemblies dumped mainMethod + None (ImmutableArray.Create (CliType.OfManagedObject arrayAllocation)) None with diff --git a/WoofWare.PawPrint/TypeDefn.fs b/WoofWare.PawPrint/TypeDefn.fs index ff45dfe..7fdf2e7 100644 --- a/WoofWare.PawPrint/TypeDefn.fs +++ b/WoofWare.PawPrint/TypeDefn.fs @@ -3,6 +3,13 @@ namespace WoofWare.PawPrint open System.Collections.Immutable open System.Reflection.Metadata open System.Reflection.Metadata.Ecma335 +open Microsoft.FSharp.Core + +type ResolvedBaseType = + | Enum + | ValueType + | Object + | Delegate /// /// Represents a method signature with type parameters. @@ -13,7 +20,7 @@ type TypeMethodSignature<'Types> = /// /// Contains calling convention and other method attributes encoded in the metadata. /// - Header : SignatureHeader + Header : ComparableSignatureHeader /// /// The types of all parameters of the method. @@ -40,7 +47,7 @@ type TypeMethodSignature<'Types> = module TypeMethodSignature = let make<'T> (p : MethodSignature<'T>) : TypeMethodSignature<'T> = { - Header = p.Header + Header = ComparableSignatureHeader.Make p.Header ReturnType = p.ReturnType ParameterTypes = List.ofSeq p.ParameterTypes GenericParameterCount = p.GenericParameterCount @@ -91,14 +98,15 @@ type PrimitiveType = type TypeDefn = | PrimitiveType of PrimitiveType - | Array of elt : TypeDefn * shape : ArrayShape + // TODO: array shapes + | Array of elt : TypeDefn * shape : unit | Pinned of TypeDefn | Pointer of TypeDefn | Byref of TypeDefn | OneDimensionalArrayLowerBoundZero of elements : TypeDefn | Modified of original : TypeDefn * afterMod : TypeDefn * modificationRequired : bool | FromReference of TypeRef * SignatureTypeKind - | FromDefinition of TypeDefinitionHandle * SignatureTypeKind + | FromDefinition of ComparableTypeDefinitionHandle * SignatureTypeKind | GenericInstantiation of generic : TypeDefn * args : ImmutableArray | FunctionPointer of TypeMethodSignature | GenericTypeParameter of index : int @@ -169,7 +177,7 @@ module TypeDefn = let typeProvider : ISignatureTypeProvider = { new ISignatureTypeProvider with member this.GetArrayType (elementType : TypeDefn, shape : ArrayShape) : TypeDefn = - TypeDefn.Array (elementType, shape) + TypeDefn.Array (elementType, ()) member this.GetByReferenceType (elementType : TypeDefn) : TypeDefn = TypeDefn.Byref elementType @@ -194,7 +202,7 @@ module TypeDefn = let handle' : EntityHandle = TypeDefinitionHandle.op_Implicit handle let typeKind = reader.ResolveSignatureTypeKind (handle', rawTypeKind) - TypeDefn.FromDefinition (handle, typeKind) + TypeDefn.FromDefinition (ComparableTypeDefinitionHandle.Make handle, typeKind) member this.GetTypeFromReference (reader : MetadataReader, handle : TypeReferenceHandle, rawTypeKind : byte) diff --git a/WoofWare.PawPrint/TypeInfo.fs b/WoofWare.PawPrint/TypeInfo.fs index cf0be63..2c28c08 100644 --- a/WoofWare.PawPrint/TypeInfo.fs +++ b/WoofWare.PawPrint/TypeInfo.fs @@ -14,12 +14,6 @@ type BaseTypeInfo = | TypeSpec of TypeSpecificationHandle | ForeignAssemblyType of assemblyName : AssemblyName * TypeDefinitionHandle -type ResolvedBaseType = - | Enum - | ValueType - | Object - | Delegate - type MethodImplParsed = | MethodImplementation of MethodImplementationHandle | MethodDefinition of MethodDefinitionHandle @@ -39,7 +33,7 @@ type TypeInfo<'generic> = /// /// All methods defined within this type. /// - Methods : WoofWare.PawPrint.MethodInfo list + Methods : WoofWare.PawPrint.MethodInfo list /// /// Method implementation mappings for this type, often used for interface implementations diff --git a/WoofWare.PawPrint/TypeInitialisation.fs b/WoofWare.PawPrint/TypeInitialisation.fs index 8071580..32da81e 100644 --- a/WoofWare.PawPrint/TypeInitialisation.fs +++ b/WoofWare.PawPrint/TypeInitialisation.fs @@ -11,32 +11,22 @@ type TypeInitState = /// Tracks the initialization state of types across assemblies. The string in the key is the FullName of the AssemblyName where the type comes from. // TODO: need a better solution than string here! AssemblyName didn't work, we had nonequal assembly names. -type TypeInitTable = ImmutableDictionary +type TypeInitTable = ImmutableDictionary [] module TypeInitTable = - let tryGet (typeDef : TypeDefinitionHandle, assy : AssemblyName) (t : TypeInitTable) = - match t.TryGetValue ((typeDef, assy.FullName)) with + let tryGet (ty : RuntimeConcreteType) (t : TypeInitTable) = + match t.TryGetValue ty with | true, v -> Some v | false, _ -> None - let beginInitialising - (thread : ThreadId) - (typeDef : TypeDefinitionHandle, assy : AssemblyName) - (t : TypeInitTable) - : TypeInitTable - = - match t.TryGetValue ((typeDef, assy.FullName)) with - | false, _ -> t.Add ((typeDef, assy.FullName), TypeInitState.InProgress thread) + let beginInitialising (thread : ThreadId) (ty : RuntimeConcreteType) (t : TypeInitTable) : TypeInitTable = + match t.TryGetValue ty with + | false, _ -> t.Add (ty, TypeInitState.InProgress thread) | true, v -> failwith "Logic error: tried initialising a type which has already started initialising" - let markInitialised - (thread : ThreadId) - (typeDef : TypeDefinitionHandle, assy : AssemblyName) - (t : TypeInitTable) - : TypeInitTable - = - match t.TryGetValue ((typeDef, assy.FullName)) with + let markInitialised (thread : ThreadId) (ty : RuntimeConcreteType) (t : TypeInitTable) : TypeInitTable = + match t.TryGetValue ty with | false, _ -> failwith "Logic error: completing initialisation of a type which never started initialising" | true, TypeInitState.Initialized -> failwith "Logic error: completing initialisation of a type which has already finished initialising" @@ -45,4 +35,4 @@ module TypeInitTable = failwith "Logic error: completed initialisation of a type on a different thread to the one which started it!" else - t.SetItem ((typeDef, assy.FullName), TypeInitState.Initialized) + t.SetItem (ty, TypeInitState.Initialized) diff --git a/WoofWare.PawPrint/TypeRef.fs b/WoofWare.PawPrint/TypeRef.fs index f573dff..50ae5f4 100644 --- a/WoofWare.PawPrint/TypeRef.fs +++ b/WoofWare.PawPrint/TypeRef.fs @@ -1,12 +1,60 @@ namespace WoofWare.PawPrint +open System open System.Reflection.Metadata +open Microsoft.FSharp.Core +[] +[] type TypeRefResolutionScope = | Assembly of AssemblyReferenceHandle | ModuleRef of ModuleReferenceHandle | TypeRef of TypeReferenceHandle + override this.Equals (other : obj) : bool = + let other = + match other with + | :? TypeRefResolutionScope as other -> other + | _ -> failwith "should never compare with non-TypeRefResolutionScope" + + match this, other with + | TypeRefResolutionScope.Assembly a1, TypeRefResolutionScope.Assembly a2 -> a1 = a2 + | TypeRefResolutionScope.Assembly _, _ -> false + | TypeRefResolutionScope.ModuleRef m1, TypeRefResolutionScope.ModuleRef m2 -> m1 = m2 + | TypeRefResolutionScope.ModuleRef _, _ -> false + | TypeRefResolutionScope.TypeRef t1, TypeRefResolutionScope.TypeRef t2 -> t1 = t2 + | TypeRefResolutionScope.TypeRef _, _ -> false + + override this.GetHashCode () : int = + match this with + | TypeRefResolutionScope.Assembly h -> hash (1, h) + | TypeRefResolutionScope.ModuleRef h -> hash (2, h) + | TypeRefResolutionScope.TypeRef h -> hash (3, h) + + interface IComparable with + member this.CompareTo other = + match this, other with + | TypeRefResolutionScope.Assembly h1, TypeRefResolutionScope.Assembly h2 -> + // this happens to get the underlying int + h1.GetHashCode().CompareTo (h2.GetHashCode ()) + | TypeRefResolutionScope.Assembly _, TypeRefResolutionScope.ModuleRef _ -> -1 + | TypeRefResolutionScope.Assembly _, TypeRefResolutionScope.TypeRef _ -> -1 + | TypeRefResolutionScope.ModuleRef _, Assembly _ -> 1 + | TypeRefResolutionScope.ModuleRef m1, ModuleRef m2 -> m1.GetHashCode().CompareTo (m2.GetHashCode ()) + | TypeRefResolutionScope.ModuleRef _, TypeRef _ -> -1 + | TypeRefResolutionScope.TypeRef _, Assembly _ -> 1 + | TypeRefResolutionScope.TypeRef _, ModuleRef _ -> 1 + | TypeRefResolutionScope.TypeRef t1, TypeRef t2 -> t1.GetHashCode().CompareTo (t2.GetHashCode ()) + + interface IComparable with + member this.CompareTo (other : obj) : int = + let other = + match other with + | :? TypeRefResolutionScope as other -> other + | _ -> failwith "unexpectedly comparing TypeRefResolutionScope with something else" + + (this :> IComparable).CompareTo other + /// /// Represents a type reference in a .NET assembly metadata. /// This corresponds to a TypeReferenceHandle in System.Reflection.Metadata. diff --git a/WoofWare.PawPrint/UnaryMetadataIlOp.fs b/WoofWare.PawPrint/UnaryMetadataIlOp.fs index 26b78c5..c76dd93 100644 --- a/WoofWare.PawPrint/UnaryMetadataIlOp.fs +++ b/WoofWare.PawPrint/UnaryMetadataIlOp.fs @@ -17,14 +17,20 @@ module internal UnaryMetadataIlOp = = match op with | Call -> - let state, methodToCall, generics = + let activeAssy = state.ActiveAssembly thread + + let state, methodToCall, methodGenerics = match metadataToken with | MetadataToken.MethodSpecification h -> - let spec = (state.ActiveAssembly thread).MethodSpecs.[h] + let spec = activeAssy.MethodSpecs.[h] match spec.Method with | MetadataToken.MethodDef token -> - state, (state.ActiveAssembly thread).Methods.[token], Some spec.Signature + let method = + activeAssy.Methods.[token] + |> MethodInfo.mapTypeGenerics (fun i _ -> spec.Signature.[i]) + + state, method, Some spec.Signature | MetadataToken.MemberReference ref -> let state, _, method = IlMachineState.resolveMember loggerFactory (state.ActiveAssembly thread) ref state @@ -42,25 +48,18 @@ module internal UnaryMetadataIlOp = | Choice1Of2 method -> state, method, None | MetadataToken.MethodDef defn -> - let activeAssy = state.ActiveAssembly thread - match activeAssy.Methods.TryGetValue defn with - | true, method -> state, method, None + | true, method -> + let method = method |> MethodInfo.mapTypeGenerics (fun _ -> failwith "not generic") + state, method, None | false, _ -> failwith $"could not find method in {activeAssy.Name}" | k -> failwith $"Unrecognised kind: %O{k}" - match - IlMachineState.loadClass - loggerFactory - (fst methodToCall.DeclaringType) - (snd methodToCall.DeclaringType) - thread - state - with + match IlMachineState.loadClass loggerFactory methodToCall.DeclaringType thread state with | NothingToDo state -> - state.WithThreadSwitchedToAssembly (snd methodToCall.DeclaringType) thread + state.WithThreadSwitchedToAssembly methodToCall.DeclaringType.Assembly thread |> fst - |> IlMachineState.callMethodInActiveAssembly loggerFactory thread generics methodToCall None + |> IlMachineState.callMethodInActiveAssembly loggerFactory thread methodGenerics methodToCall None | FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit | Callvirt -> @@ -82,8 +81,8 @@ module internal UnaryMetadataIlOp = | Some obj -> obj do - let assy = state.LoadedAssembly (snd method.DeclaringType) |> Option.get - let ty = assy.TypeDefs.[fst method.DeclaringType] + let assy = state.LoadedAssembly method.DeclaringType.Assembly |> Option.get + let ty = assy.TypeDefs.[method.DeclaringType.Definition.Get] logger.LogTrace ( "Calling method {Assembly}.{Type}.{CallvirtMethod} on object {CallvirtObject}", @@ -122,7 +121,11 @@ module internal UnaryMetadataIlOp = | EvalStackValue.ObjectRef managedHeapAddress -> failwith "todo" | _ -> failwith $"TODO (Callvirt): can't identify type of {currentObj}" - state.WithThreadSwitchedToAssembly (snd methodToCall.DeclaringType) thread + let methodToCall = + methodToCall + |> MethodInfo.mapTypeGenerics (fun _ -> failwith "TODO: look up generics from runtime type information") + + state.WithThreadSwitchedToAssembly methodToCall.DeclaringType.Assembly thread |> fst |> IlMachineState.callMethodInActiveAssembly loggerFactory thread generics methodToCall None | Castclass -> failwith "TODO: Castclass unimplemented" @@ -134,7 +137,7 @@ module internal UnaryMetadataIlOp = | MethodDef md -> let activeAssy = state.ActiveAssembly thread let method = activeAssy.Methods.[md] - state, activeAssy.Name, method + state, activeAssy.Name, MethodInfo.mapTypeGenerics (fun _ -> failwith "non-generic method") method | MemberReference mr -> let state, name, method = IlMachineState.resolveMember loggerFactory (state.ActiveAssembly thread) mr state @@ -152,9 +155,8 @@ module internal UnaryMetadataIlOp = | WhatWeDid.SuspendedForClassInit -> state, SuspendedForClassInit | WhatWeDid.Executed -> - let ctorType, ctorAssembly = ctor.DeclaringType - let ctorAssembly = state.LoadedAssembly ctorAssembly |> Option.get - let ctorType = ctorAssembly.TypeDefs.[ctorType] + let ctorAssembly = state.LoadedAssembly ctor.DeclaringType.Assembly |> Option.get + let ctorType = ctorAssembly.TypeDefs.[ctor.DeclaringType.Definition.Get] do logger.LogDebug ( @@ -215,7 +217,7 @@ module internal UnaryMetadataIlOp = | EvalStackValue.Int32 v -> v | popped -> failwith $"unexpectedly popped value %O{popped} to serve as array len" - let elementType, baseType = + let baseType = match metadataToken with | MetadataToken.TypeDefinition defn -> let assy = state.LoadedAssembly currentState.ActiveAssembly |> Option.get @@ -229,11 +231,12 @@ module internal UnaryMetadataIlOp = baseClassTypes elementType.Assembly - elementType, baseType + baseType | MetadataToken.TypeSpecification spec -> let assy = state.LoadedAssembly currentState.ActiveAssembly |> Option.get - let elementType = assy.TypeSpecs.[spec] - failwith "" + let elementType = assy.TypeSpecs.[spec].Signature + + MethodInfo.resolveBaseType newMethodState.Generics newMethodState.ExecutingMethod elementType | x -> failwith $"TODO: Newarr element type resolution unimplemented for {x}" let zeroOfType = @@ -279,15 +282,20 @@ module internal UnaryMetadataIlOp = state, WhatWeDid.Executed | Stfld -> - let state, assyName, field = + let activeAssy = state.ActiveAssembly thread + + let state, declaringType, field = match metadataToken with | MetadataToken.FieldDefinition f -> - state, (state.ActiveAssembly thread).Name, state.ActiveAssembly(thread).Fields.[f] + let field = activeAssy.Fields.[f] + // No generics on a type if we're accessing it by FieldDefinition + let declaringType = ConcreteType.make activeAssy.Name field.DeclaringType [] + state, declaringType, field | t -> failwith $"Unexpectedly asked to store to a non-field: {t}" do let logger = loggerFactory.CreateLogger "Stfld" - let declaring = state.ActiveAssembly(thread).TypeDefs.[field.DeclaringType] + let declaring = activeAssy.TypeDefs.[field.DeclaringType] logger.LogInformation ( "Storing in object field {FieldAssembly}.{FieldDeclaringType}.{FieldName} (type {FieldType})", @@ -300,12 +308,11 @@ module internal UnaryMetadataIlOp = let valueToStore, state = IlMachineState.popEvalStack thread state let state, zero = - // TODO: generics IlMachineState.cliTypeZeroOf loggerFactory (state.ActiveAssembly thread) field.Signature - ImmutableArray.Empty + (ImmutableArray.CreateRange declaringType.Generics) state let valueToStore = EvalStackValue.toCliTypeCoerced zero valueToStore @@ -313,7 +320,7 @@ module internal UnaryMetadataIlOp = let currentObj, state = IlMachineState.popEvalStack thread state if field.Attributes.HasFlag FieldAttributes.Static then - let state = state.SetStatic (field.DeclaringType, assyName) field.Name valueToStore + let state = state.SetStatic declaringType field.Name valueToStore state, WhatWeDid.Executed else @@ -353,16 +360,29 @@ module internal UnaryMetadataIlOp = |> Tuple.withRight WhatWeDid.Executed | Stsfld -> - let fieldHandle = - match metadataToken with - | MetadataToken.FieldDefinition f -> f - | t -> failwith $"Unexpectedly asked to store to a non-field: {t}" - let activeAssy = state.ActiveAssembly thread - match activeAssy.Fields.TryGetValue fieldHandle with - | false, _ -> failwith "TODO: Stsfld - throw MissingFieldException" - | true, field -> + let state, field, declaringType = + match metadataToken with + | MetadataToken.FieldDefinition fieldHandle -> + match activeAssy.Fields.TryGetValue fieldHandle with + | false, _ -> failwith "TODO: Stsfld - throw MissingFieldException" + | true, field -> state, field, ConcreteType.make activeAssy.Name field.DeclaringType [] + | MetadataToken.MemberReference mr -> + let state, assy, method = + IlMachineState.resolveMember loggerFactory (state.ActiveAssembly thread) mr state + + match method with + | Choice1Of2 methodInfo -> + failwith $"unexpectedly asked to store to a non-field method: {methodInfo.Name}" + | Choice2Of2 fieldInfo -> + state, + fieldInfo, + ConcreteType.make + assy + fieldInfo.DeclaringType + (failwith "TODO: refactor FieldInfo to store a Runtime type") + | t -> failwith $"Unexpectedly asked to store to a non-field: {t}" do let logger = loggerFactory.CreateLogger "Stsfld" @@ -376,41 +396,57 @@ module internal UnaryMetadataIlOp = field.Signature ) - match IlMachineState.loadClass loggerFactory field.DeclaringType activeAssy.Name thread state with + match IlMachineState.loadClass loggerFactory declaringType thread state with | FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit | NothingToDo state -> let popped, state = IlMachineState.popEvalStack thread state let state, zero = - // TODO: generics - IlMachineState.cliTypeZeroOf loggerFactory activeAssy field.Signature ImmutableArray.Empty state + IlMachineState.cliTypeZeroOf + loggerFactory + activeAssy + field.Signature + (ImmutableArray.CreateRange declaringType.Generics) + state let toStore = EvalStackValue.toCliTypeCoerced zero popped let state = - state.SetStatic (field.DeclaringType, activeAssy.Name) field.Name toStore + state.SetStatic declaringType field.Name toStore |> IlMachineState.advanceProgramCounter thread state, WhatWeDid.Executed | Ldfld -> - let state, assyName, field = + let activeAssembly = state.ActiveAssembly thread + + let state, declaringType, field = match metadataToken with | MetadataToken.FieldDefinition f -> - state, (state.ActiveAssembly thread).Name, state.ActiveAssembly(thread).Fields.[f] + let declaringType = + ConcreteType.make activeAssembly.Name activeAssembly.Fields.[f].DeclaringType [] + + state, declaringType, activeAssembly.Fields.[f] | MetadataToken.MemberReference mr -> let state, assyName, field = - IlMachineState.resolveMember loggerFactory (state.ActiveAssembly thread) mr state + IlMachineState.resolveMember loggerFactory activeAssembly mr state match field with | Choice1Of2 _method -> failwith "member reference was unexpectedly a method" - | Choice2Of2 field -> state, assyName, field + | Choice2Of2 field -> + let parentTy = state.LoadedAssembly(assyName).Value.TypeDefs.[field.DeclaringType] + + if parentTy.Generics.Length > 0 then + failwith "oh no: generics" + + let declaringType = ConcreteType.make assyName field.DeclaringType [] + state, declaringType, field | t -> failwith $"Unexpectedly asked to load from a non-field: {t}" do let logger = loggerFactory.CreateLogger "Ldfld" - let declaring = state.ActiveAssembly(thread).TypeDefs.[field.DeclaringType] + let declaring = activeAssembly.TypeDefs.[field.DeclaringType] logger.LogInformation ( "Loading object field {FieldAssembly}.{FieldDeclaringType}.{FieldName} (type {FieldType})", @@ -423,7 +459,7 @@ module internal UnaryMetadataIlOp = let currentObj, state = IlMachineState.popEvalStack thread state if field.Attributes.HasFlag FieldAttributes.Static then - let staticField = state.Statics.[field.DeclaringType, assyName].[field.Name] + let staticField = state.Statics.[declaringType].[field.Name] let state = state |> IlMachineState.pushToEvalStack staticField thread state, WhatWeDid.Executed else @@ -458,19 +494,23 @@ module internal UnaryMetadataIlOp = | Ldsfld -> let logger = loggerFactory.CreateLogger "Ldsfld" - let fieldHandle = - match metadataToken with - | MetadataToken.FieldDefinition f -> f - | t -> failwith $"Unexpectedly asked to load from a non-field: {t}" - let activeAssy = state.ActiveAssembly thread - match activeAssy.Fields.TryGetValue fieldHandle with - | false, _ -> failwith "TODO: Ldsfld - throw MissingFieldException" - | true, field -> + let field, declaringType = + match metadataToken with + | MetadataToken.FieldDefinition fieldHandle -> + match activeAssy.Fields.TryGetValue fieldHandle with + | false, _ -> failwith "TODO: Ldsfld - throw MissingFieldException" + | true, field -> + // FieldDefinition won't come on a generic type + field, ConcreteType.make activeAssy.Name field.DeclaringType [] + | t -> failwith $"Unexpectedly asked to load from a non-field: {t}" do - let declaring = state.ActiveAssembly(thread).TypeDefs.[field.DeclaringType] + let declaring = + state.LoadedAssembly (declaringType.Assembly) + |> Option.get + |> fun a -> a.TypeDefs.[declaringType.Definition.Get] logger.LogInformation ( "Loading from static field {FieldAssembly}.{FieldDeclaringType}.{FieldName} (type {FieldType})", @@ -480,28 +520,35 @@ module internal UnaryMetadataIlOp = field.Signature ) - match IlMachineState.loadClass loggerFactory field.DeclaringType activeAssy.Name thread state with + match IlMachineState.loadClass loggerFactory declaringType thread state with | FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit | NothingToDo state -> - // TODO: generics - let generics = ImmutableArray.Empty - let fieldValue, state = - match state.Statics.TryGetValue ((field.DeclaringType, activeAssy.Name)) with + match state.Statics.TryGetValue declaringType with | false, _ -> let state, newVal = - IlMachineState.cliTypeZeroOf loggerFactory activeAssy field.Signature generics state + IlMachineState.cliTypeZeroOf + loggerFactory + activeAssy + field.Signature + (declaringType.Generics |> ImmutableArray.CreateRange) + state - newVal, state.SetStatic (field.DeclaringType, activeAssy.Name) field.Name newVal + newVal, state.SetStatic declaringType field.Name newVal | true, v -> match v.TryGetValue field.Name with | true, v -> v, state | false, _ -> let state, newVal = - IlMachineState.cliTypeZeroOf loggerFactory activeAssy field.Signature generics state + IlMachineState.cliTypeZeroOf + loggerFactory + activeAssy + field.Signature + (declaringType.Generics |> ImmutableArray.CreateRange) + state - newVal, state.SetStatic (field.DeclaringType, activeAssy.Name) field.Name newVal + newVal, state.SetStatic declaringType field.Name newVal do let logger = loggerFactory.CreateLogger "Ldsfld" @@ -527,51 +574,51 @@ module internal UnaryMetadataIlOp = | Ldelem -> failwith "TODO: Ldelem unimplemented" | Initobj -> failwith "TODO: Initobj unimplemented" | Ldsflda -> - // TODO: check whether we should throw FieldAccessException - let fieldHandle = - match metadataToken with - | MetadataToken.FieldDefinition f -> f - | t -> failwith $"Unexpectedly asked to load a non-field: {t}" - let activeAssy = state.ActiveAssembly thread - match activeAssy.Fields.TryGetValue fieldHandle with - | false, _ -> failwith "TODO: Ldsflda - throw MissingFieldException" - | true, field -> - match IlMachineState.loadClass loggerFactory field.DeclaringType activeAssy.Name thread state with - | FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit - | NothingToDo state -> + // TODO: check whether we should throw FieldAccessException - if TypeDefn.isManaged field.Signature then - let typeId = field.DeclaringType, activeAssy.Name + let field, declaringType = + match metadataToken with + | MetadataToken.FieldDefinition fieldHandle -> + match activeAssy.Fields.TryGetValue fieldHandle with + | false, _ -> failwith "TODO: Ldsflda - throw MissingFieldException" + | true, field -> + // FieldDefinition is not found on generic type + field, ConcreteType.make activeAssy.Name field.DeclaringType [] + | t -> failwith $"Unexpectedly asked to load a non-field: {t}" - let allocateStatic () = - // TODO: generics - let state, zero = - IlMachineState.cliTypeZeroOf - loggerFactory - activeAssy - field.Signature - ImmutableArray.Empty - state + match IlMachineState.loadClass loggerFactory declaringType thread state with + | FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit + | NothingToDo state -> - state.SetStatic typeId field.Name zero - |> IlMachineState.pushToEvalStack (CliType.ObjectRef None) thread - |> Tuple.withRight WhatWeDid.Executed + if TypeDefn.isManaged field.Signature then + let allocateStatic () = + let state, zero = + IlMachineState.cliTypeZeroOf + loggerFactory + activeAssy + field.Signature + (declaringType.Generics |> ImmutableArray.CreateRange) + state - match state.Statics.TryGetValue typeId with + state.SetStatic declaringType field.Name zero + |> IlMachineState.pushToEvalStack (CliType.ObjectRef None) thread + |> Tuple.withRight WhatWeDid.Executed + + match state.Statics.TryGetValue declaringType with + | true, v -> + match v.TryGetValue field.Name with | true, v -> - match v.TryGetValue field.Name with - | true, v -> - IlMachineState.pushToEvalStack v thread state - |> IlMachineState.advanceProgramCounter thread - |> Tuple.withRight WhatWeDid.Executed - | false, _ -> - // Field has not yet been initialised. - allocateStatic () - | false, _ -> allocateStatic () - else - failwith "TODO: Ldsflda - push unmanaged pointer" + IlMachineState.pushToEvalStack v thread state + |> IlMachineState.advanceProgramCounter thread + |> Tuple.withRight WhatWeDid.Executed + | false, _ -> + // Field has not yet been initialised. + allocateStatic () + | false, _ -> allocateStatic () + else + failwith "TODO: Ldsflda - push unmanaged pointer" | Ldftn -> failwith "TODO: Ldftn unimplemented" | Stobj -> failwith "TODO: Stobj unimplemented" | Constrained -> failwith "TODO: Constrained unimplemented" diff --git a/WoofWare.PawPrint/WoofWare.PawPrint.fsproj b/WoofWare.PawPrint/WoofWare.PawPrint.fsproj index d8bf36e..5191059 100644 --- a/WoofWare.PawPrint/WoofWare.PawPrint.fsproj +++ b/WoofWare.PawPrint/WoofWare.PawPrint.fsproj @@ -1,4 +1,4 @@ - + 7.0.7 @@ -15,8 +15,11 @@ + + +