Progress towards advanced struct layout (#126)

2025-10-10 00:08:39 +00:00 · 2025-08-30 20:07:05 +01:00
parent 95987e592c
commit fb5c4a6313
8 changed files with 212 additions and 45 deletions
--- a/WoofWare.PawPrint.Domain/TypeConcretisation.fs
+++ b/WoofWare.PawPrint.Domain/TypeConcretisation.fs
@@ -337,6 +337,23 @@ module ConcreteActivePatterns =
            | None -> None
        | _ -> None

+    let (|ConcreteUInt64|_|) (concreteTypes : AllConcreteTypes) (handle : ConcreteTypeHandle) : unit option =
+        match handle with
+        | ConcreteTypeHandle.Concrete id ->
+            match concreteTypes.Mapping |> Map.tryFind id with
+            | Some ct ->
+                if
+                    ct.Assembly.Name = "System.Private.CoreLib"
+                    && ct.Namespace = "System"
+                    && ct.Name = "UInt64"
+                    && ct.Generics.IsEmpty
+                then
+                    Some ()
+                else
+                    None
+            | None -> None
+        | _ -> None
+
    let (|ConcreteSingle|_|) (concreteTypes : AllConcreteTypes) (handle : ConcreteTypeHandle) : unit option =
        match handle with
        | ConcreteTypeHandle.Concrete id ->
--- a/WoofWare.PawPrint.Domain/TypeDefn.fs
+++ b/WoofWare.PawPrint.Domain/TypeDefn.fs
@@ -6,6 +6,8 @@ open System.Reflection.Metadata
 open System.Reflection.Metadata.Ecma335
 open Microsoft.FSharp.Core

+[<RequireQualifiedAccess>]
+[<NoComparison>]
 type ResolvedBaseType =
    | Enum
    | ValueType
--- a/WoofWare.PawPrint.Test/LoggerFactory.fs
+++ b/WoofWare.PawPrint.Test/LoggerFactory.fs
@@ -23,7 +23,7 @@ module LoggerFactory =
    let makeTest () : (unit -> LogLine list) * ILoggerFactory =
        // Shared sink for all loggers created by the factory.
        let sink = ResizeArray ()
-        let isEnabled (logLevel : LogLevel) : bool = logLevel >= LogLevel.Debug
+        let isEnabled (logLevel : LogLevel) : bool = logLevel >= LogLevel.Information

        let createLogger (category : string) : ILogger =
            { new ILogger with
--- a/WoofWare.PawPrint/BinaryArithmetic.fs
+++ b/WoofWare.PawPrint/BinaryArithmetic.fs
@@ -10,6 +10,7 @@ type IArithmeticOperation =
    abstract FloatFloat : float -> float -> float
    abstract NativeIntNativeInt : nativeint -> nativeint -> nativeint
    abstract Int32ManagedPtr : IlMachineState -> int32 -> ManagedPointerSource -> Choice<ManagedPointerSource, int>
+    abstract ManagedPtrInt32 : IlMachineState -> ManagedPointerSource -> int32 -> Choice<ManagedPointerSource, int>

    abstract ManagedPtrManagedPtr :
        IlMachineState -> ManagedPointerSource -> ManagedPointerSource -> Choice<ManagedPointerSource, nativeint>
@@ -18,6 +19,35 @@ type IArithmeticOperation =

 [<RequireQualifiedAccess>]
 module ArithmeticOperation =
+    let private addInt32ManagedPtr state v ptr =
+        match ptr with
+        | LocalVariable (sourceThread, methodFrame, whichVar) -> failwith "refusing to add to a local variable address"
+        | Argument (sourceThread, methodFrame, whichVar) -> failwith "refusing to add to an argument address"
+        | Heap managedHeapAddress -> failwith "refusing to add to a heap address"
+        | ArrayIndex (arr, index) -> failwith "TODO: arrays"
+        | Field (src, fieldName) ->
+            let obj = IlMachineState.dereferencePointer state src
+            let offset, _ = CliType.getFieldLayout fieldName obj
+
+            match CliType.getFieldAt (offset + v) obj with
+            | None -> failwith "TODO: couldn't identify field at offset"
+            | Some field ->
+                ManagedPointerSource.Field (src, CliConcreteField.ToCliField(field).Name)
+                |> Choice1Of2
+        | Null -> Choice2Of2 v
+        | InterpretedAsType (managedPointerSource, concreteType) -> failwith "todo"
+
+    let private mulInt32ManagedPtr (state : IlMachineState) v ptr =
+        if v = 0 then
+            Choice2Of2 0
+        elif v = 1 then
+            Choice1Of2 ptr
+        else
+
+        match ptr with
+        | ManagedPointerSource.Null -> Choice2Of2 0
+        | _ -> failwith "refusing to multiply pointers"
+
    let add =
        { new IArithmeticOperation with
            member _.Int32Int32 a b = (# "add" a b : int32 #)
@@ -33,24 +63,8 @@ module ArithmeticOperation =
                | _, ManagedPointerSource.Null -> Choice1Of2 ptr1
                | _, _ -> failwith "refusing to add two managed pointers"

-            member _.Int32ManagedPtr state val1 ptr2 =
-                match ptr2 with
-                | LocalVariable (sourceThread, methodFrame, whichVar) ->
-                    failwith "refusing to add to a local variable address"
-                | Argument (sourceThread, methodFrame, whichVar) -> failwith "refusing to add to an argument address"
-                | Heap managedHeapAddress -> failwith "refusing to add to a heap address"
-                | ArrayIndex (arr, index) -> failwith "TODO: arrays"
-                | Field (src, fieldName) ->
-                    let obj = IlMachineState.dereferencePointer state src
-                    let offset, _ = CliType.getFieldLayout fieldName obj
-
-                    match CliType.getFieldAt (offset + val1) obj with
-                    | None -> failwith "TODO: couldn't identify field at offset"
-                    | Some field ->
-                        ManagedPointerSource.Field (src, CliConcreteField.ToCliField(field).Name)
-                        |> Choice1Of2
-                | Null -> Choice2Of2 val1
-                | InterpretedAsType (managedPointerSource, concreteType) -> failwith "todo"
+            member _.Int32ManagedPtr state val1 ptr2 = addInt32ManagedPtr state val1 ptr2
+            member _.ManagedPtrInt32 state ptr1 val2 = addInt32ManagedPtr state val2 ptr1

            member _.Name = "add"
        }
@@ -94,6 +108,8 @@ module ArithmeticOperation =
                | ManagedPointerSource.Null -> Choice2Of2 val1
                | _ -> failwith "refusing to subtract a pointer"

+            member _.ManagedPtrInt32 state ptr1 val2 = failwith "TODO: subtract from pointer"
+
            member _.Name = "sub"
        }

@@ -112,16 +128,26 @@ module ArithmeticOperation =
                | _, ManagedPointerSource.Null -> Choice2Of2 (nativeint 0)
                | _, _ -> failwith "refusing to multiply two managed pointers"

-            member _.Int32ManagedPtr _ a ptr =
-                if a = 0 then
-                    Choice2Of2 0
-                elif a = 1 then
-                    Choice1Of2 ptr
-                else
+            member _.Int32ManagedPtr state a ptr = mulInt32ManagedPtr state a ptr
+            member _.ManagedPtrInt32 state ptr a = mulInt32ManagedPtr state a ptr

-                match ptr with
-                | ManagedPointerSource.Null -> Choice2Of2 0
-                | _ -> failwith "refusing to multiply pointers"
+            member _.Name = "mul"
+        }
+
+    let rem =
+        { new IArithmeticOperation with
+            member _.Int32Int32 a b = (# "rem" a b : int32 #)
+            member _.Int64Int64 a b = (# "rem" a b : int64 #)
+            member _.FloatFloat a b = (# "rem" a b : float #)
+            member _.NativeIntNativeInt a b = (# "rem" a b : nativeint #)
+            member _.Int32NativeInt a b = (# "rem" a b : nativeint #)
+            member _.NativeIntInt32 a b = (# "rem" a b : nativeint #)
+
+            member _.ManagedPtrManagedPtr _ ptr1 ptr2 = failwith "refusing to rem pointers"
+
+            member _.Int32ManagedPtr _ a ptr = failwith "refusing to rem pointer"
+
+            member _.ManagedPtrInt32 _ ptr a = failwith "refusing to rem pointer"

            member _.Name = "mul"
        }
@@ -141,16 +167,8 @@ module ArithmeticOperation =
                | _, ManagedPointerSource.Null -> Choice2Of2 (nativeint 0)
                | _, _ -> failwith "refusing to multiply two managed pointers"

-            member _.Int32ManagedPtr _ a ptr =
-                if a = 0 then
-                    Choice2Of2 0
-                elif a = 1 then
-                    Choice1Of2 ptr
-                else
-
-                match ptr with
-                | ManagedPointerSource.Null -> Choice2Of2 0
-                | _ -> failwith "refusing to multiply pointers"
+            member _.Int32ManagedPtr state a ptr = mulInt32ManagedPtr state a ptr
+            member _.ManagedPtrInt32 state a ptr = mulInt32ManagedPtr state ptr a

            member _.Name = "mul_ovf"
        }
@@ -175,6 +193,12 @@ module ArithmeticOperation =
                else
                    failwith "refusing to divide pointers"

+            member _.ManagedPtrInt32 _ ptr a =
+                if a = 1 then
+                    Choice1Of2 ptr
+                else
+                    failwith "refusing to divide a pointer"
+
            member _.Name = "div"
        }

@@ -238,7 +262,10 @@ module BinaryArithmetic =
        | EvalStackValue.ManagedPointer val1, EvalStackValue.NativeInt val2 ->
            failwith "" |> EvalStackValue.ManagedPointer
        | EvalStackValue.ObjectRef val1, EvalStackValue.NativeInt val2 -> failwith "" |> EvalStackValue.ObjectRef
-        | EvalStackValue.ManagedPointer val1, EvalStackValue.Int32 val2 -> failwith "" |> EvalStackValue.ManagedPointer
+        | EvalStackValue.ManagedPointer val1, EvalStackValue.Int32 val2 ->
+            match op.ManagedPtrInt32 state val1 val2 with
+            | Choice1Of2 result -> EvalStackValue.ManagedPointer result
+            | Choice2Of2 result -> EvalStackValue.NativeInt (NativeIntSource.Verbatim (int64<int32> result))
        | EvalStackValue.ObjectRef val1, EvalStackValue.Int32 val2 -> failwith "" |> EvalStackValue.ObjectRef
        | EvalStackValue.ManagedPointer val1, EvalStackValue.ManagedPointer val2 ->
            match op.ManagedPtrManagedPtr state val1 val2 with
--- a/WoofWare.PawPrint/EvalStack.fs
+++ b/WoofWare.PawPrint/EvalStack.fs
@@ -1,5 +1,7 @@
 namespace WoofWare.PawPrint

+#nowarn "42"
+
 /// See I.12.3.2.1 for definition
 type EvalStackValue =
    | Int32 of int32
@@ -100,6 +102,21 @@ module EvalStackValue =
        | EvalStackValue.ObjectRef managedHeapAddress -> failwith "todo"
        | EvalStackValue.UserDefinedValueType evalStackValues -> failwith "todo"

+    /// Then truncates to int32.
+    let convToUInt8 (value : EvalStackValue) : int32 option =
+        match value with
+        | EvalStackValue.Int32 (i : int32) ->
+            let v = (# "conv.u1" i : uint8 #)
+            Some (int32<uint8> v)
+        | EvalStackValue.Int64 int64 ->
+            let v = (# "conv.u1" int64 : uint8 #)
+            Some (int32<uint8> v)
+        | EvalStackValue.NativeInt nativeIntSource -> failwith "todo"
+        | EvalStackValue.Float f -> failwith "todo"
+        | EvalStackValue.ManagedPointer managedPointerSource -> failwith "todo"
+        | EvalStackValue.ObjectRef managedHeapAddress -> failwith "todo"
+        | EvalStackValue.UserDefinedValueType evalStackValues -> failwith "todo"
+
    let rec ofCliType (v : CliType) : EvalStackValue =
        match v with
        | CliType.Numeric numeric ->
--- a/WoofWare.PawPrint/IlMachineState.fs
+++ b/WoofWare.PawPrint/IlMachineState.fs
@@ -1670,7 +1670,10 @@ module IlMachineState =
            state.ThreadState.[sourceThread].MethodStates.[methodFrame].LocalVariables.[int<uint16> whichVar]
        | ManagedPointerSource.Argument (sourceThread, methodFrame, whichVar) ->
            state.ThreadState.[sourceThread].MethodStates.[methodFrame].Arguments.[int<uint16> whichVar]
-        | ManagedPointerSource.Heap addr -> failwith "todo"
+        | ManagedPointerSource.Heap addr ->
+            let result = ManagedHeap.get addr state.ManagedHeap
+            // TODO: this is awfully dubious, this ain't no value type
+            CliType.ValueType result.Contents
        | ManagedPointerSource.ArrayIndex (arr, index) -> getArrayValue arr index state
        | ManagedPointerSource.Field (addr, name) ->
            let obj = dereferencePointer state addr
--- a/WoofWare.PawPrint/Intrinsics.fs
+++ b/WoofWare.PawPrint/Intrinsics.fs
@@ -192,6 +192,44 @@ module Intrinsics =
                |> IlMachineState.advanceProgramCounter currentThread

            Some state
+        | "System.Private.CoreLib", "Type", "get_IsValueType" ->
+            match methodToCall.Signature.ParameterTypes, methodToCall.Signature.ReturnType with
+            | [], ConcreteBool state.ConcreteTypes -> ()
+            | _ -> failwith "bad signature Type.get_IsValueType"
+
+            let this, state = IlMachineState.popEvalStack currentThread state
+
+            let this =
+                match this with
+                | EvalStackValue.ObjectRef ptr ->
+                    IlMachineState.dereferencePointer state (ManagedPointerSource.Heap ptr)
+                | EvalStackValue.ManagedPointer ptr -> IlMachineState.dereferencePointer state ptr
+                | EvalStackValue.Float _
+                | EvalStackValue.Int32 _
+                | EvalStackValue.Int64 _ -> failwith "refusing to dereference literal"
+                | _ -> failwith "TODO"
+            // `this` should be of type Type
+            let ty =
+                match this with
+                | CliType.ValueType cvt ->
+                    match CliValueType.DereferenceField "m_handle" cvt with
+                    | CliType.Numeric (CliNumericType.NativeInt (NativeIntSource.TypeHandlePtr cth)) -> cth
+                    | _ -> failwith ""
+                | _ -> failwith "expected a Type"
+
+            let ty = AllConcreteTypes.lookup ty state.ConcreteTypes |> Option.get
+            let ty = state.LoadedAssembly(ty.Assembly).Value.TypeDefs.[ty.Definition.Get]
+
+            let isValueType =
+                match DumpedAssembly.resolveBaseType baseClassTypes state._LoadedAssemblies ty.Assembly ty.BaseType with
+                | ResolvedBaseType.Enum
+                | ResolvedBaseType.ValueType -> true
+                | ResolvedBaseType.Object
+                | ResolvedBaseType.Delegate -> false
+
+            IlMachineState.pushToEvalStack (CliType.ofBool isValueType) currentThread state
+            |> IlMachineState.advanceProgramCounter currentThread
+            |> Some
        | "System.Private.CoreLib", "Unsafe", "AsPointer" ->
            // Method signature: 1 generic parameter, we take a Byref of that parameter, and return a TypeDefn.Pointer(Void)
            let arg, state = IlMachineState.popEvalStack currentThread state
@@ -235,6 +273,47 @@ module Intrinsics =
            let result =
                BitConverter.Int32BitsToSingle arg |> CliNumericType.Float32 |> CliType.Numeric

+            state
+            |> IlMachineState.pushToEvalStack result currentThread
+            |> IlMachineState.advanceProgramCounter currentThread
+            |> Some
+        | "System.Private.CoreLib", "BitConverter", "DoubleToUInt64Bits" ->
+            match methodToCall.Signature.ParameterTypes, methodToCall.Signature.ReturnType with
+            | [ ConcreteDouble state.ConcreteTypes ], ConcreteUInt64 state.ConcreteTypes -> ()
+            | _ -> failwith "bad signature BitConverter.DoubleToUInt64Bits"
+
+            let arg, state = IlMachineState.popEvalStack currentThread state
+
+            let arg =
+                match arg with
+                | EvalStackValue.Float i -> i
+                | _ -> failwith "$TODO: {arr}"
+
+            let result =
+                BitConverter.DoubleToUInt64Bits arg
+                |> int64<uint64>
+                |> CliNumericType.Int64
+                |> CliType.Numeric
+
+            state
+            |> IlMachineState.pushToEvalStack result currentThread
+            |> IlMachineState.advanceProgramCounter currentThread
+            |> Some
+        | "System.Private.CoreLib", "BitConverter", "UInt64BitsToDouble" ->
+            match methodToCall.Signature.ParameterTypes, methodToCall.Signature.ReturnType with
+            | [ ConcreteUInt64 state.ConcreteTypes ], ConcreteDouble state.ConcreteTypes -> ()
+            | _ -> failwith "bad signature BitConverter.DoubleToUInt64Bits"
+
+            let arg, state = IlMachineState.popEvalStack currentThread state
+
+            let arg =
+                match arg with
+                | EvalStackValue.Int64 i -> uint64 i
+                | _ -> failwith "$TODO: {arr}"
+
+            let result =
+                BitConverter.UInt64BitsToDouble arg |> CliNumericType.Float64 |> CliType.Numeric
+
            state
            |> IlMachineState.pushToEvalStack result currentThread
            |> IlMachineState.advanceProgramCounter currentThread
--- a/WoofWare.PawPrint/NullaryIlOp.fs
+++ b/WoofWare.PawPrint/NullaryIlOp.fs
@@ -443,8 +443,8 @@ module NullaryIlOp =
        | Sub_ovf -> failwith "TODO: Sub_ovf unimplemented"
        | Sub_ovf_un -> failwith "TODO: Sub_ovf_un unimplemented"
        | Add ->
-            let val1, state = IlMachineState.popEvalStack currentThread state
            let val2, state = IlMachineState.popEvalStack currentThread state
+            let val1, state = IlMachineState.popEvalStack currentThread state
            let result = BinaryArithmetic.execute ArithmeticOperation.add state val1 val2

            state
@@ -455,8 +455,8 @@ module NullaryIlOp =
        | Add_ovf -> failwith "TODO: Add_ovf unimplemented"
        | Add_ovf_un -> failwith "TODO: Add_ovf_un unimplemented"
        | Mul ->
-            let val1, state = IlMachineState.popEvalStack currentThread state
            let val2, state = IlMachineState.popEvalStack currentThread state
+            let val1, state = IlMachineState.popEvalStack currentThread state
            let result = BinaryArithmetic.execute ArithmeticOperation.mul state val1 val2

            state
@@ -465,8 +465,8 @@ module NullaryIlOp =
            |> Tuple.withRight WhatWeDid.Executed
            |> ExecutionResult.Stepped
        | Mul_ovf ->
-            let val1, state = IlMachineState.popEvalStack currentThread state
            let val2, state = IlMachineState.popEvalStack currentThread state
+            let val1, state = IlMachineState.popEvalStack currentThread state

            let result =
                try
@@ -688,7 +688,20 @@ module NullaryIlOp =
            let state = state |> IlMachineState.advanceProgramCounter currentThread

            (state, WhatWeDid.Executed) |> ExecutionResult.Stepped
-        | Conv_U1 -> failwith "TODO: Conv_U1 unimplemented"
+        | Conv_U1 ->
+            let popped, state = IlMachineState.popEvalStack currentThread state
+            let converted = EvalStackValue.convToUInt8 popped
+
+            let state =
+                match converted with
+                | None -> failwith "TODO: Conv_U8 conversion failure unimplemented"
+                | Some conv ->
+                    state
+                    |> IlMachineState.pushToEvalStack' (EvalStackValue.Int32 conv) currentThread
+
+            let state = state |> IlMachineState.advanceProgramCounter currentThread
+
+            (state, WhatWeDid.Executed) |> ExecutionResult.Stepped
        | Conv_U2 -> failwith "TODO: Conv_U2 unimplemented"
        | Conv_U4 -> failwith "TODO: Conv_U4 unimplemented"
        | Conv_U8 ->
@@ -896,7 +909,16 @@ module NullaryIlOp =
        | Ldind_u8 -> failwith "TODO: Ldind_u8 unimplemented"
        | Ldind_r4 -> executeLdind LdindTargetType.LdindR4 currentThread state
        | Ldind_r8 -> executeLdind LdindTargetType.LdindR8 currentThread state
-        | Rem -> failwith "TODO: Rem unimplemented"
+        | Rem ->
+            let val2, state = IlMachineState.popEvalStack currentThread state
+            let val1, state = IlMachineState.popEvalStack currentThread state
+            let result = BinaryArithmetic.execute ArithmeticOperation.rem state val1 val2
+
+            state
+            |> IlMachineState.pushToEvalStack' result currentThread
+            |> IlMachineState.advanceProgramCounter currentThread
+            |> Tuple.withRight WhatWeDid.Executed
+            |> ExecutionResult.Stepped
        | Rem_un -> failwith "TODO: Rem_un unimplemented"
        | Volatile -> failwith "TODO: Volatile unimplemented"
        | Tail -> failwith "TODO: Tail unimplemented"