diff --git a/WoofWare.PawPrint/BasicCliType.fs b/WoofWare.PawPrint/BasicCliType.fs index fcdc40a..48f7da8 100644 --- a/WoofWare.PawPrint/BasicCliType.fs +++ b/WoofWare.PawPrint/BasicCliType.fs @@ -117,6 +117,19 @@ type CliNumericType = | Float32 of float32 | Float64 of float + static member SizeOf (t : CliNumericType) : int = + match t with + | CliNumericType.Int32 _ -> 4 + | CliNumericType.Int64 _ -> 8 + | CliNumericType.NativeInt _ -> 8 + | CliNumericType.NativeFloat _ -> 8 + | CliNumericType.Int8 _ -> 1 + | CliNumericType.Int16 _ -> 2 + | CliNumericType.UInt8 _ -> 1 + | CliNumericType.UInt16 _ -> 2 + | CliNumericType.Float32 _ -> 4 + | CliNumericType.Float64 _ -> 8 + type CliRuntimePointer = | Unmanaged of int64 | Managed of ManagedPointerSource @@ -137,6 +150,15 @@ type CliType = /// as a concatenated list of its fields. | ValueType of CliValueType + static member SizeOf (t : CliType) : int = + match t with + | CliType.Numeric ty -> CliNumericType.SizeOf ty + | CliType.Bool _ -> 1 + | CliType.Char _ -> 2 + | CliType.ObjectRef _ -> 8 + | CliType.RuntimePointer _ -> 8 + | CliType.ValueType vt -> CliValueType.SizeOf vt + and CliField = { Name : string @@ -146,18 +168,64 @@ and CliField = } and CliValueType = - { - Fields : CliField list - } + private + { + _Fields : CliField list + } static member OfFields (f : CliField list) = { - Fields = f + _Fields = f + } + + static member AddField (f : CliField) (vt : CliValueType) = + { + _Fields = f :: vt._Fields } static member DereferenceField (name : string) (f : CliValueType) : CliType = // TODO: this is wrong, it doesn't account for overlapping fields - f.Fields |> List.find (fun f -> f.Name = name) |> _.Contents + f._Fields |> List.find (fun f -> f.Name = name) |> _.Contents + + static member SizeOf (vt : CliValueType) : int = + match vt._Fields with + | [] -> failwith "is it even possible to instantiate a value type with no fields" + | [ field ] -> CliType.SizeOf field.Contents + | fields -> + // TODO: consider struct layout (there's an `Explicit` test that will exercise that) + fields |> List.map (_.Contents >> CliType.SizeOf) |> List.sum + + static member WithFieldSet (field : string) (value : CliType) (cvt : CliValueType) : CliValueType = + // TODO: this doesn't account for overlapping fields + { + _Fields = + cvt._Fields + |> List.replaceWhere (fun f -> + if f.Name = field then + { f with + Contents = value + } + |> Some + else + None + ) + } + + static member TryExactlyOneField (cvt : CliValueType) : CliField option = + match cvt._Fields with + | [] -> None + | [ x ] -> Some x + | _ -> None + + /// To facilitate bodges. + static member TrySequentialFields (cvt : CliValueType) : CliField list option = + let isNone, isSome = + cvt._Fields |> List.partition (fun field -> field.Offset.IsNone) + + match isSome with + | [] -> Some isNone + | [ field ] when field.Offset = Some 0 -> Some [ field ] + | _ -> None type CliTypeResolutionResult = | Resolved of CliType @@ -173,31 +241,7 @@ module CliType = let ofManagedObject (ptr : ManagedHeapAddress) : CliType = CliType.ObjectRef (Some ptr) - let rec sizeOf (ty : CliType) : int = - match ty with - | CliType.Numeric ty -> - match ty with - | CliNumericType.Int32 _ -> 4 - | CliNumericType.Int64 _ -> 8 - | CliNumericType.NativeInt _ -> 8 - | CliNumericType.NativeFloat _ -> 8 - | CliNumericType.Int8 _ -> 1 - | CliNumericType.Int16 _ -> 2 - | CliNumericType.UInt8 _ -> 1 - | CliNumericType.UInt16 _ -> 2 - | CliNumericType.Float32 _ -> 4 - | CliNumericType.Float64 _ -> 8 - | CliType.Bool _ -> 1 - | CliType.Char _ -> 2 - | CliType.ObjectRef _ -> 8 - | CliType.RuntimePointer _ -> 8 - | CliType.ValueType vt -> - match vt.Fields with - | [] -> failwith "is it even possible to instantiate a value type with no fields" - | [ field ] -> sizeOf field.Contents - | fields -> - // TODO: consider struct layout (there's an `Explicit` test that will exercise that) - fields |> List.map (_.Contents >> sizeOf) |> List.sum + let sizeOf (ty : CliType) : int = CliType.SizeOf ty let zeroOfPrimitive (primitiveType : PrimitiveType) : CliType = match primitiveType with @@ -460,21 +504,7 @@ module CliType = | CliType.Char (high, low) -> failwith "todo" | CliType.ObjectRef managedHeapAddressOption -> failwith "todo" | CliType.RuntimePointer cliRuntimePointer -> failwith "todo" - | CliType.ValueType cvt -> - { - Fields = - cvt.Fields - |> List.replaceWhere (fun f -> - if f.Name = field then - { f with - Contents = value - } - |> Some - else - None - ) - } - |> CliType.ValueType + | CliType.ValueType cvt -> CliValueType.WithFieldSet field value cvt |> CliType.ValueType let getField (field : string) (value : CliType) : CliType = match value with @@ -483,6 +513,4 @@ module CliType = | CliType.Char (high, low) -> failwith "todo" | CliType.ObjectRef managedHeapAddressOption -> failwith "todo" | CliType.RuntimePointer cliRuntimePointer -> failwith "todo" - | CliType.ValueType cvt -> - cvt.Fields - |> List.pick (fun f -> if f.Name = field then Some f.Contents else None) + | CliType.ValueType cvt -> CliValueType.DereferenceField field cvt diff --git a/WoofWare.PawPrint/EvalStack.fs b/WoofWare.PawPrint/EvalStack.fs index 4511cdf..eb1e139 100644 --- a/WoofWare.PawPrint/EvalStack.fs +++ b/WoofWare.PawPrint/EvalStack.fs @@ -53,6 +53,14 @@ and EvalStackValueUserType = Fields = fields } + static member TrySequentialFields (cvt : EvalStackValueUserType) : EvalStackValueField list option = + let isNone, isSome = cvt.Fields |> List.partition (fun field -> field.Offset.IsNone) + + match isSome with + | [] -> Some isNone + | [ field ] when field.Offset = Some 0 -> Some [ field ] + | _ -> None + [] module EvalStackValue = /// The conversion performed by Conv_u. @@ -256,32 +264,34 @@ module EvalStackValue = | CliType.ValueType vt -> match popped with | EvalStackValue.UserDefinedValueType popped -> - if vt.Fields.Length <> popped.Fields.Length then - // TODO: overlapping fields - failwith - $"mismatch: popped value type {popped} (length %i{popped.Fields.Length}) into {vt} (length %i{vt.Fields.Length})" + match CliValueType.TrySequentialFields vt, EvalStackValueUserType.TrySequentialFields popped with + | Some vt, Some popped -> + if vt.Length <> popped.Length then + failwith + $"mismatch: popped value type {popped} (length %i{popped.Length}) into {vt} (length %i{vt.Length})" - (vt.Fields, popped.Fields) - ||> List.map2 (fun field1 popped -> - if field1.Name <> popped.Name then - failwith $"TODO: name mismatch, {field1.Name} vs {popped.Name}" + (vt, popped) + ||> List.map2 (fun field1 popped -> + if field1.Name <> popped.Name then + failwith $"TODO: name mismatch, {field1.Name} vs {popped.Name}" - if field1.Offset <> popped.Offset then - failwith $"TODO: offset mismatch for {field1.Name}, {field1.Offset} vs {popped.Offset}" + if field1.Offset <> popped.Offset then + failwith $"TODO: offset mismatch for {field1.Name}, {field1.Offset} vs {popped.Offset}" - let contents = toCliTypeCoerced field1.Contents popped.ContentsEval + let contents = toCliTypeCoerced field1.Contents popped.ContentsEval - { - CliField.Name = field1.Name - Contents = contents - Offset = field1.Offset - } - ) - |> CliValueType.OfFields - |> CliType.ValueType + { + CliField.Name = field1.Name + Contents = contents + Offset = field1.Offset + } + ) + |> CliValueType.OfFields + |> CliType.ValueType + | _, _ -> failwith "TODO: overlapping fields going onto eval stack" | popped -> - match vt.Fields with - | [ field ] -> toCliTypeCoerced field.Contents popped + match CliValueType.TryExactlyOneField vt with + | Some field -> toCliTypeCoerced field.Contents popped | _ -> failwith $"TODO: {popped} into value type {target}" let rec ofCliType (v : CliType) : EvalStackValue = @@ -313,7 +323,8 @@ module EvalStackValue = | CliRuntimePointer.Managed ptr -> ptr |> EvalStackValue.ManagedPointer | CliType.ValueType fields -> // TODO: this is a bit dubious; we're being a bit sloppy with possibly-overlapping fields here - fields.Fields + // The only allowable use of _Fields + fields._Fields |> List.map (fun field -> let contents = ofCliType field.Contents diff --git a/WoofWare.PawPrint/FieldHandleRegistry.fs b/WoofWare.PawPrint/FieldHandleRegistry.fs index eb48925..48bfba7 100644 --- a/WoofWare.PawPrint/FieldHandleRegistry.fs +++ b/WoofWare.PawPrint/FieldHandleRegistry.fs @@ -34,7 +34,7 @@ module FieldHandleRegistry = let getOrAllocate (baseClassTypes : BaseClassTypes<'corelib>) (allocState : 'allocState) - (allocate : CliField list -> 'allocState -> ManagedHeapAddress * 'allocState) + (allocate : CliValueType -> 'allocState -> ManagedHeapAddress * 'allocState) (declaringAssy : AssemblyName) (declaringType : ConcreteTypeHandle) (handle : FieldDefinitionHandle) @@ -132,6 +132,7 @@ module FieldHandleRegistry = Offset = Some (SIZEOF_OBJ * 4 + SIZEOF_INT) } ] + |> CliValueType.OfFields let alloc, state = allocate runtimeFieldInfoStub allocState diff --git a/WoofWare.PawPrint/IlMachineState.fs b/WoofWare.PawPrint/IlMachineState.fs index 98ea8a0..f999774 100644 --- a/WoofWare.PawPrint/IlMachineState.fs +++ b/WoofWare.PawPrint/IlMachineState.fs @@ -753,14 +753,9 @@ module IlMachineState = | ResolvedBaseType.Delegate | ResolvedBaseType.Object -> state |> pushToEvalStack (CliType.ofManagedObject constructing) currentThread | ResolvedBaseType.ValueType -> - let vt = - { - CliValueType.Fields = constructed.Fields - } - state // TODO: ordering of fields probably important - |> pushToEvalStack (CliType.ValueType vt) currentThread + |> pushToEvalStack (CliType.ValueType constructed.Contents) currentThread | ResolvedBaseType.Enum -> failwith "TODO" | None -> match threadStateAtEndOfMethod.MethodState.EvaluationStack.Values with @@ -1129,13 +1124,13 @@ module IlMachineState = let allocateManagedObject (ty : ConcreteTypeHandle) - (fields : CliField list) + (fields : CliValueType) (state : IlMachineState) : ManagedHeapAddress * IlMachineState = let o = { - Fields = fields + Contents = fields ConcreteType = ty SyncBlock = SyncBlock.Free } @@ -1500,24 +1495,24 @@ module IlMachineState = // Standard delegate fields in .NET are _target and _methodPtr // Update the fields with the target object and method pointer - let updatedFields = - // Let's not consider field ordering for reference types like delegates. - // Nobody's going to be marshalling a reference type anyway, I hope. - { - Name = "_target" - Contents = CliType.ObjectRef targetObj - Offset = None - } - :: { - Name = "_methodPtr" - Contents = methodPtr - Offset = None - } - :: heapObj.Fields - let updatedObj = + let newContents = + heapObj.Contents + |> CliValueType.AddField + { + Name = "_target" + Contents = CliType.ObjectRef targetObj + Offset = None + } + |> CliValueType.AddField + { + Name = "_methodPtr" + Contents = methodPtr + Offset = None + } + { heapObj with - Fields = updatedFields + Contents = newContents } let updatedHeap = diff --git a/WoofWare.PawPrint/ManagedHeap.fs b/WoofWare.PawPrint/ManagedHeap.fs index 68616dd..e85efa8 100644 --- a/WoofWare.PawPrint/ManagedHeap.fs +++ b/WoofWare.PawPrint/ManagedHeap.fs @@ -8,36 +8,18 @@ type SyncBlock = type AllocatedNonArrayObject = { - Fields : CliField list + // TODO: this is a slightly odd domain; the same type for value types as class types! + Contents : CliValueType ConcreteType : ConcreteTypeHandle SyncBlock : SyncBlock } static member DereferenceField (name : string) (f : AllocatedNonArrayObject) : CliType = - // TODO: this is wrong, it doesn't account for overlapping fields - f.Fields |> List.find (fun f -> f.Name = name) |> _.Contents + CliValueType.DereferenceField name f.Contents static member SetField (name : string) (v : CliType) (f : AllocatedNonArrayObject) : AllocatedNonArrayObject = - // TODO: this is wrong, it doesn't account for overlapping fields - let contents = - { - Name = name - Contents = v - Offset = None - } - { f with - Fields = - f.Fields - |> List.replaceWhere (fun f -> - if f.Name = name then - Some - { contents with - Offset = f.Offset - } - else - None - ) + Contents = CliValueType.WithFieldSet name v f.Contents } type AllocatedArray = diff --git a/WoofWare.PawPrint/TypeHandleRegistry.fs b/WoofWare.PawPrint/TypeHandleRegistry.fs index b07e04b..775e783 100644 --- a/WoofWare.PawPrint/TypeHandleRegistry.fs +++ b/WoofWare.PawPrint/TypeHandleRegistry.fs @@ -18,7 +18,7 @@ module TypeHandleRegistry = /// Returns an allocated System.RuntimeType as well. let getOrAllocate (allocState : 'allocState) - (allocate : CliField list -> 'allocState -> ManagedHeapAddress * 'allocState) + (allocate : CliValueType -> 'allocState -> ManagedHeapAddress * 'allocState) (def : ConcreteTypeHandle) (reg : TypeHandleRegistry) : ManagedHeapAddress * TypeHandleRegistry * 'allocState @@ -58,6 +58,7 @@ module TypeHandleRegistry = Offset = None } ] + |> CliValueType.OfFields let alloc, state = allocate fields allocState diff --git a/WoofWare.PawPrint/UnaryMetadataIlOp.fs b/WoofWare.PawPrint/UnaryMetadataIlOp.fs index f2b5dbb..7bad477 100644 --- a/WoofWare.PawPrint/UnaryMetadataIlOp.fs +++ b/WoofWare.PawPrint/UnaryMetadataIlOp.fs @@ -316,7 +316,7 @@ module internal UnaryMetadataIlOp = state, field :: zeros ) - let fields = List.rev fieldZeros + let fields = List.rev fieldZeros |> CliValueType.OfFields // Note: this is a bit unorthodox for value types, which *aren't* heap-allocated. // We'll perform their construction on the heap, though, to keep the interface @@ -541,7 +541,7 @@ module internal UnaryMetadataIlOp = logger.LogInformation ( "Storing in object field {FieldAssembly}.{FieldDeclaringType}.{FieldName} (type {FieldType})", field.DeclaringType.Assembly.Name, - field.Name, + field.DeclaringType.Name, field.Name, field.Signature ) @@ -582,20 +582,7 @@ module internal UnaryMetadataIlOp = match state.ManagedHeap.NonArrayObjects.TryGetValue addr with | false, _ -> failwith $"todo: array {addr}" | true, v -> - let v = - { v with - Fields = - v.Fields - |> List.replaceWhere (fun f -> - if f.Name = field.Name then - { f with - Contents = valueToStore - } - |> Some - else - None - ) - } + let v = AllocatedNonArrayObject.SetField field.Name valueToStore v let heap = { state.ManagedHeap with @@ -790,7 +777,7 @@ module internal UnaryMetadataIlOp = | false, _ -> failwith $"todo: array {managedHeapAddress}" | true, v -> IlMachineState.pushToEvalStack - (v.Fields |> List.find (fun f -> field.Name = f.Name) |> _.Contents) + (AllocatedNonArrayObject.DereferenceField field.Name v) thread state | EvalStackValue.ManagedPointer (ManagedPointerSource.ArrayIndex (arr, index)) -> diff --git a/WoofWare.PawPrint/UnaryStringTokenIlOp.fs b/WoofWare.PawPrint/UnaryStringTokenIlOp.fs index cdf44a5..b262b46 100644 --- a/WoofWare.PawPrint/UnaryStringTokenIlOp.fs +++ b/WoofWare.PawPrint/UnaryStringTokenIlOp.fs @@ -63,6 +63,7 @@ module internal UnaryStringTokenIlOp = Offset = None } ] + |> CliValueType.OfFields let state, stringType = DumpedAssembly.typeInfoToTypeDefn' baseClassTypes state._LoadedAssemblies baseClassTypes.String