Centralise field handling in structs (#118)

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 =
-    {
+    private
-        Fields : CliField list
+        {
-    }
+            _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 =
+    let sizeOf (ty : CliType) : int = CliType.SizeOf ty
-        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 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 ->
+        | CliType.ValueType cvt -> CliValueType.WithFieldSet field value cvt |> CliType.ValueType
-            {
-                Fields =
-                    cvt.Fields
-                    |> List.replaceWhere (fun f ->
-                        if f.Name = field then
-                            { f with
-                                Contents = value
-                            }
-                            |> Some
-                        else
-                            None
-                    )
-            }
-            |> 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 ->
+        | CliType.ValueType cvt -> CliValueType.DereferenceField field cvt
-            cvt.Fields
-            |> List.pick (fun f -> if f.Name = field then Some f.Contents else None)

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
+
 [<RequireQualifiedAccess>]
 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
+                match CliValueType.TrySequentialFields vt, EvalStackValueUserType.TrySequentialFields popped with
-                    // TODO: overlapping fields
+                | Some vt, Some popped ->
-                    failwith
+                    if vt.Length <> popped.Length then
-                        $"mismatch: popped value type {popped} (length %i{popped.Fields.Length}) into {vt} (length %i{vt.Fields.Length})"
+                        failwith
+                            $"mismatch: popped value type {popped} (length %i{popped.Length}) into {vt} (length %i{vt.Length})"
 
-                (vt.Fields, popped.Fields)
+                    (vt, popped)
-                ||> List.map2 (fun field1 popped ->
+                    ||> List.map2 (fun field1 popped ->
-                    if field1.Name <> popped.Name then
+                        if field1.Name <> popped.Name then
-                        failwith $"TODO: name mismatch, {field1.Name} vs {popped.Name}"
+                            failwith $"TODO: name mismatch, {field1.Name} vs {popped.Name}"
 
-                    if field1.Offset <> popped.Offset then
+                        if field1.Offset <> popped.Offset then
-                        failwith $"TODO: offset mismatch for {field1.Name}, {field1.Offset} vs {popped.Offset}"
+                            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
+                            CliField.Name = field1.Name
-                        Contents = contents
+                            Contents = contents
-                        Offset = field1.Offset
+                            Offset = field1.Offset
-                    }
+                        }
-                )
+                    )
-                |> CliValueType.OfFields
+                    |> CliValueType.OfFields
-                |> CliType.ValueType
+                    |> CliType.ValueType
+                | _, _ -> failwith "TODO: overlapping fields going onto eval stack"
             | popped ->
-                match vt.Fields with
+                match CliValueType.TryExactlyOneField vt with
-                | [ field ] -> toCliTypeCoerced field.Contents popped
+                | 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
 

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
 

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 =

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
+        CliValueType.DereferenceField name f.Contents
-        f.Fields |> List.find (fun f -> f.Name = name) |> _.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 =
+            Contents = CliValueType.WithFieldSet name v f.Contents
-                f.Fields
-                |> List.replaceWhere (fun f ->
-                    if f.Name = name then
-                        Some
-                            { contents with
-                                Offset = f.Offset
-                            }
-                    else
-                        None
-                )
         }
 
 type AllocatedArray =

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
 

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 =
+                        let v = AllocatedNonArrayObject.SetField field.Name valueToStore v
-                            { v with
-                                Fields =
-                                    v.Fields
-                                    |> List.replaceWhere (fun f ->
-                                        if f.Name = field.Name then
-                                            { f with
-                                                Contents = valueToStore
-                                            }
-                                            |> Some
-                                        else
-                                            None
-                                    )
-                            }
 
                         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)) ->

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