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

Oh god there is so much

Browse Source
This commit is contained in:
Smaug123
2025-06-29 21:07:28 +01:00
parent ab4c251c97
commit a7150e3294
3 changed files with 95 additions and 52 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
WoofWare.PawPrint.Domain/Assembly.fs
View File

@@ -558,35 +558,38 @@ module DumpedAssembly =
go source baseTypeInfo
// TODO: this is in totally the wrong place, it was just convenient to put it here
/// Returns a mapping whose keys are assembly full name * type definition.
let concretiseType
(mapping : AllConcreteTypes)
(baseTypes : BaseClassTypes<'corelib>)
(getCorelibAssembly : 'corelib -> AssemblyName)
(getTypeInfo :
ComparableTypeDefinitionHandle
-> AssemblyName
-> TypeInfo<WoofWare.PawPrint.GenericParameter, WoofWare.PawPrint.TypeDefn>)
(resolveTypeRef : TypeRef -> TypeResolutionResult<'a>)
(typeGenerics : TypeDefn ImmutableArray)
(methodGenerics : TypeDefn ImmutableArray)
(typeGenerics : (AssemblyName * TypeDefn) ImmutableArray)
(methodGenerics : (AssemblyName * TypeDefn) ImmutableArray)
(defn : AssemblyName * TypeDefn)
: Map<TypeDefn, ConcreteTypeHandle> * AllConcreteTypes
: Map<string * TypeDefn, ConcreteTypeHandle> * AllConcreteTypes
=
// Track types currently being processed to detect cycles
let rec concretiseTypeRec
(inProgress : Map<TypeDefn, ConcreteTypeHandle>)
(newlyCreated : Map<TypeDefn, ConcreteTypeHandle>)
(inProgress : Map<string * TypeDefn, ConcreteTypeHandle>)
(newlyCreated : Map<string * TypeDefn, ConcreteTypeHandle>)
(mapping : AllConcreteTypes)
(assy : AssemblyName)
(typeDefn : TypeDefn)
: ConcreteTypeHandle * Map<TypeDefn, ConcreteTypeHandle> * AllConcreteTypes
: ConcreteTypeHandle * Map<string * TypeDefn, ConcreteTypeHandle> * AllConcreteTypes
=
// First check if we're already processing this type (cycle)
match inProgress |> Map.tryFind typeDefn with
match inProgress |> Map.tryFind (assy.FullName, typeDefn) with
| Some handle -> handle, newlyCreated, mapping
| None ->
// Check if already concretised in this session
match newlyCreated |> Map.tryFind typeDefn with
match newlyCreated |> Map.tryFind (assy.FullName, typeDefn) with
| Some handle -> handle, newlyCreated, mapping
| None ->
@@ -622,7 +625,11 @@ module DumpedAssembly =
[]
let handle, mapping = mapping |> AllConcreteTypes.add concreteType
handle, newlyCreated |> Map.add typeDefn handle, mapping
handle,
newlyCreated
|> Map.add ((getCorelibAssembly baseTypes.Corelib).FullName, typeDefn) handle,
mapping
| Void -> failwith "Void is not a real type and cannot be concretised"
@@ -660,7 +667,11 @@ module DumpedAssembly =
[ eltHandle ]
let handle, mapping = mapping |> AllConcreteTypes.add concreteType
handle, newlyCreated |> Map.add typeDefn handle, mapping
handle,
newlyCreated
|> Map.add ((getCorelibAssembly baseTypes.Corelib).FullName, typeDefn) handle,
mapping
| Pointer inner -> failwith "Pointer types require special handling - no TypeDefinition available"
@@ -681,14 +692,14 @@ module DumpedAssembly =
failwithf "Generic method parameter index %d out of range" index
| FromDefinition (typeDefHandle, assemblyFullName, _) ->
let assemblyName = AssemblyName (assemblyFullName)
let assemblyName = AssemblyName assemblyFullName
let typeInfo = getTypeInfo typeDefHandle assemblyName
let cth, concreteType, mapping =
ConcreteType.make mapping assemblyName typeInfo.Namespace typeInfo.Name typeDefHandle.Get []
let handle, mapping = mapping |> AllConcreteTypes.add concreteType
handle, newlyCreated |> Map.add typeDefn handle, mapping
handle, newlyCreated |> Map.add (assemblyFullName, typeDefn) handle, mapping
| FromReference (typeRef, sigKind) ->
match resolveTypeRef typeRef with
@@ -788,6 +799,6 @@ module DumpedAssembly =
| FunctionPointer _ -> failwith "Function pointer concretisation not implemented"
let _, newlyCreated, finalMapping =
concretiseTypeRec Map.empty Map.empty mapping (snd defn)
concretiseTypeRec Map.empty Map.empty mapping (fst defn) (snd defn)
newlyCreated, finalMapping

35
WoofWare.PawPrint/IlMachineState.fs
View File

@@ -921,6 +921,29 @@ module IlMachineState =
ThreadState = state.ThreadState |> Map.add thread newThreadState
}
let concretiseType
(state : IlMachineState)
(corelib : BaseClassTypes<'corelib>)
(typeGenerics : _)
(methodGenerics : ImmutableArray<TypeDefn>)
(ty : AssemblyName * TypeDefn)
: ConcreteTypeHandle * IlMachineState
=
let ct, mapping =
DumpedAssembly.concretiseType
state.ConcreteTypes
corelib
getTypeInfo
resolveTypeRef
typeGenerics
methodGenerics
ty
ct.[snd ty],
{ state with
ConcreteTypes = mapping
}
let rec loadClass
(loggerFactory : ILoggerFactory)
(corelib : BaseClassTypes<DumpedAssembly>)
@@ -1064,16 +1087,16 @@ module IlMachineState =
// TODO: factor out the common bit.
let currentThreadState = state.ThreadState.[currentThread]
let cctorMethod =
let cctorMethod, state =
cctorMethod
|> MethodInfo.mapTypeGenerics (fun i _ -> ty'.Generics.[i])
|> MethodInfo.mapMethodGenerics (fun _ -> failwith "cctor cannot be generic")
|> MethodInfo.mapVarGenerics
state.ConcreteTypes
(fun mapping v ->
let ty, mapping =
state
(fun state v ->
let ty, state =
DumpedAssembly.concretiseType
mapping
state.ConcreteTypes
corelib
(failwith "")
(failwith "")
@@ -1081,7 +1104,7 @@ module IlMachineState =
ImmutableArray.Empty
(failwith "")
ty.[v], mapping
ty.[v], state
)
callMethod

75
WoofWare.PawPrint/UnaryMetadataIlOp.fs
View File

@@ -772,26 +772,28 @@ module internal UnaryMetadataIlOp =
let currentMethod = state.ThreadState.[thread].MethodState.ExecutingMethod
let declaringTypeGenerics =
match currentMethod.DeclaringType.Generics with
| [] -> None
| x -> Some (ImmutableArray.CreateRange x)
currentMethod.DeclaringType.Generics |> ImmutableArray.CreateRange
let state, assy, elementType =
match metadataToken with
| MetadataToken.TypeDefinition defn ->
state,
assy,
assy.TypeDefs.[defn]
|> TypeInfo.mapGeneric (fun _ i -> declaringTypeGenerics.Value.[i.SequenceNumber])
let ty =
assy.TypeDefs.[defn]
|> TypeInfo.mapGeneric (fun _ i -> declaringTypeGenerics.[i.SequenceNumber])
state, assy, ty
| MetadataToken.TypeSpecification spec ->
IlMachineState.resolveTypeFromSpec
loggerFactory
baseClassTypes
spec
assy
declaringTypeGenerics
currentMethod.Generics
state
let state, assy, ty =
IlMachineState.resolveTypeFromSpec
loggerFactory
baseClassTypes
spec
assy
declaringTypeGenerics
currentMethod.Generics
state
state, assy, ty
| x -> failwith $"TODO: Stelem element type resolution unimplemented for {x}"
let contents, state = IlMachineState.popEvalStack thread state
@@ -847,26 +849,28 @@ module internal UnaryMetadataIlOp =
let currentMethod = state.ThreadState.[thread].MethodState.ExecutingMethod
let declaringTypeGenerics =
match currentMethod.DeclaringType.Generics with
| [] -> None
| x -> Some (ImmutableArray.CreateRange x)
currentMethod.DeclaringType.Generics |> ImmutableArray.CreateRange
let state, assy, elementType =
match metadataToken with
| MetadataToken.TypeDefinition defn ->
state,
assy,
assy.TypeDefs.[defn]
|> TypeInfo.mapGeneric (fun _ i -> declaringTypeGenerics.Value.[i.SequenceNumber])
let ty =
assy.TypeDefs.[defn]
|> TypeInfo.mapGeneric (fun _ i -> declaringTypeGenerics.[i.SequenceNumber])
state, assy, ty
| MetadataToken.TypeSpecification spec ->
IlMachineState.resolveTypeFromSpec
loggerFactory
baseClassTypes
spec
assy
declaringTypeGenerics
currentMethod.Generics
state
let state, assy, ty =
IlMachineState.resolveTypeFromSpec
loggerFactory
baseClassTypes
spec
assy
declaringTypeGenerics
currentMethod.Generics
state
state, assy, ty
| x -> failwith $"TODO: Ldelem element type resolution unimplemented for {x}"
let index, state = IlMachineState.popEvalStack thread state
@@ -911,12 +915,17 @@ module internal UnaryMetadataIlOp =
|> FieldInfo.mapTypeGenerics (fun _ _ -> failwith "generics not allowed on FieldDefinition")
| t -> failwith $"Unexpectedly asked to load a non-field: {t}"
match IlMachineState.loadClass loggerFactory baseClassTypes field.DeclaringType thread state with
let declaringTypeHandle =
match AllConcreteTypes.lookup' field.DeclaringType state.ConcreteTypes with
| None -> failwith "unexpectedly haven't concretised type when loading its field"
| Some t -> t
match IlMachineState.loadClass loggerFactory baseClassTypes declaringTypeHandle thread state with
| FirstLoadThis state -> state, WhatWeDid.SuspendedForClassInit
| NothingToDo state ->
if TypeDefn.isManaged field.Signature then
match IlMachineState.getStatic field.DeclaringType field.Name state with
match IlMachineState.getStatic declaringTypeHandle field.Name state with
| Some v ->
IlMachineState.pushToEvalStack v thread state
|> IlMachineState.advanceProgramCounter thread
@@ -935,7 +944,7 @@ module internal UnaryMetadataIlOp =
ImmutableArray.Empty // field can't have its own generics
state
IlMachineState.setStatic field.DeclaringType field.Name zero state
IlMachineState.setStatic declaringTypeHandle field.Name zero state
|> IlMachineState.pushToEvalStack (CliType.ObjectRef None) thread
|> IlMachineState.advanceProgramCounter thread
|> Tuple.withRight WhatWeDid.Executed