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

Centralise field handling in structs (#118)

Browse Source
This commit is contained in:
Patrick Stevens
2025-08-27 19:49:50 +01:00
committed by GitHub
parent c58c8ce678
commit 655ba4400a
8 changed files with 141 additions and 135 deletions
Download Patch File Download Diff File Expand all files Collapse all files

124
WoofWare.PawPrint/BasicCliType.fs
View File

@@ -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

55
WoofWare.PawPrint/EvalStack.fs
View File

@@ -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
// 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

3
WoofWare.PawPrint/FieldHandleRegistry.fs
View File

@@ -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

43
WoofWare.PawPrint/IlMachineState.fs
View File

@@ -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 =

26
WoofWare.PawPrint/ManagedHeap.fs
View File

@@ -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 =

3
WoofWare.PawPrint/TypeHandleRegistry.fs
View File

@@ -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

21
WoofWare.PawPrint/UnaryMetadataIlOp.fs
View File

@@ -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)) ->

1
WoofWare.PawPrint/UnaryStringTokenIlOp.fs
View File

@@ -63,6 +63,7 @@ module internal UnaryStringTokenIlOp =
Offset = None
}
]
|> CliValueType.OfFields
let state, stringType =
DumpedAssembly.typeInfoToTypeDefn' baseClassTypes state._LoadedAssemblies baseClassTypes.String