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

Prepare for overlapping struct field handling (#121)

Browse Source
This commit is contained in:
Patrick Stevens
2025-08-29 18:27:34 +01:00
committed by GitHub
parent 5e7bd969ba
commit cb5d76f059
12 changed files with 188 additions and 205 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
WoofWare.PawPrint/Constants.fs → WoofWare.PawPrint.Domain/Constants.fs
View File

@@ -11,3 +11,6 @@ module Constants =
[<Literal>]
let DEFAULT_STRUCT_ALIGNMENT = 8
[<Literal>]
let NATIVE_INT_SIZE = 8

4
WoofWare.PawPrint.Domain/TypeDefn.fs
View File

@@ -167,8 +167,8 @@ module PrimitiveType =
| PrimitiveType.Double -> 8
| PrimitiveType.String -> 8
| PrimitiveType.TypedReference -> failwith "todo"
| PrimitiveType.IntPtr -> 8
| PrimitiveType.UIntPtr -> 8
| PrimitiveType.IntPtr -> NATIVE_INT_SIZE
| PrimitiveType.UIntPtr -> NATIVE_INT_SIZE
| PrimitiveType.Object -> 8
type TypeDefn =

1
WoofWare.PawPrint.Domain/WoofWare.PawPrint.Domain.fsproj
View File

@@ -7,6 +7,7 @@
<ItemGroup>
<Compile Include="StringToken.fs" />
<Compile Include="Constants.fs" />
<Compile Include="ImmutableArray.fs" />
<Compile Include="Tokens.fs" />
<Compile Include="TypeRef.fs" />

4
WoofWare.PawPrint.Test/sourcesPure/OverlappingStructs.cs
View File

@@ -323,10 +323,10 @@ public class StructLayoutTests
{
int result = 0;
result = TestSequentialLayout();
result = TestExplicitUnion();
if (result != 0) return result;
result = TestExplicitUnion();
result = TestSequentialLayout();
if (result != 0) return result;
result = TestFixedSizeStruct();

141
WoofWare.PawPrint/BasicCliType.fs
View File

@@ -2,7 +2,7 @@ namespace WoofWare.PawPrint
open System.Collections.Immutable
open System.Reflection
open System.Reflection.Metadata
open Checked
/// Source:
/// Table I.6: Data Types Directly Supported by the CLI
@@ -68,6 +68,7 @@ type NativeIntSource =
| ManagedPointer of ManagedPointerSource
| FunctionPointer of MethodInfo<ConcreteTypeHandle, ConcreteTypeHandle, ConcreteTypeHandle>
| TypeHandlePtr of ConcreteTypeHandle
| FieldHandlePtr of int64
override this.ToString () : string =
match this with
@@ -76,12 +77,14 @@ type NativeIntSource =
| NativeIntSource.FunctionPointer methodDefinition ->
$"<pointer to {methodDefinition.Name} in {methodDefinition.DeclaringType.Assembly.Name}>"
| NativeIntSource.TypeHandlePtr ptr -> $"<type ID %O{ptr}>"
| NativeIntSource.FieldHandlePtr ptr -> $"<field ID %O{ptr}>"
[<RequireQualifiedAccess>]
module NativeIntSource =
let isZero (n : NativeIntSource) : bool =
match n with
| NativeIntSource.Verbatim i -> i = 0L
| NativeIntSource.FieldHandlePtr _
| NativeIntSource.TypeHandlePtr _ -> false
| NativeIntSource.FunctionPointer _ -> failwith "TODO"
| NativeIntSource.ManagedPointer src ->
@@ -93,6 +96,7 @@ module NativeIntSource =
match n with
| NativeIntSource.Verbatim i -> i >= 0L
| NativeIntSource.FunctionPointer _ -> failwith "TODO"
| NativeIntSource.FieldHandlePtr _
| NativeIntSource.TypeHandlePtr _ -> true
| NativeIntSource.ManagedPointer _ -> true
@@ -131,7 +135,8 @@ type CliNumericType =
| CliNumericType.Float64 _ -> 8
type CliRuntimePointer =
| Unmanaged of int64
| Verbatim of int64
| FieldRegistryHandle of int64
| Managed of ManagedPointerSource
type SizeofResult =
@@ -203,6 +208,7 @@ and private CliConcreteField =
Size : int
Alignment : int
ConfiguredOffset : int option
EditedAtTime : uint64
}
static member ToCliField (this : CliConcreteField) : CliField =
@@ -217,6 +223,9 @@ and CliValueType =
{
_Fields : CliConcreteField list
Layout : Layout
/// We track dependency orderings between updates to overlapping fields with a monotonically increasing
/// timestamp.
NextTimestamp : uint64
}
static member private ComputeConcreteFields (layout : Layout) (fields : CliField list) : CliConcreteField list =
@@ -255,6 +264,7 @@ and CliValueType =
Size = size.Size
Alignment = size.Alignment
ConfiguredOffset = field.Offset
EditedAtTime = 0UL
}
alignedOffset + size.Size, concreteField :: acc
@@ -275,6 +285,7 @@ and CliValueType =
Size = size.Size
Alignment = size.Alignment
ConfiguredOffset = field.Offset
EditedAtTime = 0UL
}
)
@@ -286,12 +297,16 @@ and CliValueType =
{
_Fields = fields
Layout = layout
NextTimestamp = 1UL
}
static member AddField (f : CliField) (vt : CliValueType) : CliValueType =
// Recompute all fields with the new one added
// TODO: the existence of this function at all is rather dubious, but it's there
// at the moment to support delegate types
// at the moment to support delegate types.
// The whole function is just a bodge and it will hopefully go away soon; I just don't know how.
let prevFields = vt._Fields |> List.map (fun f -> f.Name, f) |> Map.ofList
let allFields =
f
:: (vt._Fields
@@ -306,14 +321,60 @@ and CliValueType =
}
))
let newFields =
CliValueType.ComputeConcreteFields vt.Layout allFields
|> List.map (fun field ->
match Map.tryFind field.Name prevFields with
| Some prev ->
{ field with
EditedAtTime = prev.EditedAtTime
}
| None ->
{ field with
EditedAtTime = vt.NextTimestamp
}
)
{
_Fields = CliValueType.ComputeConcreteFields vt.Layout allFields
_Fields = newFields
Layout = vt.Layout
NextTimestamp = vt.NextTimestamp + 1UL
}
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
// TODO: rewrite this so that it takes a CliConcreteField.
// We should eventually be able to dereference an arbitrary field of a struct
// as though it were any other field of any other type, to accommodate Unsafe.As.
static member DereferenceField (field : string) (cvt : CliValueType) : CliType =
let targetField =
cvt._Fields
|> List.tryFind (fun f -> f.Name = field)
|> Option.defaultWith (fun () -> failwithf $"Field '%s{field}' not found")
// Identify all fields that overlap with the target field's memory range
let targetStart = targetField.Offset
let targetEnd = targetField.Offset + targetField.Size
let affectedFields =
cvt._Fields
|> List.filter (fun f ->
let fieldStart = f.Offset
let fieldEnd = f.Offset + f.Size
// Fields overlap if their ranges intersect
fieldStart < targetEnd && targetStart < fieldEnd
)
match affectedFields with
| [] -> failwith "unexpectedly didn't dereference a field"
| [ f ] -> f.Contents
| _ -> failwith "TODO: dereference overlapping fields"
static member DereferenceFieldAt (offset : int) (size : int) (cvt : CliValueType) : CliType =
let targetField =
cvt._Fields |> List.tryFind (fun f -> f.Offset = offset && f.Size = size)
match targetField with
| None -> failwith "TODO: couldn't find the field"
| Some f -> f.Contents
static member SizeOf (vt : CliValueType) : SizeofResult =
let minimumSize, packingSize =
@@ -352,53 +413,35 @@ and CliValueType =
Alignment = alignment
}
/// Sets the value of the specified field, *without* touching any overlapping fields.
/// `DereferenceField` handles resolving conflicts between overlapping fields.
static member WithFieldSet (field : string) (value : CliType) (cvt : CliValueType) : CliValueType =
let storageSize = CliType.SizeOf value
let targetField =
cvt._Fields
|> List.tryFind (fun f -> f.Name = field)
|> Option.defaultWith (fun () -> failwithf $"Field '%s{field}' not found")
if targetField.Size < storageSize.Size then
failwith "TODO: trying to store a value into a field that's too small to contain it"
// Identify all fields that overlap with the target field's memory range
let targetStart = targetField.Offset
let targetEnd = targetField.Offset + targetField.Size
let affectedFields =
cvt._Fields
|> List.filter (fun f ->
let fieldStart = f.Offset
let fieldEnd = f.Offset + f.Size
// Fields overlap if their ranges intersect
fieldStart < targetEnd && targetStart < fieldEnd
)
match affectedFields |> List.tryExactlyOne with
| None -> failwith "TODO: overlapping fields"
| Some toReplace ->
{
Layout = cvt.Layout
_Fields =
cvt._Fields
|> List.replaceWhere (fun f ->
if f.Name = toReplace.Name then
{ f with
Contents = value
}
|> Some
else
None
)
}
{
Layout = cvt.Layout
_Fields =
cvt._Fields
|> List.replaceWhere (fun f ->
if f.Name = field then
{ f with
Contents = value
EditedAtTime = cvt.NextTimestamp
}
|> Some
else
None
)
NextTimestamp = cvt.NextTimestamp + 1UL
}
/// To facilitate bodges. This function absolutely should not exist.
static member TryExactlyOneField (cvt : CliValueType) : CliField option =
match cvt._Fields with
| [] -> None
| [ x ] -> Some (CliConcreteField.ToCliField x)
| [ x ] ->
if x.Offset = 0 then
Some (CliConcreteField.ToCliField x)
else
None
| _ -> None
/// To facilitate bodges. This function absolutely should not exist.
@@ -493,7 +536,7 @@ module CliType =
| ConcreteTypeHandle.Pointer _ ->
// Pointer types are unmanaged pointers - the zero value is a null pointer
CliType.RuntimePointer (CliRuntimePointer.Unmanaged 0L), concreteTypes
CliType.RuntimePointer (CliRuntimePointer.Managed ManagedPointerSource.Null), concreteTypes
| ConcreteTypeHandle.Concrete _ ->
// This is a concrete type - look it up in the mapping

182
WoofWare.PawPrint/EvalStack.fs
View File

@@ -8,7 +8,8 @@ type EvalStackValue =
| Float of float
| ManagedPointer of ManagedPointerSource
| ObjectRef of ManagedHeapAddress
| UserDefinedValueType of EvalStackValueUserType
/// This doesn't match what the CLR does in reality, but we can work out whatever we need from it.
| UserDefinedValueType of CliValueType
override this.ToString () =
match this with
@@ -18,50 +19,7 @@ type EvalStackValue =
| EvalStackValue.Float f -> $"Float(%f{f})"
| EvalStackValue.ManagedPointer managedPointerSource -> $"Pointer(%O{managedPointerSource})"
| EvalStackValue.ObjectRef managedHeapAddress -> $"ObjectRef(%O{managedHeapAddress})"
| EvalStackValue.UserDefinedValueType evalStackValues ->
let desc =
evalStackValues.Fields
|> List.map (_.ContentsEval >> string<EvalStackValue>)
|> String.concat " | "
$"Struct(%s{desc})"
and EvalStackValueField =
{
Name : string
ContentsEval : EvalStackValue
Offset : int option
}
and EvalStackValueUserType =
{
Fields : EvalStackValueField list
Layout : Layout
}
static member DereferenceField (name : string) (this : EvalStackValueUserType) =
// TODO: this doesn't account for overlapping fields
this.Fields
|> List.pick (fun stackField ->
if stackField.Name = name then
Some stackField.ContentsEval
else
None
)
static member OfFields (layout : Layout) (fields : EvalStackValueField list) =
{
Fields = fields
Layout = layout
}
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
| EvalStackValue.UserDefinedValueType evalStackValues -> $"Struct(%O{evalStackValues})"
[<RequireQualifiedAccess>]
module EvalStackValue =
@@ -89,6 +47,7 @@ module EvalStackValue =
failwith "todo"
| NativeIntSource.ManagedPointer _ -> failwith "TODO"
| NativeIntSource.FunctionPointer _ -> failwith "TODO"
| NativeIntSource.FieldHandlePtr _ -> failwith "TODO"
| NativeIntSource.TypeHandlePtr _ -> failwith "TODO"
| EvalStackValue.Float f -> failwith "todo"
| EvalStackValue.ManagedPointer managedPointerSource ->
@@ -134,6 +93,37 @@ module EvalStackValue =
| EvalStackValue.ObjectRef managedHeapAddress -> failwith "todo"
| EvalStackValue.UserDefinedValueType evalStackValues -> failwith "todo"
let rec ofCliType (v : CliType) : EvalStackValue =
match v with
| CliType.Numeric numeric ->
match numeric with
| CliNumericType.Int32 i -> EvalStackValue.Int32 i
| CliNumericType.Int64 i -> EvalStackValue.Int64 i
| CliNumericType.NativeInt i -> EvalStackValue.NativeInt i
// Sign-extend types int8 and int16
// Zero-extend unsigned int8/unsigned int16
| CliNumericType.Int8 b -> int32<int8> b |> EvalStackValue.Int32
| CliNumericType.UInt8 b -> int32<uint8> b |> EvalStackValue.Int32
| CliNumericType.Int16 s -> int32<int16> s |> EvalStackValue.Int32
| CliNumericType.UInt16 s -> int32<uint16> s |> EvalStackValue.Int32
| CliNumericType.Float32 f -> EvalStackValue.Float (float<float32> f)
| CliNumericType.Float64 f -> EvalStackValue.Float f
| CliNumericType.NativeFloat f -> EvalStackValue.Float f
| CliType.ObjectRef i ->
match i with
| None -> EvalStackValue.ManagedPointer ManagedPointerSource.Null
| Some i -> EvalStackValue.ManagedPointer (ManagedPointerSource.Heap i)
// Zero-extend bool/char
| CliType.Bool b -> int32 b |> EvalStackValue.Int32
| CliType.Char (high, low) -> int32 high * 256 + int32 low |> EvalStackValue.Int32
| CliType.RuntimePointer ptr ->
match ptr with
| CliRuntimePointer.Verbatim ptrInt -> NativeIntSource.Verbatim ptrInt |> EvalStackValue.NativeInt
| CliRuntimePointer.FieldRegistryHandle ptrInt ->
NativeIntSource.FieldHandlePtr ptrInt |> EvalStackValue.NativeInt
| CliRuntimePointer.Managed ptr -> ptr |> EvalStackValue.ManagedPointer
| CliType.ValueType fields -> EvalStackValue.UserDefinedValueType fields
let rec toCliTypeCoerced (target : CliType) (popped : EvalStackValue) : CliType =
match target with
| CliType.Numeric numeric ->
@@ -142,23 +132,12 @@ module EvalStackValue =
match popped with
| EvalStackValue.Int32 i -> CliType.Numeric (CliNumericType.Int32 i)
| EvalStackValue.UserDefinedValueType popped ->
match popped.Fields with
| [] -> failwith "unexpectedly empty"
| [ popped ] -> toCliTypeCoerced target popped.ContentsEval
| fields ->
match fields.[0].Offset with
| None -> failwith "TODO"
| Some _ ->
let fields =
fields
|> List.map (fun f ->
match f.Offset with
| None -> failwith "unexpectedly got a field which didn't have an offset"
| Some offset -> offset, f
)
|> List.sortBy fst
failwith "TODO"
let popped = CliValueType.DereferenceFieldAt 0 4 popped
// TODO: when we have a general mechanism to coerce CliTypes to each other,
// do that
match popped with
| CliType.Numeric (CliNumericType.Int32 i) -> CliType.Numeric (CliNumericType.Int32 i)
| _ -> failwith "TODO"
| i -> failwith $"TODO: %O{i}"
| CliNumericType.Int64 _ ->
match popped with
@@ -168,7 +147,7 @@ module EvalStackValue =
| NativeIntSource.Verbatim i -> CliType.Numeric (CliNumericType.Int64 i)
| NativeIntSource.ManagedPointer ptr -> failwith "TODO"
| NativeIntSource.FunctionPointer f -> failwith $"TODO: {f}"
// CliType.Numeric (CliNumericType.ProvenanceTrackedNativeInt64 f)
| NativeIntSource.FieldHandlePtr f -> failwith $"TODO: {f}"
| NativeIntSource.TypeHandlePtr f -> failwith $"TODO: {f}"
// CliType.Numeric (CliNumericType.TypeHandlePtr f)
| i -> failwith $"TODO: %O{i}"
@@ -179,9 +158,21 @@ module EvalStackValue =
CliNumericType.NativeInt (NativeIntSource.ManagedPointer ptrSrc)
|> CliType.Numeric
| EvalStackValue.UserDefinedValueType vt ->
match vt.Fields with
| [] -> failwith "unexpected"
| [ vt ] -> toCliTypeCoerced target vt.ContentsEval
let popped = CliValueType.DereferenceFieldAt 0 NATIVE_INT_SIZE vt
// TODO: when we have a general mechanism to coerce CliTypes to each other,
// do that
match popped with
| CliType.Numeric (CliNumericType.NativeInt i) -> CliType.Numeric (CliNumericType.NativeInt i)
| CliType.Numeric (CliNumericType.Int64 i) ->
CliType.Numeric (CliNumericType.NativeInt (NativeIntSource.Verbatim i))
| CliType.RuntimePointer ptr ->
match ptr with
| CliRuntimePointer.Verbatim i ->
CliType.Numeric (CliNumericType.NativeInt (NativeIntSource.Verbatim i))
| CliRuntimePointer.FieldRegistryHandle ptr ->
CliType.Numeric (CliNumericType.NativeInt (NativeIntSource.FieldHandlePtr ptr))
| CliRuntimePointer.Managed src ->
CliType.Numeric (CliNumericType.NativeInt (NativeIntSource.ManagedPointer src))
| _ -> failwith $"TODO: {popped}"
| _ -> failwith $"TODO: {popped}"
| CliNumericType.NativeFloat f -> failwith "todo"
@@ -223,15 +214,18 @@ module EvalStackValue =
| NativeIntSource.Verbatim i -> failwith $"refusing to interpret verbatim native int {i} as a pointer"
| NativeIntSource.FunctionPointer _ -> failwith "TODO"
| NativeIntSource.TypeHandlePtr _ -> failwith "refusing to interpret type handle ID as an object ref"
| NativeIntSource.FieldHandlePtr _ -> failwith "refusing to interpret field handle ID as an object ref"
| NativeIntSource.ManagedPointer ptr ->
match ptr with
| ManagedPointerSource.Null -> CliType.ObjectRef None
| ManagedPointerSource.Heap s -> CliType.ObjectRef (Some s)
| _ -> failwith "TODO"
| EvalStackValue.UserDefinedValueType obj ->
match obj.Fields with
| [ esv ] -> toCliTypeCoerced target esv.ContentsEval
| fields -> failwith $"TODO: don't know how to coerce struct of {fields} to a pointer"
let popped = CliValueType.DereferenceFieldAt 0 NATIVE_INT_SIZE obj
match popped with
| CliType.ObjectRef r -> CliType.ObjectRef r
| _ -> failwith "TODO"
| _ -> failwith $"TODO: {popped}"
| CliType.Bool _ ->
match popped with
@@ -246,11 +240,12 @@ module EvalStackValue =
| EvalStackValue.ManagedPointer src -> src |> CliRuntimePointer.Managed |> CliType.RuntimePointer
| EvalStackValue.NativeInt intSrc ->
match intSrc with
| NativeIntSource.Verbatim i -> CliType.RuntimePointer (CliRuntimePointer.Unmanaged i)
| NativeIntSource.Verbatim i -> CliType.RuntimePointer (CliRuntimePointer.Verbatim i)
| NativeIntSource.ManagedPointer src -> src |> CliRuntimePointer.Managed |> CliType.RuntimePointer
| NativeIntSource.FunctionPointer methodInfo ->
CliType.Numeric (CliNumericType.NativeInt (NativeIntSource.FunctionPointer methodInfo))
| NativeIntSource.TypeHandlePtr int64 -> failwith "todo"
| NativeIntSource.FieldHandlePtr int64 -> failwith "todo"
| EvalStackValue.ObjectRef addr ->
ManagedPointerSource.Heap addr
|> CliRuntimePointer.Managed
@@ -266,7 +261,7 @@ module EvalStackValue =
| CliType.ValueType vt ->
match popped with
| EvalStackValue.UserDefinedValueType popped' ->
match CliValueType.TrySequentialFields vt, EvalStackValueUserType.TrySequentialFields popped' with
match CliValueType.TrySequentialFields vt, CliValueType.TrySequentialFields popped' with
| Some vt, Some popped ->
if vt.Length <> popped.Length then
failwith
@@ -280,7 +275,7 @@ module EvalStackValue =
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 (ofCliType popped.Contents)
{
CliField.Name = field1.Name
@@ -296,49 +291,6 @@ module EvalStackValue =
| Some field -> toCliTypeCoerced field.Contents popped
| _ -> failwith $"TODO: {popped} into value type {target}"
let rec ofCliType (v : CliType) : EvalStackValue =
match v with
| CliType.Numeric numeric ->
match numeric with
| CliNumericType.Int32 i -> EvalStackValue.Int32 i
| CliNumericType.Int64 i -> EvalStackValue.Int64 i
| CliNumericType.NativeInt i -> EvalStackValue.NativeInt i
// Sign-extend types int8 and int16
// Zero-extend unsigned int8/unsigned int16
| CliNumericType.Int8 b -> int32<int8> b |> EvalStackValue.Int32
| CliNumericType.UInt8 b -> int32<uint8> b |> EvalStackValue.Int32
| CliNumericType.Int16 s -> int32<int16> s |> EvalStackValue.Int32
| CliNumericType.UInt16 s -> int32<uint16> s |> EvalStackValue.Int32
| CliNumericType.Float32 f -> EvalStackValue.Float (float<float32> f)
| CliNumericType.Float64 f -> EvalStackValue.Float f
| CliNumericType.NativeFloat f -> EvalStackValue.Float f
| CliType.ObjectRef i ->
match i with
| None -> EvalStackValue.ManagedPointer ManagedPointerSource.Null
| Some i -> EvalStackValue.ManagedPointer (ManagedPointerSource.Heap i)
// Zero-extend bool/char
| CliType.Bool b -> int32 b |> EvalStackValue.Int32
| CliType.Char (high, low) -> int32 high * 256 + int32 low |> EvalStackValue.Int32
| CliType.RuntimePointer ptr ->
match ptr with
| CliRuntimePointer.Unmanaged ptrInt -> NativeIntSource.Verbatim ptrInt |> EvalStackValue.NativeInt
| CliRuntimePointer.Managed ptr -> ptr |> EvalStackValue.ManagedPointer
| CliType.ValueType fields ->
// The only allowable use of _Fields
fields._Fields
|> List.map (fun field ->
let contents = ofCliType field.Contents
{
Name = field.Name
// TODO: this probably wants to be a real offset
Offset = field.ConfiguredOffset
ContentsEval = contents
}
)
|> EvalStackValueUserType.OfFields fields.Layout
|> EvalStackValue.UserDefinedValueType
type EvalStack =
{
Values : EvalStackValue list

26
WoofWare.PawPrint/EvalStackValueComparisons.fs
View File

@@ -123,24 +123,14 @@ module EvalStackValueComparisons =
let rec ceq (var1 : EvalStackValue) (var2 : EvalStackValue) : bool =
// Table III.4
match var1, var2 with
| EvalStackValue.UserDefinedValueType {
Fields = [ f ]
},
v -> ceq f.ContentsEval v
| u,
EvalStackValue.UserDefinedValueType {
Fields = [ f ]
} -> ceq u f.ContentsEval
| EvalStackValue.UserDefinedValueType {
Fields = []
},
EvalStackValue.UserDefinedValueType {
Fields = []
} ->
// hmm, surely this can't happen, but :shrug:
true
| EvalStackValue.UserDefinedValueType _, _
| _, EvalStackValue.UserDefinedValueType _ -> failwith $"TODO: ceq {var1} vs {var2}"
| EvalStackValue.UserDefinedValueType var1, v ->
match CliValueType.TryExactlyOneField var1 with
| None -> failwith "TODO"
| Some var1 -> ceq (EvalStackValue.ofCliType var1.Contents) v
| u, EvalStackValue.UserDefinedValueType var2 ->
match CliValueType.TryExactlyOneField var2 with
| None -> failwith "TODO"
| Some var2 -> ceq u (EvalStackValue.ofCliType var2.Contents)
| EvalStackValue.Int32 var1, EvalStackValue.Int32 var2 -> var1 = var2
| EvalStackValue.Int32 var1, EvalStackValue.NativeInt var2 -> failwith "TODO: int32 CEQ nativeint"
| EvalStackValue.Int32 _, _ -> failwith $"bad ceq: Int32 vs {var2}"

2
WoofWare.PawPrint/FieldHandleRegistry.fs
View File

@@ -88,7 +88,7 @@ module FieldHandleRegistry =
// https://github.com/dotnet/runtime/blob/2b21c73fa2c32fa0195e4a411a435dda185efd08/src/coreclr/System.Private.CoreLib/src/System/RuntimeHandles.cs#L1380
{
Name = "m_handle"
Contents = CliType.RuntimePointer (CliRuntimePointer.Unmanaged newHandle)
Contents = CliType.RuntimePointer (CliRuntimePointer.FieldRegistryHandle newHandle)
Offset = None // no struct layout was specified
}
|> List.singleton

20
WoofWare.PawPrint/Intrinsics.fs
View File

@@ -157,9 +157,9 @@ module Intrinsics =
let rec go (arg : EvalStackValue) =
match arg with
| EvalStackValue.UserDefinedValueType vt ->
match vt.Fields with
| [ field ] -> go field.ContentsEval
| _ -> failwith $"TODO: %O{vt}"
match CliValueType.TryExactlyOneField vt with
| None -> failwith "TODO"
| Some field -> go (EvalStackValue.ofCliType field.Contents)
| EvalStackValue.ManagedPointer ManagedPointerSource.Null -> failwith "TODO: throw NRE"
| EvalStackValue.ObjectRef addr
| EvalStackValue.ManagedPointer (ManagedPointerSource.Heap addr) -> Some addr
@@ -358,16 +358,10 @@ module Intrinsics =
| EvalStackValue.ManagedPointer src -> IlMachineState.dereferencePointer state src
| EvalStackValue.NativeInt src -> failwith "TODO"
| EvalStackValue.ObjectRef ptr -> failwith "TODO"
| EvalStackValue.UserDefinedValueType {
Fields = [ f ]
} -> go f.ContentsEval
| EvalStackValue.UserDefinedValueType {
Fields = []
} -> failwith "unexpected no-fields object"
| EvalStackValue.UserDefinedValueType {
Fields = _ :: _ :: _
} ->
failwith "TODO: check overlapping fields to see if this is a pointer"
| EvalStackValue.UserDefinedValueType vt ->
match CliValueType.TryExactlyOneField vt with
| None -> failwith "TODO"
| Some field -> go (EvalStackValue.ofCliType field.Contents)
| EvalStackValue.Int32 _
| EvalStackValue.Int64 _
| EvalStackValue.Float _ -> failwith $"this isn't a pointer! {ptr}"

5
WoofWare.PawPrint/NullaryIlOp.fs
View File

@@ -118,7 +118,6 @@ module NullaryIlOp =
| EvalStackValue.ObjectRef managedHeapAddress -> failwith "todo"
let internal ldElem
(targetCliTypeZero : CliType)
(index : EvalStackValue)
(arr : EvalStackValue)
(currentThread : ThreadId)
@@ -130,6 +129,7 @@ module NullaryIlOp =
| EvalStackValue.NativeInt src ->
match src with
| NativeIntSource.FunctionPointer _
| NativeIntSource.FieldHandlePtr _
| NativeIntSource.TypeHandlePtr _
| NativeIntSource.ManagedPointer _ -> failwith "Refusing to treat a pointer as an array index"
| NativeIntSource.Verbatim i -> i |> int32
@@ -166,6 +166,7 @@ module NullaryIlOp =
| EvalStackValue.NativeInt src ->
match src with
| NativeIntSource.FunctionPointer _
| NativeIntSource.FieldHandlePtr _
| NativeIntSource.TypeHandlePtr _
| NativeIntSource.ManagedPointer _ -> failwith "Refusing to treat a pointer as an array index"
| NativeIntSource.Verbatim i -> i |> int32
@@ -950,7 +951,7 @@ module NullaryIlOp =
let index, state = IlMachineState.popEvalStack currentThread state
let arr, state = IlMachineState.popEvalStack currentThread state
ldElem (CliType.ObjectRef None) index arr currentThread state
ldElem index arr currentThread state
| Stelem_i ->
let value, state = IlMachineState.popEvalStack currentThread state
let index, state = IlMachineState.popEvalStack currentThread state

4
WoofWare.PawPrint/UnaryMetadataIlOp.fs
View File

@@ -795,9 +795,9 @@ module internal UnaryMetadataIlOp =
IlMachineState.pushToEvalStack currentValue thread state
| EvalStackValue.ManagedPointer (ManagedPointerSource.InterpretedAsType (src, ty)) -> failwith "TODO"
| EvalStackValue.UserDefinedValueType vt ->
let result = vt |> EvalStackValueUserType.DereferenceField field.Name
let result = vt |> CliValueType.DereferenceField field.Name
IlMachineState.pushToEvalStack' result thread state
IlMachineState.pushToEvalStack result thread state
state
|> IlMachineState.advanceProgramCounter thread

1
WoofWare.PawPrint/WoofWare.PawPrint.fsproj
View File

@@ -10,7 +10,6 @@
<Compile Include="List.fs" />
<Compile Include="ImmutableArray.fs" />
<Compile Include="Result.fs" />
<Compile Include="Constants.fs" />
<Compile Include="Corelib.fs" />
<Compile Include="AbstractMachineDomain.fs" />
<Compile Include="BasicCliType.fs" />