From ab1c25282bb7254f35fe49dc27ffa1b26d075727 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 12:08:59 +0100 Subject: [PATCH 1/7] cosmetic cleanup --- VisualFSharp.sln | 3 - src/absil/ildiag.fs | 1 - src/absil/ildiag.fsi | 3 - src/absil/ilread.fs | 1581 ++++++++--------- src/fsharp/CompileOps.fs | 9 +- src/fsharp/ConstraintSolver.fs | 50 +- src/fsharp/ConstraintSolver.fsi | 3 +- .../FSharp.Compiler-proto.fsproj | 6 - .../FSharp.Compiler/FSharp.Compiler.fsproj | 6 - .../FSharp.LanguageService.Compiler.fsproj | 4 - src/fsharp/FindUnsolved.fs | 108 +- src/fsharp/LexFilter.fs | 1 - src/fsharp/PatternMatchCompilation.fs | 59 +- src/fsharp/PostInferenceChecks.fs | 260 +-- src/fsharp/QuotationTranslator.fs | 76 +- src/fsharp/TraceCall.fs | 172 -- src/fsharp/TraceCall.fsi | 25 - src/fsharp/vs/IncrementalBuild.fs | 3 +- src/fsharp/vs/ServiceLexing.fs | 5 +- src/fsharp/vs/ServiceParamInfoLocations.fs | 8 +- src/fsharp/vs/ServiceUntypedParse.fs | 5 - src/fsharp/vs/service.fs | 18 +- 22 files changed, 1069 insertions(+), 1337 deletions(-) delete mode 100644 src/fsharp/TraceCall.fs delete mode 100644 src/fsharp/TraceCall.fsi diff --git a/VisualFSharp.sln b/VisualFSharp.sln index 002dbd63f6..6409c1433e 100644 --- a/VisualFSharp.sln +++ b/VisualFSharp.sln @@ -126,9 +126,6 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution EndProjectSection EndProject Global - GlobalSection(Performance) = preSolution - HasPerformanceSessions = true - EndGlobalSection GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU Debug|x86 = Debug|x86 diff --git a/src/absil/ildiag.fs b/src/absil/ildiag.fs index 44d0713c55..3cbb2852d5 100644 --- a/src/absil/ildiag.fs +++ b/src/absil/ildiag.fs @@ -18,4 +18,3 @@ let dprintf (fmt: Format<_,_,_,_>) = let dprintfn (fmt: Format<_,_,_,_>) = Printf.kfprintf dflushn (match !diagnosticsLog with None -> System.IO.TextWriter.Null | Some d -> d) fmt -let setDiagnosticsChannel s = diagnosticsLog := s diff --git a/src/absil/ildiag.fsi b/src/absil/ildiag.fsi index 682cab7bdb..3974130fcd 100644 --- a/src/absil/ildiag.fsi +++ b/src/absil/ildiag.fsi @@ -11,9 +11,6 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open System.IO open Microsoft.FSharp.Core.Printf -val public setDiagnosticsChannel: TextWriter option -> unit - val public dprintfn: TextWriterFormat<'a> -> 'a val public dprintf: TextWriterFormat<'a> -> 'a - val public dprintn: string -> unit diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index b5cebc1737..4a6c3cd59c 100644 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -29,8 +29,8 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.NativeInterop type ILReaderOptions = - { pdbPath: string option; - ilGlobals: ILGlobals; + { pdbPath: string option + ilGlobals: ILGlobals optimizeForMemory: bool } #if STATISTICS @@ -160,22 +160,22 @@ type MemoryMappedFile(hMap: MemoryMapping.HANDLE, start:nativeint) = inherit BinaryFile() static member Create fileName = - //printf "fileName = %s\n" fileName; + //printf "fileName = %s\n" fileName let hFile = MemoryMapping.CreateFile (fileName, MemoryMapping.GENERIC_READ, MemoryMapping.FILE_SHARE_READ_WRITE, IntPtr.Zero, MemoryMapping.OPEN_EXISTING, 0, IntPtr.Zero ) - //printf "hFile = %Lx\n" (hFile.ToInt64()); + //printf "hFile = %Lx\n" (hFile.ToInt64()) if ( hFile.Equals(MemoryMapping.INVALID_HANDLE) ) then - failwithf "CreateFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() ); + failwithf "CreateFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() ) let protection = 0x00000002 (* ReadOnly *) - //printf "OK! hFile = %Lx\n" (hFile.ToInt64()); + //printf "OK! hFile = %Lx\n" (hFile.ToInt64()) let hMap = MemoryMapping.CreateFileMapping (hFile, IntPtr.Zero, protection, 0,0, null ) - ignore(MemoryMapping.CloseHandle(hFile)); + ignore(MemoryMapping.CloseHandle(hFile)) if hMap.Equals(MemoryMapping.NULL_HANDLE) then - failwithf "CreateFileMapping(0x%08x)" ( Marshal.GetHRForLastWin32Error() ); + failwithf "CreateFileMapping(0x%08x)" ( Marshal.GetHRForLastWin32Error() ) let start = MemoryMapping.MapViewOfFile (hMap, MemoryMapping.MAP_READ,0,0,0n) if start.Equals(IntPtr.Zero) then - failwithf "MapViewOfFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() ); + failwithf "MapViewOfFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() ) MemoryMappedFile(hMap, start) member m.Addr (i:int) : nativeint = @@ -186,7 +186,7 @@ type MemoryMappedFile(hMap: MemoryMapping.HANDLE, start:nativeint) = override m.ReadBytes i len = let res = Bytes.zeroCreate len - Marshal.Copy(m.Addr i, res, 0,len); + Marshal.Copy(m.Addr i, res, 0,len) res override m.ReadInt32 i = @@ -196,7 +196,7 @@ type MemoryMappedFile(hMap: MemoryMapping.HANDLE, start:nativeint) = NativePtr.read (NativePtr.ofNativeInt (m.Addr i)) member m.Close() = - ignore(MemoryMapping.UnmapViewOfFile start); + ignore(MemoryMapping.UnmapViewOfFile start) ignore(MemoryMapping.CloseHandle hMap) override m.CountUtf8String i = @@ -325,7 +325,7 @@ let sigptrCheck (bytes:byte[]) sigptr = // member x.GetByte() = let res = bytes.[curr] in curr <- curr + 1; res let sigptrGetByte (bytes:byte[]) sigptr = - sigptrCheck bytes sigptr; + sigptrCheck bytes sigptr bytes.[sigptr], sigptr + 1 let sigptrGetBool bytes sigptr = @@ -346,7 +346,7 @@ let sigptrGetInt16 bytes sigptr = int16 u,sigptr let sigptrGetInt32 bytes sigptr = - sigptrCheck bytes sigptr; + sigptrCheck bytes sigptr let b0 = bytes.[sigptr] let b1 = bytes.[sigptr+1] let b2 = bytes.[sigptr+2] @@ -402,7 +402,7 @@ let sigptrFold f n (bytes:byte[]) (sigptr:int) = let sigptrGetBytes n (bytes:byte[]) sigptr = if checking && sigptr + n >= bytes.Length then - dprintn "read past end of sig. in sigptrGetString"; + dprintn "read past end of sig. in sigptrGetString" Bytes.zeroCreate 0, sigptr else let res = Bytes.zeroCreate n @@ -421,51 +421,51 @@ let sigptrGetString n bytes sigptr = [] type ILInstrPrefixesRegister = - { mutable al: ILAlignment; - mutable tl: ILTailcall; - mutable vol: ILVolatility; - mutable ro: ILReadonly; + { mutable al: ILAlignment + mutable tl: ILTailcall + mutable vol: ILVolatility + mutable ro: ILReadonly mutable constrained: ILType option} let noPrefixes mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here"; - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here"; - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here"; - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here"; - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here"; + if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" + if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" + if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" + if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" + if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" mk let volatileOrUnalignedPrefix mk prefixes = - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here"; - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here"; - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here"; + if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" + if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" + if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" mk (prefixes.al,prefixes.vol) let volatilePrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here"; - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here"; - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here"; - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here"; + if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" + if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" + if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" + if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" mk prefixes.vol let tailPrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here"; - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here"; - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here"; - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here"; + if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" + if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" + if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" + if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" mk prefixes.tl let constraintOrTailPrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here"; - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here"; - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here"; + if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" + if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" + if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" mk (prefixes.constrained,prefixes.tl ) let readonlyPrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here"; - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here"; - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here"; - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here"; + if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" + if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" + if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" + if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" mk prefixes.ro @@ -496,103 +496,103 @@ let mkStind dt = volatileOrUnalignedPrefix (fun (x,y) -> I_stind(x,y,dt)) let mkLdind dt = volatileOrUnalignedPrefix (fun (x,y) -> I_ldind(x,y,dt)) let instrs () = - [ i_ldarg_s, I_u16_u8_instr (noPrefixes mkLdarg); - i_starg_s, I_u16_u8_instr (noPrefixes I_starg); - i_ldarga_s, I_u16_u8_instr (noPrefixes I_ldarga); - i_stloc_s, I_u16_u8_instr (noPrefixes mkStloc); - i_ldloc_s, I_u16_u8_instr (noPrefixes mkLdloc); - i_ldloca_s, I_u16_u8_instr (noPrefixes I_ldloca); - i_ldarg, I_u16_u16_instr (noPrefixes mkLdarg); - i_starg, I_u16_u16_instr (noPrefixes I_starg); - i_ldarga, I_u16_u16_instr (noPrefixes I_ldarga); - i_stloc, I_u16_u16_instr (noPrefixes mkStloc); - i_ldloc, I_u16_u16_instr (noPrefixes mkLdloc); - i_ldloca, I_u16_u16_instr (noPrefixes I_ldloca); - i_stind_i, I_none_instr (mkStind DT_I); - i_stind_i1, I_none_instr (mkStind DT_I1); - i_stind_i2, I_none_instr (mkStind DT_I2); - i_stind_i4, I_none_instr (mkStind DT_I4); - i_stind_i8, I_none_instr (mkStind DT_I8); - i_stind_r4, I_none_instr (mkStind DT_R4); - i_stind_r8, I_none_instr (mkStind DT_R8); - i_stind_ref, I_none_instr (mkStind DT_REF); - i_ldind_i, I_none_instr (mkLdind DT_I); - i_ldind_i1, I_none_instr (mkLdind DT_I1); - i_ldind_i2, I_none_instr (mkLdind DT_I2); - i_ldind_i4, I_none_instr (mkLdind DT_I4); - i_ldind_i8, I_none_instr (mkLdind DT_I8); - i_ldind_u1, I_none_instr (mkLdind DT_U1); - i_ldind_u2, I_none_instr (mkLdind DT_U2); - i_ldind_u4, I_none_instr (mkLdind DT_U4); - i_ldind_r4, I_none_instr (mkLdind DT_R4); - i_ldind_r8, I_none_instr (mkLdind DT_R8); - i_ldind_ref, I_none_instr (mkLdind DT_REF); - i_cpblk, I_none_instr (volatileOrUnalignedPrefix I_cpblk); - i_initblk, I_none_instr (volatileOrUnalignedPrefix I_initblk); - i_ldc_i8, I_i64_instr (noPrefixes (fun x ->(AI_ldc (DT_I8, ILConst.I8 x)))); - i_ldc_i4, I_i32_i32_instr (noPrefixes mkLdcInt32); - i_ldc_i4_s, I_i32_i8_instr (noPrefixes mkLdcInt32); - i_ldc_r4, I_r4_instr (noPrefixes (fun x -> (AI_ldc (DT_R4, ILConst.R4 x)))); - i_ldc_r8, I_r8_instr (noPrefixes (fun x -> (AI_ldc (DT_R8, ILConst.R8 x)))); - i_ldfld, I_field_instr (volatileOrUnalignedPrefix(fun (x,y) fspec -> I_ldfld(x,y,fspec))); - i_stfld, I_field_instr (volatileOrUnalignedPrefix(fun (x,y) fspec -> I_stfld(x,y,fspec))); - i_ldsfld, I_field_instr (volatilePrefix (fun x fspec -> I_ldsfld (x, fspec))); - i_stsfld, I_field_instr (volatilePrefix (fun x fspec -> I_stsfld (x, fspec))); - i_ldflda, I_field_instr (noPrefixes I_ldflda); - i_ldsflda, I_field_instr (noPrefixes I_ldsflda); - i_call, I_method_instr (tailPrefix (fun tl (mspec,y) -> I_call (tl,mspec,y))); - i_ldftn, I_method_instr (noPrefixes (fun (mspec,_y) -> I_ldftn mspec)); - i_ldvirtftn, I_method_instr (noPrefixes (fun (mspec,_y) -> I_ldvirtftn mspec)); - i_newobj, I_method_instr (noPrefixes I_newobj); - i_callvirt, I_method_instr (constraintOrTailPrefix (fun (c,tl) (mspec,y) -> match c with Some ty -> I_callconstraint(tl,ty,mspec,y) | None -> I_callvirt (tl,mspec,y))); - i_leave_s, I_unconditional_i8_instr (noPrefixes (fun x -> I_leave x)); - i_br_s, I_unconditional_i8_instr (noPrefixes I_br); - i_leave, I_unconditional_i32_instr (noPrefixes (fun x -> I_leave x)); - i_br, I_unconditional_i32_instr (noPrefixes I_br); - i_brtrue_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue,x))); - i_brfalse_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse,x))); - i_beq_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_beq,x))); - i_blt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt,x))); - i_blt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un,x))); - i_ble_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble,x))); - i_ble_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un,x))); - i_bgt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt,x))); - i_bgt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un,x))); - i_bge_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge,x))); - i_bge_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un,x))); - i_bne_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un,x))); - i_brtrue, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue,x))); - i_brfalse, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse,x))); - i_beq, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_beq,x))); - i_blt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt,x))); - i_blt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un,x))); - i_ble, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble,x))); - i_ble_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un,x))); - i_bgt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt,x))); - i_bgt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un,x))); - i_bge, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge,x))); - i_bge_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un,x))); - i_bne_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un,x))); - i_ldstr, I_string_instr (noPrefixes I_ldstr); - i_switch, I_switch_instr (noPrefixes I_switch); - i_ldtoken, I_tok_instr (noPrefixes I_ldtoken); - i_calli, I_sig_instr (tailPrefix (fun tl (x,y) -> I_calli (tl, x, y))); - i_mkrefany, I_type_instr (noPrefixes I_mkrefany); - i_refanyval, I_type_instr (noPrefixes I_refanyval); - i_ldelema, I_type_instr (readonlyPrefix (fun ro x -> I_ldelema (ro,false,ILArrayShape.SingleDimensional,x))); - i_ldelem_any, I_type_instr (noPrefixes (fun x -> I_ldelem_any (ILArrayShape.SingleDimensional,x))); - i_stelem_any, I_type_instr (noPrefixes (fun x -> I_stelem_any (ILArrayShape.SingleDimensional,x))); - i_newarr, I_type_instr (noPrefixes (fun x -> I_newarr (ILArrayShape.SingleDimensional,x))); - i_castclass, I_type_instr (noPrefixes I_castclass); - i_isinst, I_type_instr (noPrefixes I_isinst); - i_unbox_any, I_type_instr (noPrefixes I_unbox_any); - i_cpobj, I_type_instr (noPrefixes I_cpobj); - i_initobj, I_type_instr (noPrefixes I_initobj); - i_ldobj, I_type_instr (volatileOrUnalignedPrefix (fun (x,y) z -> I_ldobj (x,y,z))); - i_stobj, I_type_instr (volatileOrUnalignedPrefix (fun (x,y) z -> I_stobj (x,y,z))); - i_sizeof, I_type_instr (noPrefixes I_sizeof); - i_box, I_type_instr (noPrefixes I_box); - i_unbox, I_type_instr (noPrefixes I_unbox); ] + [ i_ldarg_s, I_u16_u8_instr (noPrefixes mkLdarg) + i_starg_s, I_u16_u8_instr (noPrefixes I_starg) + i_ldarga_s, I_u16_u8_instr (noPrefixes I_ldarga) + i_stloc_s, I_u16_u8_instr (noPrefixes mkStloc) + i_ldloc_s, I_u16_u8_instr (noPrefixes mkLdloc) + i_ldloca_s, I_u16_u8_instr (noPrefixes I_ldloca) + i_ldarg, I_u16_u16_instr (noPrefixes mkLdarg) + i_starg, I_u16_u16_instr (noPrefixes I_starg) + i_ldarga, I_u16_u16_instr (noPrefixes I_ldarga) + i_stloc, I_u16_u16_instr (noPrefixes mkStloc) + i_ldloc, I_u16_u16_instr (noPrefixes mkLdloc) + i_ldloca, I_u16_u16_instr (noPrefixes I_ldloca) + i_stind_i, I_none_instr (mkStind DT_I) + i_stind_i1, I_none_instr (mkStind DT_I1) + i_stind_i2, I_none_instr (mkStind DT_I2) + i_stind_i4, I_none_instr (mkStind DT_I4) + i_stind_i8, I_none_instr (mkStind DT_I8) + i_stind_r4, I_none_instr (mkStind DT_R4) + i_stind_r8, I_none_instr (mkStind DT_R8) + i_stind_ref, I_none_instr (mkStind DT_REF) + i_ldind_i, I_none_instr (mkLdind DT_I) + i_ldind_i1, I_none_instr (mkLdind DT_I1) + i_ldind_i2, I_none_instr (mkLdind DT_I2) + i_ldind_i4, I_none_instr (mkLdind DT_I4) + i_ldind_i8, I_none_instr (mkLdind DT_I8) + i_ldind_u1, I_none_instr (mkLdind DT_U1) + i_ldind_u2, I_none_instr (mkLdind DT_U2) + i_ldind_u4, I_none_instr (mkLdind DT_U4) + i_ldind_r4, I_none_instr (mkLdind DT_R4) + i_ldind_r8, I_none_instr (mkLdind DT_R8) + i_ldind_ref, I_none_instr (mkLdind DT_REF) + i_cpblk, I_none_instr (volatileOrUnalignedPrefix I_cpblk) + i_initblk, I_none_instr (volatileOrUnalignedPrefix I_initblk) + i_ldc_i8, I_i64_instr (noPrefixes (fun x ->(AI_ldc (DT_I8, ILConst.I8 x)))) + i_ldc_i4, I_i32_i32_instr (noPrefixes mkLdcInt32) + i_ldc_i4_s, I_i32_i8_instr (noPrefixes mkLdcInt32) + i_ldc_r4, I_r4_instr (noPrefixes (fun x -> (AI_ldc (DT_R4, ILConst.R4 x)))) + i_ldc_r8, I_r8_instr (noPrefixes (fun x -> (AI_ldc (DT_R8, ILConst.R8 x)))) + i_ldfld, I_field_instr (volatileOrUnalignedPrefix(fun (x,y) fspec -> I_ldfld(x,y,fspec))) + i_stfld, I_field_instr (volatileOrUnalignedPrefix(fun (x,y) fspec -> I_stfld(x,y,fspec))) + i_ldsfld, I_field_instr (volatilePrefix (fun x fspec -> I_ldsfld (x, fspec))) + i_stsfld, I_field_instr (volatilePrefix (fun x fspec -> I_stsfld (x, fspec))) + i_ldflda, I_field_instr (noPrefixes I_ldflda) + i_ldsflda, I_field_instr (noPrefixes I_ldsflda) + i_call, I_method_instr (tailPrefix (fun tl (mspec,y) -> I_call (tl,mspec,y))) + i_ldftn, I_method_instr (noPrefixes (fun (mspec,_y) -> I_ldftn mspec)) + i_ldvirtftn, I_method_instr (noPrefixes (fun (mspec,_y) -> I_ldvirtftn mspec)) + i_newobj, I_method_instr (noPrefixes I_newobj) + i_callvirt, I_method_instr (constraintOrTailPrefix (fun (c,tl) (mspec,y) -> match c with Some ty -> I_callconstraint(tl,ty,mspec,y) | None -> I_callvirt (tl,mspec,y))) + i_leave_s, I_unconditional_i8_instr (noPrefixes (fun x -> I_leave x)) + i_br_s, I_unconditional_i8_instr (noPrefixes I_br) + i_leave, I_unconditional_i32_instr (noPrefixes (fun x -> I_leave x)) + i_br, I_unconditional_i32_instr (noPrefixes I_br) + i_brtrue_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue,x))) + i_brfalse_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse,x))) + i_beq_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_beq,x))) + i_blt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt,x))) + i_blt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un,x))) + i_ble_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble,x))) + i_ble_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un,x))) + i_bgt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt,x))) + i_bgt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un,x))) + i_bge_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge,x))) + i_bge_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un,x))) + i_bne_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un,x))) + i_brtrue, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue,x))) + i_brfalse, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse,x))) + i_beq, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_beq,x))) + i_blt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt,x))) + i_blt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un,x))) + i_ble, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble,x))) + i_ble_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un,x))) + i_bgt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt,x))) + i_bgt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un,x))) + i_bge, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge,x))) + i_bge_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un,x))) + i_bne_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un,x))) + i_ldstr, I_string_instr (noPrefixes I_ldstr) + i_switch, I_switch_instr (noPrefixes I_switch) + i_ldtoken, I_tok_instr (noPrefixes I_ldtoken) + i_calli, I_sig_instr (tailPrefix (fun tl (x,y) -> I_calli (tl, x, y))) + i_mkrefany, I_type_instr (noPrefixes I_mkrefany) + i_refanyval, I_type_instr (noPrefixes I_refanyval) + i_ldelema, I_type_instr (readonlyPrefix (fun ro x -> I_ldelema (ro,false,ILArrayShape.SingleDimensional,x))) + i_ldelem_any, I_type_instr (noPrefixes (fun x -> I_ldelem_any (ILArrayShape.SingleDimensional,x))) + i_stelem_any, I_type_instr (noPrefixes (fun x -> I_stelem_any (ILArrayShape.SingleDimensional,x))) + i_newarr, I_type_instr (noPrefixes (fun x -> I_newarr (ILArrayShape.SingleDimensional,x))) + i_castclass, I_type_instr (noPrefixes I_castclass) + i_isinst, I_type_instr (noPrefixes I_isinst) + i_unbox_any, I_type_instr (noPrefixes I_unbox_any) + i_cpobj, I_type_instr (noPrefixes I_cpobj) + i_initobj, I_type_instr (noPrefixes I_initobj) + i_ldobj, I_type_instr (volatileOrUnalignedPrefix (fun (x,y) z -> I_ldobj (x,y,z))) + i_stobj, I_type_instr (volatileOrUnalignedPrefix (fun (x,y) z -> I_stobj (x,y,z))) + i_sizeof, I_type_instr (noPrefixes I_sizeof) + i_box, I_type_instr (noPrefixes I_box) + i_unbox, I_type_instr (noPrefixes I_unbox) ] // The tables are delayed to avoid building them unnecessarily at startup // Many applications of AbsIL (e.g. a compiler) don't need to read instructions. @@ -603,20 +603,20 @@ let fillInstrs () = let twoByteInstrTable = Array.create 256 I_invalid_instr let addInstr (i,f) = if i > 0xff then - assert (i >>>& 8 = 0xfe); + assert (i >>>& 8 = 0xfe) let i = (i &&& 0xff) match twoByteInstrTable.[i] with | I_invalid_instr -> () - | _ -> dprintn ("warning: duplicate decode entries for "+string i); + | _ -> dprintn ("warning: duplicate decode entries for "+string i) twoByteInstrTable.[i] <- f else match oneByteInstrTable.[i] with | I_invalid_instr -> () - | _ -> dprintn ("warning: duplicate decode entries for "+string i); + | _ -> dprintn ("warning: duplicate decode entries for "+string i) oneByteInstrTable.[i] <- f - List.iter addInstr (instrs()); - List.iter (fun (x,mk) -> addInstr (x,I_none_instr (noPrefixes mk))) (noArgInstrs.Force()); - oneByteInstrs := Some oneByteInstrTable; + List.iter addInstr (instrs()) + List.iter (fun (x,mk) -> addInstr (x,I_none_instr (noPrefixes mk))) (noArgInstrs.Force()) + oneByteInstrs := Some oneByteInstrTable twoByteInstrs := Some twoByteInstrTable let rec getOneByteInstr i = @@ -758,7 +758,7 @@ let mkCacheInt32 lowMem _inbase _nm _sz = let cache = ref null let count = ref 0 #if STATISTICS - addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " "+ _nm + " cache hits") : string)); + addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " "+ _nm + " cache hits") : string)) #endif fun f (idx:int32) -> let cache = @@ -769,11 +769,11 @@ let mkCacheInt32 lowMem _inbase _nm _sz = let mutable res = Unchecked.defaultof<_> let ok = cache.TryGetValue(idx, &res) if ok then - incr count; + incr count res else let res = f idx - cache.[idx] <- res; + cache.[idx] <- res res let mkCacheGeneric lowMem _inbase _nm _sz = @@ -781,7 +781,7 @@ let mkCacheGeneric lowMem _inbase _nm _sz = let cache = ref null let count = ref 0 #if STATISTICS - addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " " + _nm + " cache hits") : string)); + addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " " + _nm + " cache hits") : string)) #endif fun f (idx :'T) -> let cache = @@ -799,8 +799,8 @@ let mkCacheGeneric lowMem _inbase _nm _sz = let seekFindRow numRows rowChooser = let mutable i = 1 while (i <= numRows && not (rowChooser i)) do - i <- i + 1; - if i > numRows then dprintn "warning: seekFindRow: row not found"; + i <- i + 1 + if i > numRows then dprintn "warning: seekFindRow: row not found" i // search for rows satisfying predicate @@ -823,7 +823,7 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r high <- mid else fin <- true - end; + end let mutable res = [] if high - low > 1 then // now read off rows, forward and backwards @@ -834,17 +834,17 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r let mutable curr = mid while not fin do if curr > numRows then - fin <- true; + fin <- true else let currrow = rowReader curr if keyComparer (keyFunc currrow) = 0 then - res <- rowConverter currrow :: res; + res <- rowConverter currrow :: res else - fin <- true; - curr <- curr + 1; - done; - end; - res <- List.rev res; + fin <- true + curr <- curr + 1 + done + end + res <- List.rev res // read backwards begin let mutable fin = false @@ -855,11 +855,11 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r else let currrow = rowReader curr if keyComparer (keyFunc currrow) = 0 then - res <- rowConverter currrow :: res; + res <- rowConverter currrow :: res else - fin <- true; - curr <- curr - 1; - end; + fin <- true + curr <- curr - 1 + end // sanity check #if CHECKING if checking then @@ -878,7 +878,7 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r for i = 1 to numRows do let rowinfo = rowReader i if keyComparer (keyFunc rowinfo) = 0 then - res := rowConverter rowinfo :: !res; + res := rowConverter rowinfo :: !res List.rev !res @@ -887,7 +887,7 @@ let seekReadOptionalIndexedRow (info) = | [k] -> Some k | [] -> None | h::_ -> - dprintn ("multiple rows found when indexing table"); + dprintn ("multiple rows found when indexing table") Some h let seekReadIndexedRow (info) = @@ -900,7 +900,7 @@ let seekReadIndexedRow (info) = //--------------------------------------------------------------------- type ILModuleReader = - { modul: ILModuleDef; + { modul: ILModuleDef ilAssemblyRefs: Lazy dispose: unit -> unit } member x.ILModuleDef = x.modul @@ -914,113 +914,113 @@ type VarArgMethodData = VarArgMethodData of ILType * ILCallingConv * string * IL [] type ILReaderContext = - { ilg: ILGlobals; - dataEndPoints: Lazy; - sorted: int64; + { ilg: ILGlobals + dataEndPoints: Lazy + sorted: int64 #if FX_NO_PDB_READER - pdb: obj option; + pdb: obj option #else - pdb: (PdbReader * (string -> ILSourceDocument)) option; + pdb: (PdbReader * (string -> ILSourceDocument)) option #endif - entryPointToken: TableName * int; - getNumRows: TableName -> int; - textSegmentPhysicalLoc : int32; - textSegmentPhysicalSize : int32; - dataSegmentPhysicalLoc : int32; - dataSegmentPhysicalSize : int32; - anyV2P : (string * int32) -> int32; - metadataAddr: int32; - sectionHeaders : (int32 * int32 * int32) list; - nativeResourcesAddr:int32; - nativeResourcesSize:int32; - resourcesAddr:int32; - strongnameAddr:int32; - vtableFixupsAddr:int32; - is: BinaryFile; - infile:string; - userStringsStreamPhysicalLoc: int32; - stringsStreamPhysicalLoc: int32; - blobsStreamPhysicalLoc: int32; - blobsStreamSize: int32; - readUserStringHeap: (int32 -> string); - memoizeString: string -> string; - readStringHeap: (int32 -> string); - readBlobHeap: (int32 -> byte[]); - guidsStreamPhysicalLoc : int32; - rowAddr : (TableName -> int -> int32); - tableBigness : bool array; - rsBigness : bool; - tdorBigness : bool; - tomdBigness : bool; - hcBigness : bool; - hcaBigness : bool; - hfmBigness : bool; - hdsBigness : bool; - mrpBigness : bool; - hsBigness : bool; - mdorBigness : bool; - mfBigness : bool; - iBigness : bool; - catBigness : bool; - stringsBigness: bool; - guidsBigness: bool; - blobsBigness: bool; - countTypeRef : int ref; - countTypeDef : int ref; - countField : int ref; - countMethod : int ref; - countParam : int ref; - countInterfaceImpl : int ref; - countMemberRef : int ref; - countConstant : int ref; - countCustomAttribute : int ref; - countFieldMarshal: int ref; - countPermission : int ref; - countClassLayout : int ref; - countFieldLayout : int ref; - countStandAloneSig : int ref; - countEventMap : int ref; - countEvent : int ref; - countPropertyMap : int ref; - countProperty : int ref; - countMethodSemantics : int ref; - countMethodImpl : int ref; - countModuleRef : int ref; - countTypeSpec : int ref; - countImplMap : int ref; - countFieldRVA : int ref; - countAssembly : int ref; - countAssemblyRef : int ref; - countFile : int ref; - countExportedType : int ref; - countManifestResource : int ref; - countNested : int ref; - countGenericParam : int ref; - countGenericParamConstraint : int ref; - countMethodSpec : int ref; - seekReadNestedRow : int -> int * int; - seekReadConstantRow : int -> uint16 * TaggedIndex * int32; - seekReadMethodSemanticsRow : int -> int32 * int * TaggedIndex; - seekReadTypeDefRow : int -> int32 * int32 * int32 * TaggedIndex * int * int; - seekReadInterfaceImplRow : int -> int * TaggedIndex; - seekReadFieldMarshalRow : int -> TaggedIndex * int32; - seekReadPropertyMapRow : int -> int * int; - seekReadAssemblyRef : int -> ILAssemblyRef; - seekReadMethodSpecAsMethodData : MethodSpecAsMspecIdx -> VarArgMethodData; - seekReadMemberRefAsMethodData : MemberRefAsMspecIdx -> VarArgMethodData; - seekReadMemberRefAsFieldSpec : MemberRefAsFspecIdx -> ILFieldSpec; - seekReadCustomAttr : CustomAttrIdx -> ILAttribute; - seekReadSecurityDecl : SecurityDeclIdx -> ILPermission; - seekReadTypeRef : int ->ILTypeRef; - seekReadTypeRefAsType : TypeRefAsTypIdx -> ILType; - readBlobHeapAsPropertySig : BlobAsPropSigIdx -> ILThisConvention * ILType * ILTypes; - readBlobHeapAsFieldSig : BlobAsFieldSigIdx -> ILType; - readBlobHeapAsMethodSig : BlobAsMethodSigIdx -> bool * int32 * ILCallingConv * ILType * ILTypes * ILVarArgs; - readBlobHeapAsLocalsSig : BlobAsLocalSigIdx -> ILLocal list; - seekReadTypeDefAsType : TypeDefAsTypIdx -> ILType; - seekReadMethodDefAsMethodData : int -> MethodData; - seekReadGenericParams : GenericParamsIdx -> ILGenericParameterDef list; - seekReadFieldDefAsFieldSpec : int -> ILFieldSpec; } + entryPointToken: TableName * int + getNumRows: TableName -> int + textSegmentPhysicalLoc : int32 + textSegmentPhysicalSize : int32 + dataSegmentPhysicalLoc : int32 + dataSegmentPhysicalSize : int32 + anyV2P : (string * int32) -> int32 + metadataAddr: int32 + sectionHeaders : (int32 * int32 * int32) list + nativeResourcesAddr:int32 + nativeResourcesSize:int32 + resourcesAddr:int32 + strongnameAddr:int32 + vtableFixupsAddr:int32 + is: BinaryFile + infile:string + userStringsStreamPhysicalLoc: int32 + stringsStreamPhysicalLoc: int32 + blobsStreamPhysicalLoc: int32 + blobsStreamSize: int32 + readUserStringHeap: (int32 -> string) + memoizeString: string -> string + readStringHeap: (int32 -> string) + readBlobHeap: (int32 -> byte[]) + guidsStreamPhysicalLoc : int32 + rowAddr : (TableName -> int -> int32) + tableBigness : bool array + rsBigness : bool + tdorBigness : bool + tomdBigness : bool + hcBigness : bool + hcaBigness : bool + hfmBigness : bool + hdsBigness : bool + mrpBigness : bool + hsBigness : bool + mdorBigness : bool + mfBigness : bool + iBigness : bool + catBigness : bool + stringsBigness: bool + guidsBigness: bool + blobsBigness: bool + countTypeRef : int ref + countTypeDef : int ref + countField : int ref + countMethod : int ref + countParam : int ref + countInterfaceImpl : int ref + countMemberRef : int ref + countConstant : int ref + countCustomAttribute : int ref + countFieldMarshal: int ref + countPermission : int ref + countClassLayout : int ref + countFieldLayout : int ref + countStandAloneSig : int ref + countEventMap : int ref + countEvent : int ref + countPropertyMap : int ref + countProperty : int ref + countMethodSemantics : int ref + countMethodImpl : int ref + countModuleRef : int ref + countTypeSpec : int ref + countImplMap : int ref + countFieldRVA : int ref + countAssembly : int ref + countAssemblyRef : int ref + countFile : int ref + countExportedType : int ref + countManifestResource : int ref + countNested : int ref + countGenericParam : int ref + countGenericParamConstraint : int ref + countMethodSpec : int ref + seekReadNestedRow : int -> int * int + seekReadConstantRow : int -> uint16 * TaggedIndex * int32 + seekReadMethodSemanticsRow : int -> int32 * int * TaggedIndex + seekReadTypeDefRow : int -> int32 * int32 * int32 * TaggedIndex * int * int + seekReadInterfaceImplRow : int -> int * TaggedIndex + seekReadFieldMarshalRow : int -> TaggedIndex * int32 + seekReadPropertyMapRow : int -> int * int + seekReadAssemblyRef : int -> ILAssemblyRef + seekReadMethodSpecAsMethodData : MethodSpecAsMspecIdx -> VarArgMethodData + seekReadMemberRefAsMethodData : MemberRefAsMspecIdx -> VarArgMethodData + seekReadMemberRefAsFieldSpec : MemberRefAsFspecIdx -> ILFieldSpec + seekReadCustomAttr : CustomAttrIdx -> ILAttribute + seekReadSecurityDecl : SecurityDeclIdx -> ILPermission + seekReadTypeRef : int ->ILTypeRef + seekReadTypeRefAsType : TypeRefAsTypIdx -> ILType + readBlobHeapAsPropertySig : BlobAsPropSigIdx -> ILThisConvention * ILType * ILTypes + readBlobHeapAsFieldSig : BlobAsFieldSigIdx -> ILType + readBlobHeapAsMethodSig : BlobAsMethodSigIdx -> bool * int32 * ILCallingConv * ILType * ILTypes * ILVarArgs + readBlobHeapAsLocalsSig : BlobAsLocalSigIdx -> ILLocal list + seekReadTypeDefAsType : TypeDefAsTypIdx -> ILType + seekReadMethodDefAsMethodData : int -> MethodData + seekReadGenericParams : GenericParamsIdx -> ILGenericParameterDef list + seekReadFieldDefAsFieldSpec : int -> ILFieldSpec } let count c = #if DEBUG @@ -1076,7 +1076,7 @@ let seekReadGuidIdx ctxt (addr: byref) = seekReadIdx ctxt.guidsBigness ctxt let seekReadBlobIdx ctxt (addr: byref) = seekReadIdx ctxt.blobsBigness ctxt &addr let seekReadModuleRow ctxt idx = - if idx = 0 then failwith "cannot read Module table row 0"; + if idx = 0 then failwith "cannot read Module table row 0" let mutable addr = ctxt.rowAddr TableNames.Module idx let generation = seekReadUInt16Adv ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1087,7 +1087,7 @@ let seekReadModuleRow ctxt idx = /// Read Table ILTypeRef. let seekReadTypeRefRow ctxt idx = - count ctxt.countTypeRef; + count ctxt.countTypeRef let mutable addr = ctxt.rowAddr TableNames.TypeRef idx let scopeIdx = seekReadResolutionScopeIdx ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1098,7 +1098,7 @@ let seekReadTypeRefRow ctxt idx = let seekReadTypeDefRow ctxt idx = ctxt.seekReadTypeDefRow idx let seekReadTypeDefRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countTypeDef; + count ctxt.countTypeDef let mutable addr = ctxt.rowAddr TableNames.TypeDef idx let flags = seekReadInt32Adv ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1110,7 +1110,7 @@ let seekReadTypeDefRowUncached ctxtH idx = /// Read Table Field. let seekReadFieldRow ctxt idx = - count ctxt.countField; + count ctxt.countField let mutable addr = ctxt.rowAddr TableNames.Field idx let flags = seekReadUInt16AsInt32Adv ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1119,7 +1119,7 @@ let seekReadFieldRow ctxt idx = /// Read Table Method. let seekReadMethodRow ctxt idx = - count ctxt.countMethod; + count ctxt.countMethod let mutable addr = ctxt.rowAddr TableNames.Method idx let codeRVA = seekReadInt32Adv ctxt &addr let implflags = seekReadUInt16AsInt32Adv ctxt &addr @@ -1131,7 +1131,7 @@ let seekReadMethodRow ctxt idx = /// Read Table Param. let seekReadParamRow ctxt idx = - count ctxt.countParam; + count ctxt.countParam let mutable addr = ctxt.rowAddr TableNames.Param idx let flags = seekReadUInt16AsInt32Adv ctxt &addr let seq = seekReadUInt16AsInt32Adv ctxt &addr @@ -1142,7 +1142,7 @@ let seekReadParamRow ctxt idx = let seekReadInterfaceImplRow ctxt idx = ctxt.seekReadInterfaceImplRow idx let seekReadInterfaceImplRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countInterfaceImpl; + count ctxt.countInterfaceImpl let mutable addr = ctxt.rowAddr TableNames.InterfaceImpl idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr @@ -1150,7 +1150,7 @@ let seekReadInterfaceImplRowUncached ctxtH idx = /// Read Table MemberRef. let seekReadMemberRefRow ctxt idx = - count ctxt.countMemberRef; + count ctxt.countMemberRef let mutable addr = ctxt.rowAddr TableNames.MemberRef idx let mrpIdx = seekReadMemberRefParentIdx ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1161,7 +1161,7 @@ let seekReadMemberRefRow ctxt idx = let seekReadConstantRow ctxt idx = ctxt.seekReadConstantRow idx let seekReadConstantRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countConstant; + count ctxt.countConstant let mutable addr = ctxt.rowAddr TableNames.Constant idx let kind = seekReadUInt16Adv ctxt &addr let parentIdx = seekReadHasConstantIdx ctxt &addr @@ -1170,7 +1170,7 @@ let seekReadConstantRowUncached ctxtH idx = /// Read Table CustomAttribute. let seekReadCustomAttributeRow ctxt idx = - count ctxt.countCustomAttribute; + count ctxt.countCustomAttribute let mutable addr = ctxt.rowAddr TableNames.CustomAttribute idx let parentIdx = seekReadHasCustomAttributeIdx ctxt &addr let typeIdx = seekReadCustomAttributeTypeIdx ctxt &addr @@ -1181,7 +1181,7 @@ let seekReadCustomAttributeRow ctxt idx = let seekReadFieldMarshalRow ctxt idx = ctxt.seekReadFieldMarshalRow idx let seekReadFieldMarshalRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countFieldMarshal; + count ctxt.countFieldMarshal let mutable addr = ctxt.rowAddr TableNames.FieldMarshal idx let parentIdx = seekReadHasFieldMarshalIdx ctxt &addr let typeIdx = seekReadBlobIdx ctxt &addr @@ -1189,7 +1189,7 @@ let seekReadFieldMarshalRowUncached ctxtH idx = /// Read Table Permission. let seekReadPermissionRow ctxt idx = - count ctxt.countPermission; + count ctxt.countPermission let mutable addr = ctxt.rowAddr TableNames.Permission idx let action = seekReadUInt16Adv ctxt &addr let parentIdx = seekReadHasDeclSecurityIdx ctxt &addr @@ -1198,7 +1198,7 @@ let seekReadPermissionRow ctxt idx = /// Read Table ClassLayout. let seekReadClassLayoutRow ctxt idx = - count ctxt.countClassLayout; + count ctxt.countClassLayout let mutable addr = ctxt.rowAddr TableNames.ClassLayout idx let pack = seekReadUInt16Adv ctxt &addr let size = seekReadInt32Adv ctxt &addr @@ -1207,7 +1207,7 @@ let seekReadClassLayoutRow ctxt idx = /// Read Table FieldLayout. let seekReadFieldLayoutRow ctxt idx = - count ctxt.countFieldLayout; + count ctxt.countFieldLayout let mutable addr = ctxt.rowAddr TableNames.FieldLayout idx let offset = seekReadInt32Adv ctxt &addr let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr @@ -1215,14 +1215,14 @@ let seekReadFieldLayoutRow ctxt idx = //// Read Table StandAloneSig. let seekReadStandAloneSigRow ctxt idx = - count ctxt.countStandAloneSig; + count ctxt.countStandAloneSig let mutable addr = ctxt.rowAddr TableNames.StandAloneSig idx let sigIdx = seekReadBlobIdx ctxt &addr sigIdx /// Read Table EventMap. let seekReadEventMapRow ctxt idx = - count ctxt.countEventMap; + count ctxt.countEventMap let mutable addr = ctxt.rowAddr TableNames.EventMap idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt &addr @@ -1230,7 +1230,7 @@ let seekReadEventMapRow ctxt idx = /// Read Table Event. let seekReadEventRow ctxt idx = - count ctxt.countEvent; + count ctxt.countEvent let mutable addr = ctxt.rowAddr TableNames.Event idx let flags = seekReadUInt16AsInt32Adv ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1241,7 +1241,7 @@ let seekReadEventRow ctxt idx = let seekReadPropertyMapRow ctxt idx = ctxt.seekReadPropertyMapRow idx let seekReadPropertyMapRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countPropertyMap; + count ctxt.countPropertyMap let mutable addr = ctxt.rowAddr TableNames.PropertyMap idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt &addr @@ -1249,7 +1249,7 @@ let seekReadPropertyMapRowUncached ctxtH idx = /// Read Table Property. let seekReadPropertyRow ctxt idx = - count ctxt.countProperty; + count ctxt.countProperty let mutable addr = ctxt.rowAddr TableNames.Property idx let flags = seekReadUInt16AsInt32Adv ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1260,7 +1260,7 @@ let seekReadPropertyRow ctxt idx = let seekReadMethodSemanticsRow ctxt idx = ctxt.seekReadMethodSemanticsRow idx let seekReadMethodSemanticsRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countMethodSemantics; + count ctxt.countMethodSemantics let mutable addr = ctxt.rowAddr TableNames.MethodSemantics idx let flags = seekReadUInt16AsInt32Adv ctxt &addr let midx = seekReadUntaggedIdx TableNames.Method ctxt &addr @@ -1269,7 +1269,7 @@ let seekReadMethodSemanticsRowUncached ctxtH idx = /// Read Table MethodImpl. let seekReadMethodImplRow ctxt idx = - count ctxt.countMethodImpl; + count ctxt.countMethodImpl let mutable addr = ctxt.rowAddr TableNames.MethodImpl idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr let mbodyIdx = seekReadMethodDefOrRefIdx ctxt &addr @@ -1278,21 +1278,21 @@ let seekReadMethodImplRow ctxt idx = /// Read Table ILModuleRef. let seekReadModuleRefRow ctxt idx = - count ctxt.countModuleRef; + count ctxt.countModuleRef let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx let nameIdx = seekReadStringIdx ctxt &addr nameIdx /// Read Table ILTypeSpec. let seekReadTypeSpecRow ctxt idx = - count ctxt.countTypeSpec; + count ctxt.countTypeSpec let mutable addr = ctxt.rowAddr TableNames.TypeSpec idx let blobIdx = seekReadBlobIdx ctxt &addr blobIdx /// Read Table ImplMap. let seekReadImplMapRow ctxt idx = - count ctxt.countImplMap; + count ctxt.countImplMap let mutable addr = ctxt.rowAddr TableNames.ImplMap idx let flags = seekReadUInt16AsInt32Adv ctxt &addr let forwrdedIdx = seekReadMemberForwardedIdx ctxt &addr @@ -1302,7 +1302,7 @@ let seekReadImplMapRow ctxt idx = /// Read Table FieldRVA. let seekReadFieldRVARow ctxt idx = - count ctxt.countFieldRVA; + count ctxt.countFieldRVA let mutable addr = ctxt.rowAddr TableNames.FieldRVA idx let rva = seekReadInt32Adv ctxt &addr let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr @@ -1310,7 +1310,7 @@ let seekReadFieldRVARow ctxt idx = /// Read Table Assembly. let seekReadAssemblyRow ctxt idx = - count ctxt.countAssembly; + count ctxt.countAssembly let mutable addr = ctxt.rowAddr TableNames.Assembly idx let hash = seekReadInt32Adv ctxt &addr let v1 = seekReadUInt16Adv ctxt &addr @@ -1325,7 +1325,7 @@ let seekReadAssemblyRow ctxt idx = /// Read Table ILAssemblyRef. let seekReadAssemblyRefRow ctxt idx = - count ctxt.countAssemblyRef; + count ctxt.countAssemblyRef let mutable addr = ctxt.rowAddr TableNames.AssemblyRef idx let v1 = seekReadUInt16Adv ctxt &addr let v2 = seekReadUInt16Adv ctxt &addr @@ -1340,7 +1340,7 @@ let seekReadAssemblyRefRow ctxt idx = /// Read Table File. let seekReadFileRow ctxt idx = - count ctxt.countFile; + count ctxt.countFile let mutable addr = ctxt.rowAddr TableNames.File idx let flags = seekReadInt32Adv ctxt &addr let nameIdx = seekReadStringIdx ctxt &addr @@ -1349,7 +1349,7 @@ let seekReadFileRow ctxt idx = /// Read Table ILExportedTypeOrForwarder. let seekReadExportedTypeRow ctxt idx = - count ctxt.countExportedType; + count ctxt.countExportedType let mutable addr = ctxt.rowAddr TableNames.ExportedType idx let flags = seekReadInt32Adv ctxt &addr let tok = seekReadInt32Adv ctxt &addr @@ -1360,7 +1360,7 @@ let seekReadExportedTypeRow ctxt idx = /// Read Table ManifestResource. let seekReadManifestResourceRow ctxt idx = - count ctxt.countManifestResource; + count ctxt.countManifestResource let mutable addr = ctxt.rowAddr TableNames.ManifestResource idx let offset = seekReadInt32Adv ctxt &addr let flags = seekReadInt32Adv ctxt &addr @@ -1372,7 +1372,7 @@ let seekReadManifestResourceRow ctxt idx = let seekReadNestedRow ctxt idx = ctxt.seekReadNestedRow idx let seekReadNestedRowUncached ctxtH idx = let ctxt = getHole ctxtH - count ctxt.countNested; + count ctxt.countNested let mutable addr = ctxt.rowAddr TableNames.Nested idx let nestedIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr @@ -1380,7 +1380,7 @@ let seekReadNestedRowUncached ctxtH idx = /// Read Table GenericParam. let seekReadGenericParamRow ctxt idx = - count ctxt.countGenericParam; + count ctxt.countGenericParam let mutable addr = ctxt.rowAddr TableNames.GenericParam idx let seq = seekReadUInt16Adv ctxt &addr let flags = seekReadUInt16Adv ctxt &addr @@ -1390,7 +1390,7 @@ let seekReadGenericParamRow ctxt idx = // Read Table GenericParamConstraint. let seekReadGenericParamConstraintRow ctxt idx = - count ctxt.countGenericParamConstraint; + count ctxt.countGenericParamConstraint let mutable addr = ctxt.rowAddr TableNames.GenericParamConstraint idx let pidx = seekReadUntaggedIdx TableNames.GenericParam ctxt &addr let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr @@ -1398,7 +1398,7 @@ let seekReadGenericParamConstraintRow ctxt idx = /// Read Table ILMethodSpec. let seekReadMethodSpecRow ctxt idx = - count ctxt.countMethodSpec; + count ctxt.countMethodSpec let mutable addr = ctxt.rowAddr TableNames.MethodSpec idx let mdorIdx = seekReadMethodDefOrRefIdx ctxt &addr let instIdx = seekReadBlobIdx ctxt &addr @@ -1479,12 +1479,12 @@ let dataEndPoints ctxtH = let res = ref [] for i = 1 to ctxt.getNumRows (TableNames.FieldRVA) do let rva,_fidx = seekReadFieldRVARow ctxt i - res := ("field",rva) :: !res; + res := ("field",rva) :: !res for i = 1 to ctxt.getNumRows TableNames.ManifestResource do let (offset,_,_,TaggedIndex(_tag,idx)) = seekReadManifestResourceRow ctxt i if idx = 0 then let rva = ctxt.resourcesAddr + offset - res := ("manifest resource", rva) :: !res; + res := ("manifest resource", rva) :: !res !res if isNil dataStartPoints then [] else @@ -1494,19 +1494,19 @@ let dataEndPoints ctxtH = let (rva, _, _, nameIdx, _, _) = seekReadMethodRow ctxt i if rva <> 0 then let nm = readStringHeap ctxt nameIdx - res := (nm,rva) :: !res; + res := (nm,rva) :: !res !res - ([ ctxt.textSegmentPhysicalLoc + ctxt.textSegmentPhysicalSize; - ctxt.dataSegmentPhysicalLoc + ctxt.dataSegmentPhysicalSize; ] + ([ ctxt.textSegmentPhysicalLoc + ctxt.textSegmentPhysicalSize ; + ctxt.dataSegmentPhysicalLoc + ctxt.dataSegmentPhysicalSize ] @ (List.map ctxt.anyV2P (dataStartPoints @ [for (virtAddr,_virtSize,_physLoc) in ctxt.sectionHeaders do yield ("section start",virtAddr) done] @ [("md",ctxt.metadataAddr)] - @ (if ctxt.nativeResourcesAddr = 0x0 then [] else [("native resources",ctxt.nativeResourcesAddr); ]) - @ (if ctxt.resourcesAddr = 0x0 then [] else [("managed resources",ctxt.resourcesAddr); ]) - @ (if ctxt.strongnameAddr = 0x0 then [] else [("managed strongname",ctxt.strongnameAddr); ]) - @ (if ctxt.vtableFixupsAddr = 0x0 then [] else [("managed vtable_fixups",ctxt.vtableFixupsAddr); ]) + @ (if ctxt.nativeResourcesAddr = 0x0 then [] else [("native resources",ctxt.nativeResourcesAddr) ]) + @ (if ctxt.resourcesAddr = 0x0 then [] else [("managed resources",ctxt.resourcesAddr) ]) + @ (if ctxt.strongnameAddr = 0x0 then [] else [("managed strongname",ctxt.strongnameAddr) ]) + @ (if ctxt.vtableFixupsAddr = 0x0 then [] else [("managed vtable_fixups",ctxt.vtableFixupsAddr) ]) @ methodRVAs))) // Make distinct |> Set.ofList @@ -1515,7 +1515,7 @@ let dataEndPoints ctxtH = let rec rvaToData ctxt nm rva = - if rva = 0x0 then failwith "rva is zero"; + if rva = 0x0 then failwith "rva is zero" let start = ctxt.anyV2P (nm, rva) let endPoints = (Lazy.force ctxt.dataEndPoints) let rec look l = @@ -1543,38 +1543,38 @@ let rec seekReadModule ctxt (subsys,subsysversion,useHighEntropyVA, ilOnly,only3 { Manifest = if ctxt.getNumRows (TableNames.Assembly) > 0 then Some (seekReadAssemblyManifest ctxt 1) - else None; - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Module,idx)); - Name = ilModuleName; - NativeResources=nativeResources; - TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt ()); - SubSystemFlags = int32 subsys; - IsILOnly = ilOnly; + else None + CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Module,idx)) + Name = ilModuleName + NativeResources=nativeResources + TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt ()) + SubSystemFlags = int32 subsys + IsILOnly = ilOnly SubsystemVersion = subsysversion UseHighEntropyVA = useHighEntropyVA - Platform = platform; - StackReserveSize = None; // TODO - Is32Bit = only32; - Is32BitPreferred = is32bitpreferred; - Is64Bit = only64; - IsDLL=isDll; - VirtualAlignment = alignVirt; - PhysicalAlignment = alignPhys; - ImageBase = imageBaseReal; - MetadataVersion = ilMetadataVersion; - Resources = seekReadManifestResources ctxt (); } + Platform = platform + StackReserveSize = None // TODO + Is32Bit = only32 + Is32BitPreferred = is32bitpreferred + Is64Bit = only64 + IsDLL=isDll + VirtualAlignment = alignVirt + PhysicalAlignment = alignPhys + ImageBase = imageBaseReal + MetadataVersion = ilMetadataVersion + Resources = seekReadManifestResources ctxt () } and seekReadAssemblyManifest ctxt idx = let (hash,v1,v2,v3,v4,flags,publicKeyIdx, nameIdx, localeIdx) = seekReadAssemblyRow ctxt idx let name = readStringHeap ctxt nameIdx let pubkey = readBlobHeapOption ctxt publicKeyIdx - { Name= name; - AuxModuleHashAlgorithm=hash; - SecurityDecls= seekReadSecurityDecls ctxt (TaggedIndex(hds_Assembly,idx)); - PublicKey= pubkey; - Version= Some (v1,v2,v3,v4); - Locale= readStringHeapOption ctxt localeIdx; - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Assembly,idx)); + { Name= name + AuxModuleHashAlgorithm=hash + SecurityDecls= seekReadSecurityDecls ctxt (TaggedIndex(hds_Assembly,idx)) + PublicKey= pubkey + Version= Some (v1,v2,v3,v4) + Locale= readStringHeapOption ctxt localeIdx + CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Assembly,idx)) AssemblyLongevity= begin let masked = flags &&& 0x000e if masked = 0x0000 then ILAssemblyLongevity.Unspecified @@ -1583,12 +1583,12 @@ and seekReadAssemblyManifest ctxt idx = elif masked = 0x0006 then ILAssemblyLongevity.PlatformProcess elif masked = 0x0008 then ILAssemblyLongevity.PlatformSystem else ILAssemblyLongevity.Unspecified - end; - ExportedTypes= seekReadTopExportedTypes ctxt (); - EntrypointElsewhere=(if fst ctxt.entryPointToken = TableNames.File then Some (seekReadFile ctxt (snd ctxt.entryPointToken)) else None); - Retargetable = 0 <> (flags &&& 0x100); - DisableJitOptimizations = 0 <> (flags &&& 0x4000); - JitTracking = 0 <> (flags &&& 0x8000); } + end + ExportedTypes= seekReadTopExportedTypes ctxt () + EntrypointElsewhere=(if fst ctxt.entryPointToken = TableNames.File then Some (seekReadFile ctxt (snd ctxt.entryPointToken)) else None) + Retargetable = 0 <> (flags &&& 0x100) + DisableJitOptimizations = 0 <> (flags &&& 0x4000) + JitTracking = 0 <> (flags &&& 0x8000) } and seekReadAssemblyRef ctxt idx = ctxt.seekReadAssemblyRef idx and seekReadAssemblyRefUncached ctxtH idx = @@ -1606,7 +1606,7 @@ and seekReadAssemblyRefUncached ctxtH idx = publicKey=publicKey, retargetable=((flags &&& 0x0100) <> 0x0), version=Some(v1,v2,v3,v4), - locale=readStringHeapOption ctxt localeIdx;) + locale=readStringHeapOption ctxt localeIdx) and seekReadModuleRef ctxt idx = let (nameIdx) = seekReadModuleRefRow ctxt idx @@ -1623,8 +1623,7 @@ and seekReadFile ctxt idx = and seekReadClassLayout ctxt idx = match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.ClassLayout,seekReadClassLayoutRow ctxt,(fun (_,_,tidx) -> tidx),simpleIndexCompare idx,isSorted ctxt TableNames.ClassLayout,(fun (pack,size,_) -> pack,size)) with | None -> { Size = None; Pack = None } - | Some (pack,size) -> { Size = Some size; - Pack = Some pack; } + | Some (pack,size) -> { Size = Some size; Pack = Some pack } and memberAccessOfFlags flags = let f = (flags &&& 0x00000007) @@ -1736,32 +1735,32 @@ and seekReadTypeDef ctxt toponly (idx:int) = let mimpls = seekReadMethodImpls ctxt numtypars idx let props = seekReadProperties ctxt numtypars idx let events = seekReadEvents ctxt numtypars idx - { tdKind= kind; - Name=nm; - GenericParams=typars; - Access= typeAccessOfFlags flags; - IsAbstract= (flags &&& 0x00000080) <> 0x0; - IsSealed= (flags &&& 0x00000100) <> 0x0; - IsSerializable= (flags &&& 0x00002000) <> 0x0; - IsComInterop= (flags &&& 0x00001000) <> 0x0; - Layout = layout; - IsSpecialName= (flags &&& 0x00000400) <> 0x0; - Encoding=typeEncodingOfFlags flags; - NestedTypes= nested; - Implements = mkILTypes impls; - Extends = super; - Methods = mdefs; - SecurityDecls = sdecls; - HasSecurity=(flags &&& 0x00040000) <> 0x0; - Fields=fdefs; - MethodImpls=mimpls; + { tdKind= kind + Name=nm + GenericParams=typars + Access= typeAccessOfFlags flags + IsAbstract= (flags &&& 0x00000080) <> 0x0 + IsSealed= (flags &&& 0x00000100) <> 0x0 + IsSerializable= (flags &&& 0x00002000) <> 0x0 + IsComInterop= (flags &&& 0x00001000) <> 0x0 + Layout = layout + IsSpecialName= (flags &&& 0x00000400) <> 0x0 + Encoding=typeEncodingOfFlags flags + NestedTypes= nested + Implements = mkILTypes impls + Extends = super + Methods = mdefs + SecurityDecls = sdecls + HasSecurity=(flags &&& 0x00040000) <> 0x0 + Fields=fdefs + MethodImpls=mimpls InitSemantics= if kind = ILTypeDefKind.Interface then ILTypeInit.OnAny elif (flags &&& 0x00100000) <> 0x0 then ILTypeInit.BeforeField - else ILTypeInit.OnAny; - Events= events; - Properties=props; - CustomAttrs=cas; } + else ILTypeInit.OnAny + Events= events + Properties=props + CustomAttrs=cas } Some (ns,n,cas,rest) and seekReadTopTypeDefs ctxt () = @@ -1807,13 +1806,13 @@ and seekReadGenericParamsUncached ctxtH (GenericParamsIdx(numtypars,a,b)) = else NonVariant let constraints = seekReadGenericParamConstraintsUncached ctxt numtypars gpidx let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_GenericParam,gpidx)) - seq, {Name=readStringHeap ctxt nameIdx; - Constraints=mkILTypes constraints; - Variance=variance; - CustomAttrs=cas; - HasReferenceTypeConstraint= (flags &&& 0x0004) <> 0; - HasNotNullableValueTypeConstraint= (flags &&& 0x0008) <> 0; - HasDefaultConstructorConstraint=(flags &&& 0x0010) <> 0; })) + seq, {Name=readStringHeap ctxt nameIdx + Constraints=mkILTypes constraints + Variance=variance + CustomAttrs=cas + HasReferenceTypeConstraint= (flags &&& 0x0004) <> 0 + HasNotNullableValueTypeConstraint= (flags &&& 0x0008) <> 0 + HasDefaultConstructorConstraint=(flags &&& 0x0010) <> 0 })) pars |> List.sortBy fst |> List.map snd and seekReadGenericParamConstraintsUncached ctxt numtypars gpidx = @@ -1861,7 +1860,7 @@ and seekReadTypeDefOrRef ctxt numtypars boxity (ginst:ILTypes) (TaggedIndex(tag, | tag when tag = tdor_TypeDef -> seekReadTypeDefAsType ctxt boxity ginst idx | tag when tag = tdor_TypeRef -> seekReadTypeRefAsType ctxt boxity ginst idx | tag when tag = tdor_TypeSpec -> - if ginst.Length > 0 then dprintn ("type spec used as type constructor for a generic instantiation: ignoring instantiation"); + if ginst.Length > 0 then dprintn ("type spec used as type constructor for a generic instantiation: ignoring instantiation") readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt idx) | _ -> failwith "seekReadTypeDefOrRef ctxt" @@ -1870,7 +1869,7 @@ and seekReadTypeDefOrRefAsTypeRef ctxt (TaggedIndex(tag,idx) ) = | tag when tag = tdor_TypeDef -> seekReadTypeDefAsTypeRef ctxt idx | tag when tag = tdor_TypeRef -> seekReadTypeRef ctxt idx | tag when tag = tdor_TypeSpec -> - dprintn ("type spec used where a type ref or def ctxt.is required"); + dprintn ("type spec used where a type ref or def ctxt.is required") ctxt.ilg.tref_Object | _ -> failwith "seekReadTypeDefOrRefAsTypeRef_readTypeDefOrRefOrSpec" @@ -1896,7 +1895,7 @@ and seekReadMethodDefOrRef ctxt numtypars (TaggedIndex(tag,idx)) = and seekReadMethodDefOrRefNoVarargs ctxt numtypars x = let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) = seekReadMethodDefOrRef ctxt numtypars x - if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature"; + if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" MethodData(enclTyp, cc, nm, argtys, retty,minst) and seekReadCustomAttrType ctxt (TaggedIndex(tag,idx) ) = @@ -1937,21 +1936,21 @@ and seekReadField ctxt (numtypars, hasLayout) (idx:int) = let nm = readStringHeap ctxt nameIdx let isStatic = (flags &&& 0x0010) <> 0 let fd = - { Name = nm; - Type= readBlobHeapAsFieldSig ctxt numtypars typeIdx; - Access = memberAccessOfFlags flags; - IsStatic = isStatic; - IsInitOnly = (flags &&& 0x0020) <> 0; - IsLiteral = (flags &&& 0x0040) <> 0; - NotSerialized = (flags &&& 0x0080) <> 0; - IsSpecialName = (flags &&& 0x0200) <> 0 || (flags &&& 0x0400) <> 0; (* REVIEW: RTSpecialName *) - LiteralValue = if (flags &&& 0x8000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_FieldDef,idx))); + { Name = nm + Type= readBlobHeapAsFieldSig ctxt numtypars typeIdx + Access = memberAccessOfFlags flags + IsStatic = isStatic + IsInitOnly = (flags &&& 0x0020) <> 0 + IsLiteral = (flags &&& 0x0040) <> 0 + NotSerialized = (flags &&& 0x0080) <> 0 + IsSpecialName = (flags &&& 0x0200) <> 0 || (flags &&& 0x0400) <> 0 (* REVIEW: RTSpecialName *) + LiteralValue = if (flags &&& 0x8000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_FieldDef,idx))) Marshal = if (flags &&& 0x1000) = 0 then None else Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal,seekReadFieldMarshalRow ctxt, fst,hfmCompare (TaggedIndex(hfm_FieldDef,idx)), isSorted ctxt TableNames.FieldMarshal, - (snd >> readBlobHeapAsNativeType ctxt))); + (snd >> readBlobHeapAsNativeType ctxt))) Data = if (flags &&& 0x0100) = 0 then None else @@ -1961,8 +1960,8 @@ and seekReadField ctxt (numtypars, hasLayout) (idx:int) = Offset = if hasLayout && not isStatic then Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldLayout,seekReadFieldLayoutRow ctxt, - snd,simpleIndexCompare idx,isSorted ctxt TableNames.FieldLayout,fst)) else None; - CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_FieldDef,idx)); } + snd,simpleIndexCompare idx,isSorted ctxt TableNames.FieldLayout,fst)) else None + CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_FieldDef,idx)) } fd and seekReadFields ctxt (numtypars, hasLayout) fidx1 fidx2 = @@ -2056,13 +2055,13 @@ and sigptrGetTy ctxt numtypars bytes sigptr = elif b0 = et_FNPTR then let ccByte,sigptr = sigptrGetByte bytes sigptr let generic,cc = byteAsCallConv ccByte - if generic then failwith "fptr sig may not be generic"; + if generic then failwith "fptr sig may not be generic" let numparams,sigptr = sigptrGetZInt32 bytes sigptr let retty,sigptr = sigptrGetTy ctxt numtypars bytes sigptr let argtys,sigptr = sigptrFold (sigptrGetTy ctxt numtypars) ( numparams) bytes sigptr ILType.FunctionPointer - { CallingConv=cc; - ArgTypes=mkILTypes argtys; + { CallingConv=cc + ArgTypes=mkILTypes argtys ReturnType=retty } ,sigptr elif b0 = et_SENTINEL then failwith "varargs NYI" @@ -2121,7 +2120,7 @@ and readBlobHeapAsFieldSigUncached ctxtH (BlobAsFieldSigIdx (numtypars,blobIdx)) let bytes = readBlobHeap ctxt blobIdx let sigptr = 0 let ccByte,sigptr = sigptrGetByte bytes sigptr - if ccByte <> e_IMAGE_CEE_CS_CALLCONV_FIELD then dprintn "warning: field sig was not CC_FIELD"; + if ccByte <> e_IMAGE_CEE_CS_CALLCONV_FIELD then dprintn "warning: field sig was not CC_FIELD" let retty,_sigptr = sigptrGetTy ctxt numtypars bytes sigptr retty @@ -2135,7 +2134,7 @@ and readBlobHeapAsPropertySigUncached ctxtH (BlobAsPropSigIdx (numtypars,blobIdx let ccByte,sigptr = sigptrGetByte bytes sigptr let hasthis = byteAsHasThis ccByte let ccMaxked = (ccByte &&& 0x0Fuy) - if ccMaxked <> e_IMAGE_CEE_CS_CALLCONV_PROPERTY then dprintn ("warning: property sig was "+string ccMaxked+" instead of CC_PROPERTY"); + if ccMaxked <> e_IMAGE_CEE_CS_CALLCONV_PROPERTY then dprintn ("warning: property sig was "+string ccMaxked+" instead of CC_PROPERTY") let numparams,sigptr = sigptrGetZInt32 bytes sigptr let retty,sigptr = sigptrGetTy ctxt numtypars bytes sigptr let argtys,_sigptr = sigptrFold (sigptrGetTy ctxt numtypars) ( numparams) bytes sigptr @@ -2149,7 +2148,7 @@ and readBlobHeapAsLocalsSigUncached ctxtH (BlobAsLocalSigIdx (numtypars,blobIdx) let bytes = readBlobHeap ctxt blobIdx let sigptr = 0 let ccByte,sigptr = sigptrGetByte bytes sigptr - if ccByte <> e_IMAGE_CEE_CS_CALLCONV_LOCAL_SIG then dprintn "warning: local sig was not CC_LOCAL"; + if ccByte <> e_IMAGE_CEE_CS_CALLCONV_LOCAL_SIG then dprintn "warning: local sig was not CC_LOCAL" let numlocals,sigptr = sigptrGetZInt32 bytes sigptr let localtys,_sigptr = sigptrFold (sigptrGetLocal ctxt numtypars) ( numlocals) bytes sigptr localtys @@ -2185,7 +2184,7 @@ and seekReadMemberRefAsMethodDataUncached ctxtH (MemberRefAsMspecIdx (numtypars, and seekReadMemberRefAsMethDataNoVarArgs ctxt numtypars idx : MethodData = let (VarArgMethodData(enclTyp, cc, nm, argtys,varargs, retty,minst)) = seekReadMemberRefAsMethodData ctxt numtypars idx - if isSome varargs then dprintf "ignoring sentinel and varargs in ILMethodDef token signature"; + if isSome varargs then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" (MethodData(enclTyp, cc, nm, argtys, retty,minst)) and seekReadMethodSpecAsMethodData ctxt numtypars idx = @@ -2198,7 +2197,7 @@ and seekReadMethodSpecAsMethodDataUncached ctxtH (MethodSpecAsMspecIdx (numtypar let bytes = readBlobHeap ctxt instIdx let sigptr = 0 let ccByte,sigptr = sigptrGetByte bytes sigptr - if ccByte <> e_IMAGE_CEE_CS_CALLCONV_GENERICINST then dprintn ("warning: method inst ILCallingConv was "+string ccByte+" instead of CC_GENERICINST"); + if ccByte <> e_IMAGE_CEE_CS_CALLCONV_GENERICINST then dprintn ("warning: method inst ILCallingConv was "+string ccByte+" instead of CC_GENERICINST") let numgpars,sigptr = sigptrGetZInt32 bytes sigptr let argtys,_sigptr = sigptrFold (sigptrGetTy ctxt numtypars) numgpars bytes sigptr mkILTypes argtys @@ -2239,7 +2238,7 @@ and seekReadMethodDefAsMethodDataUncached ctxtH idx = true,fst) // Read the method def signature. let _generic,_genarity,cc,retty,argtys,varargs = readBlobHeapAsMethodSig ctxt 0 typeIdx - if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature"; + if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" // Create a formal instantiation if needed let finst = mkILFormalGenericArgsRaw (seekReadGenericParams ctxt 0 (tomd_TypeDef,tidx)) let minst = mkILFormalGenericArgsRaw (seekReadGenericParams ctxt finst.Length (tomd_MethodDef,idx)) @@ -2302,7 +2301,7 @@ and seekReadMethod ctxt numtypars (idx:int) = let cctor = (nm = ".cctor") let ctor = (nm = ".ctor") let _generic,_genarity,cc,retty,argtys,varargs = readBlobHeapAsMethodSig ctxt numtypars typeIdx - if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef signature"; + if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef signature" let endParamIdx = if idx >= ctxt.getNumRows TableNames.Method then @@ -2313,49 +2312,49 @@ and seekReadMethod ctxt numtypars (idx:int) = let ret,ilParams = seekReadParams ctxt (retty,argtys) paramIdx endParamIdx - { Name=nm; + { Name=nm mdKind = (if cctor then MethodKind.Cctor elif ctor then MethodKind.Ctor elif isStatic then MethodKind.Static elif virt then MethodKind.Virtual - { IsFinal=final; - IsNewSlot=newslot; - IsCheckAccessOnOverride=strict; - IsAbstract=abstr; } - else MethodKind.NonVirtual); - Access = memberAccessOfFlags flags; - SecurityDecls=seekReadSecurityDecls ctxt (TaggedIndex(hds_MethodDef,idx)); - HasSecurity=hassec; - IsEntryPoint= (fst ctxt.entryPointToken = TableNames.Method && snd ctxt.entryPointToken = idx); - IsReqSecObj=reqsecobj; - IsHideBySig=hidebysig; - IsSpecialName=specialname; - IsUnmanagedExport=export; - IsSynchronized=synchronized; - IsNoInline=noinline; - IsMustRun=mustrun; - IsPreserveSig=preservesig; - IsManaged = not unmanaged; - IsInternalCall = internalcall; - IsForwardRef = forwardref; - mdCodeKind = (if (codetype = 0x00) then MethodCodeKind.IL elif (codetype = 0x01) then MethodCodeKind.Native elif (codetype = 0x03) then MethodCodeKind.Runtime else (dprintn "unsupported code type"; MethodCodeKind.Native)); - GenericParams=seekReadGenericParams ctxt numtypars (tomd_MethodDef,idx); - CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_MethodDef,idx)); - Parameters= ilParams; - CallingConv=cc; - Return=ret; + { IsFinal=final + IsNewSlot=newslot + IsCheckAccessOnOverride=strict + IsAbstract=abstr } + else MethodKind.NonVirtual) + Access = memberAccessOfFlags flags + SecurityDecls=seekReadSecurityDecls ctxt (TaggedIndex(hds_MethodDef,idx)) + HasSecurity=hassec + IsEntryPoint= (fst ctxt.entryPointToken = TableNames.Method && snd ctxt.entryPointToken = idx) + IsReqSecObj=reqsecobj + IsHideBySig=hidebysig + IsSpecialName=specialname + IsUnmanagedExport=export + IsSynchronized=synchronized + IsNoInline=noinline + IsMustRun=mustrun + IsPreserveSig=preservesig + IsManaged = not unmanaged + IsInternalCall = internalcall + IsForwardRef = forwardref + mdCodeKind = (if (codetype = 0x00) then MethodCodeKind.IL elif (codetype = 0x01) then MethodCodeKind.Native elif (codetype = 0x03) then MethodCodeKind.Runtime else MethodCodeKind.Native) + GenericParams=seekReadGenericParams ctxt numtypars (tomd_MethodDef,idx) + CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_MethodDef,idx)) + Parameters= ilParams + CallingConv=cc + Return=ret mdBody= if (codetype = 0x01) && pinvoke then mkMethBodyLazyAux (notlazy MethodBody.Native) elif pinvoke then seekReadImplMap ctxt nm idx elif internalcall || abstr || unmanaged || (codetype <> 0x00) then - if codeRVA <> 0x0 then dprintn "non-IL or abstract method with non-zero RVA"; + if codeRVA <> 0x0 then dprintn "non-IL or abstract method with non-zero RVA" mkMethBodyLazyAux (notlazy MethodBody.Abstract) else - seekReadMethodRVA ctxt (idx,nm,internalcall,noinline,numtypars) codeRVA; + seekReadMethodRVA ctxt (idx,nm,internalcall,noinline,numtypars) codeRVA } @@ -2365,13 +2364,13 @@ and seekReadParams ctxt (retty,argtys) pidx1 pidx2 = argtys |> ILList.toArray |> Array.map (fun ty -> - { Name=None; - Default=None; - Marshal=None; - IsIn=false; - IsOut=false; - IsOptional=false; - Type=ty; + { Name=None + Default=None + Marshal=None + IsIn=false + IsOut=false + IsOptional=false + Type=ty CustomAttrs=emptyILCustomAttrs }) for i = pidx1 to pidx2 - 1 do seekReadParamExtras ctxt (retRes,paramsRes) i @@ -2386,18 +2385,18 @@ and seekReadParamExtras ctxt (retRes,paramsRes) (idx:int) = let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_ParamDef,idx)) if seq = 0 then retRes := { !retRes with - Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef,idx))) else None); + Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef,idx))) else None) CustomAttrs = cas } elif seq > Array.length paramsRes then dprintn "bad seq num. for param" else paramsRes.[seq - 1] <- { paramsRes.[seq - 1] with - Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef,idx))) else None); - Default = (if hasDefault then Some (seekReadConstant ctxt (TaggedIndex(hc_ParamDef,idx))) else None); - Name = readStringHeapOption ctxt nameIdx; - IsIn = ((inOutMasked &&& 0x0001) <> 0x0); - IsOut = ((inOutMasked &&& 0x0002) <> 0x0); - IsOptional = ((inOutMasked &&& 0x0010) <> 0x0); + Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef,idx))) else None) + Default = (if hasDefault then Some (seekReadConstant ctxt (TaggedIndex(hc_ParamDef,idx))) else None) + Name = readStringHeapOption ctxt nameIdx + IsIn = ((inOutMasked &&& 0x0001) <> 0x0) + IsOut = ((inOutMasked &&& 0x0002) <> 0x0) + IsOptional = ((inOutMasked &&& 0x0010) <> 0x0) CustomAttrs =cas } and seekReadMethodImpls ctxt numtypars tidx = @@ -2407,7 +2406,7 @@ and seekReadMethodImpls ctxt numtypars tidx = mimpls |> List.map (fun (b,c) -> { OverrideBy= let (MethodData(enclTyp, cc, nm, argtys, retty,minst)) = seekReadMethodDefOrRefNoVarargs ctxt numtypars b - mkILMethSpecInTyRaw (enclTyp, cc, nm, argtys, retty,minst); + mkILMethSpecInTyRaw (enclTyp, cc, nm, argtys, retty,minst) Overrides= let (MethodData(enclTyp, cc, nm, argtys, retty,minst)) = seekReadMethodDefOrRefNoVarargs ctxt numtypars c let mspec = mkILMethSpecInTyRaw (enclTyp, cc, nm, argtys, retty,minst) @@ -2440,14 +2439,14 @@ and seekReadMethodSemantics ctxt id = and seekReadEvent ctxt numtypars idx = let (flags,nameIdx,typIdx) = seekReadEventRow ctxt idx - { Name = readStringHeap ctxt nameIdx; - Type = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx; - IsSpecialName = (flags &&& 0x0200) <> 0x0; - IsRTSpecialName = (flags &&& 0x0400) <> 0x0; - AddMethod= seekReadMethodSemantics ctxt (0x0008,TaggedIndex(hs_Event, idx)); - RemoveMethod=seekReadMethodSemantics ctxt (0x0010,TaggedIndex(hs_Event,idx)); - FireMethod=seekReadoptional_MethodSemantics ctxt (0x0020,TaggedIndex(hs_Event,idx)); - OtherMethods = seekReadMultipleMethodSemantics ctxt (0x0004, TaggedIndex(hs_Event, idx)); + { Name = readStringHeap ctxt nameIdx + Type = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx + IsSpecialName = (flags &&& 0x0200) <> 0x0 + IsRTSpecialName = (flags &&& 0x0400) <> 0x0 + AddMethod= seekReadMethodSemantics ctxt (0x0008,TaggedIndex(hs_Event, idx)) + RemoveMethod=seekReadMethodSemantics ctxt (0x0010,TaggedIndex(hs_Event,idx)) + FireMethod=seekReadoptional_MethodSemantics ctxt (0x0020,TaggedIndex(hs_Event,idx)) + OtherMethods = seekReadMultipleMethodSemantics ctxt (0x0004, TaggedIndex(hs_Event, idx)) CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_Event,idx)) } (* REVIEW: can substantially reduce numbers of EventMap and PropertyMap reads by first checking if the whole table is sorted according to ILTypeDef tokens and then doing a binary chop *) @@ -2481,15 +2480,15 @@ and seekReadProperty ctxt numtypars idx = match setter with | Some mref -> mref.CallingConv .ThisConv | None -> cc - { Name=readStringHeap ctxt nameIdx; - CallingConv = cc2; - IsRTSpecialName=(flags &&& 0x0400) <> 0x0; - IsSpecialName= (flags &&& 0x0200) <> 0x0; - SetMethod=setter; - GetMethod=getter; - Type=retty; - Init= if (flags &&& 0x1000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_Property,idx))); - Args=argtys; + { Name=readStringHeap ctxt nameIdx + CallingConv = cc2 + IsRTSpecialName=(flags &&& 0x0400) <> 0x0 + IsSpecialName= (flags &&& 0x0200) <> 0x0 + SetMethod=setter + GetMethod=getter + Type=retty + Init= if (flags &&& 0x1000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_Property,idx))) + Args=argtys CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_Property,idx)) } and seekReadProperties ctxt numtypars tidx = @@ -2523,7 +2522,7 @@ and seekReadCustomAttr ctxt (TaggedIndex(cat,idx),b) = and seekReadCustomAttrUncached ctxtH (CustomAttrIdx (cat,idx,valIdx)) = let ctxt = getHole ctxtH - { Method=seekReadCustomAttrType ctxt (TaggedIndex(cat,idx)); + { Method=seekReadCustomAttrType ctxt (TaggedIndex(cat,idx)) Data= match readBlobHeapOption ctxt valIdx with | Some bytes -> bytes @@ -2611,16 +2610,16 @@ and seekReadImplMap ctxt nm midx = elif masked = 0x2000 then PInvokeThrowOnUnmappableChar.Disabled else (dprintn "strange ThrowOnUnmappableChar"; PInvokeThrowOnUnmappableChar.UseAssembly) - MethodBody.PInvoke { CallingConv = cc; - CharEncoding = enc; - CharBestFit=bestfit; - ThrowOnUnmappableChar=unmap; - NoMangle = (flags &&& 0x0001) <> 0x0; - LastError = (flags &&& 0x0040) <> 0x0; + MethodBody.PInvoke { CallingConv = cc + CharEncoding = enc + CharBestFit=bestfit + ThrowOnUnmappableChar=unmap + NoMangle = (flags &&& 0x0001) <> 0x0 + LastError = (flags &&& 0x0040) <> 0x0 Name = (match readStringHeapOption ctxt nameIdx with | None -> nm - | Some nm2 -> nm2); + | Some nm2 -> nm2) Where = seekReadModuleRef ctxt scopeIdx }) and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = @@ -2637,7 +2636,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = | Some l -> l | None -> let lab = generateCodeLabel() - labelsOfRawOffsets.[rawOffset] <- lab; + labelsOfRawOffsets.[rawOffset] <- lab lab let markAsInstructionStart rawOffset ilOffset = @@ -2651,12 +2650,12 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = let lastb2 = ref 0x0 let b = ref 0x0 let get () = - lastb := seekReadByteAsInt32 ctxt.is (start + (!curr)); - incr curr; + lastb := seekReadByteAsInt32 ctxt.is (start + (!curr)) + incr curr b := if !lastb = 0xfe && !curr < sz then - lastb2 := seekReadByteAsInt32 ctxt.is (start + (!curr)); - incr curr; + lastb2 := seekReadByteAsInt32 ctxt.is (start + (!curr)) + incr curr !lastb2 else !lastb @@ -2665,7 +2664,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = while !curr < sz do // registering "+string !curr+" as start of an instruction") - markAsInstructionStart !curr ibuf.Count; + markAsInstructionStart !curr ibuf.Count // Insert any sequence points into the instruction sequence while @@ -2675,17 +2674,17 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = do // Emitting one sequence point let (_,tag) = List.head !seqPointsRemaining - seqPointsRemaining := List.tail !seqPointsRemaining; + seqPointsRemaining := List.tail !seqPointsRemaining ibuf.Add (I_seqpoint tag) // Read the prefixes. Leave lastb and lastb2 holding the instruction byte(s) begin - prefixes.al <- Aligned; - prefixes.tl <- Normalcall; - prefixes.vol <- Nonvolatile; - prefixes.ro<-NormalAddress; - prefixes.constrained<-None; - get (); + prefixes.al <- Aligned + prefixes.tl <- Normalcall + prefixes.vol <- Nonvolatile + prefixes.ro<-NormalAddress + prefixes.constrained<-None + get () while !curr < sz && !lastb = 0xfe && (!b = (i_constrained &&& 0xff) || @@ -2693,10 +2692,9 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = !b = (i_unaligned &&& 0xff) || !b = (i_volatile &&& 0xff) || !b = (i_tail &&& 0xff)) do - begin if !b = (i_unaligned &&& 0xff) then let unal = seekReadByteAsInt32 ctxt.is (start + (!curr)) - incr curr; + incr curr prefixes.al <- if unal = 0x1 then Unaligned1 elif unal = 0x2 then Unaligned2 @@ -2706,17 +2704,15 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = elif !b = (i_readonly &&& 0xff) then prefixes.ro <- ReadonlyAddress elif !b = (i_constrained &&& 0xff) then let uncoded = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 let typ = seekReadTypeDefOrRef ctxt numtypars AsObject ILList.empty (uncodedTokenToTypeDefOrRefOrSpec uncoded) prefixes.constrained <- Some typ - else prefixes.tl <- Tailcall; - end; - get (); - done; - end; + else prefixes.tl <- Tailcall + get () + end // data for instruction begins at "+string !curr - (* Read and decode the instruction *) + // Read and decode the instruction if (!curr <= sz) then let idecoder = if !lastb = 0xfe then getTwoByteInstr ( !lastb2) @@ -2725,37 +2721,37 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = match idecoder with | I_u16_u8_instr f -> let x = seekReadByte ctxt.is (start + (!curr)) |> uint16 - curr := !curr + 1; + curr := !curr + 1 f prefixes x | I_u16_u16_instr f -> let x = seekReadUInt16 ctxt.is (start + (!curr)) - curr := !curr + 2; + curr := !curr + 2 f prefixes x | I_none_instr f -> f prefixes | I_i64_instr f -> let x = seekReadInt64 ctxt.is (start + (!curr)) - curr := !curr + 8; + curr := !curr + 8 f prefixes x | I_i32_i8_instr f -> let x = seekReadSByte ctxt.is (start + (!curr)) |> int32 - curr := !curr + 1; + curr := !curr + 1 f prefixes x | I_i32_i32_instr f -> let x = seekReadInt32 ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 f prefixes x | I_r4_instr f -> let x = seekReadSingle ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 f prefixes x | I_r8_instr f -> let x = seekReadDouble ctxt.is (start + (!curr)) - curr := !curr + 8; + curr := !curr + 8 f prefixes x | I_field_instr f -> let (tab,tok) = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 let fspec = if tab = TableNames.Field then seekReadFieldDefAsFieldSpec ctxt tok @@ -2767,7 +2763,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = // method instruction, curr = "+string !curr let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) = if tab = TableNames.Method then seekReadMethodDefOrRef ctxt numtypars (TaggedIndex(mdor_MethodDef, idx)) @@ -2789,39 +2785,41 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = f prefixes (mspec,varargs) | I_type_instr f -> let uncoded = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 let typ = seekReadTypeDefOrRef ctxt numtypars AsObject ILList.empty (uncodedTokenToTypeDefOrRefOrSpec uncoded) f prefixes typ | I_string_instr f -> let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; - if tab <> TableNames.UserStrings then dprintn "warning: bad table in user string for ldstr"; + curr := !curr + 4 + if tab <> TableNames.UserStrings then dprintn "warning: bad table in user string for ldstr" f prefixes (readUserStringHeap ctxt (idx)) | I_conditional_i32_instr f -> let offsDest = (seekReadInt32 ctxt.is (start + (!curr))) - curr := !curr + 4; + curr := !curr + 4 let dest = !curr + offsDest f prefixes (rawToLabel dest) | I_conditional_i8_instr f -> let offsDest = int (seekReadSByte ctxt.is (start + (!curr))) - curr := !curr + 1; + curr := !curr + 1 let dest = !curr + offsDest f prefixes (rawToLabel dest) | I_unconditional_i32_instr f -> let offsDest = (seekReadInt32 ctxt.is (start + (!curr))) - curr := !curr + 4; + curr := !curr + 4 let dest = !curr + offsDest f prefixes (rawToLabel dest) | I_unconditional_i8_instr f -> let offsDest = int (seekReadSByte ctxt.is (start + (!curr))) - curr := !curr + 1; + curr := !curr + 1 let dest = !curr + offsDest f prefixes (rawToLabel dest) - | I_invalid_instr -> dprintn ("invalid instruction: "+string !lastb+ (if !lastb = 0xfe then ","+string !lastb2 else "")); I_ret + | I_invalid_instr -> + dprintn ("invalid instruction: "+string !lastb+ (if !lastb = 0xfe then ","+string !lastb2 else "")) + I_ret | I_tok_instr f -> let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; + curr := !curr + 4 (* REVIEW: this incorrectly labels all MemberRef tokens as ILMethod's: we should go look at the MemberRef sig to determine if it is a field or method *) let token_info = if tab = TableNames.Method || tab = TableNames.MemberRef (* REVIEW:generics or tab = TableNames.MethodSpec *) then @@ -2835,25 +2833,25 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = f prefixes token_info | I_sig_instr f -> let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr)) - curr := !curr + 4; - if tab <> TableNames.StandAloneSig then dprintn "strange table for callsig token"; + curr := !curr + 4 + if tab <> TableNames.StandAloneSig then dprintn "strange table for callsig token" let generic,_genarity,cc,retty,argtys,varargs = readBlobHeapAsMethodSig ctxt numtypars (seekReadStandAloneSigRow ctxt idx) - if generic then failwith "bad image: a generic method signature ctxt.is begin used at a calli instruction"; + if generic then failwith "bad image: a generic method signature ctxt.is begin used at a calli instruction" f prefixes (mkILCallSigRaw (cc,argtys,retty), varargs) | I_switch_instr f -> let n = (seekReadInt32 ctxt.is (start + (!curr))) - curr := !curr + 4; + curr := !curr + 4 let offsets = List.init n (fun _ -> let i = (seekReadInt32 ctxt.is (start + (!curr))) - curr := !curr + 4; + curr := !curr + 4 i) let dests = List.map (fun offs -> rawToLabel (!curr + offs)) offsets f prefixes dests ibuf.Add instr - done; + done // Finished reading instructions - mark the end of the instruction stream in case the PDB information refers to it. - markAsInstructionStart !curr ibuf.Count; + markAsInstructionStart !curr ibuf.Count // Build the function that maps from raw labels (offsets into the bytecode stream) to indexes in the AbsIL instruction stream let lab2pc = ilOffsetsOfLabels @@ -2898,7 +2896,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = let pdbm = pdbReaderGetMethod pdbr (uncodedToken TableNames.Method idx) //let rootScope = pdbMethodGetRootScope pdbm let sps = pdbMethodGetSequencePoints pdbm - (*dprintf "#sps for 0x%x = %d\n" (uncodedToken TableNames.Method idx) (Array.length sps); *) + (*dprintf "#sps for 0x%x = %d\n" (uncodedToken TableNames.Method idx) (Array.length sps) *) (* let roota,rootb = pdbScopeGetOffsets rootScope in *) let seqpoints = let arr = @@ -2913,7 +2911,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = endColumn = sp.pdbSeqPointEndColumn) (sp.pdbSeqPointOffset,source)) - Array.sortInPlaceBy fst arr; + Array.sortInPlaceBy fst arr Array.toList arr let rec scopes scp = @@ -2929,12 +2927,12 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = ilvs |> List.map (fun ilv -> let _k,idx = pdbVariableGetAddressAttributes ilv let n = pdbVariableGetName ilv - { LocalIndex= idx; + { LocalIndex= idx LocalName=n}) let thisOne = (fun raw2nextLab -> - { Range= (raw2nextLab a,raw2nextLab b); + { Range= (raw2nextLab a,raw2nextLab b) DebugMappings = ilinfos } : ILLocalDebugInfo ) let others = List.foldBack (scopes >> (@)) (Array.toList (pdbScopeGetChildren scp)) [] thisOne :: others @@ -2952,17 +2950,17 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = if (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_TinyFormat then let codeBase = baseRVA + 1 let codeSize = (int32 b >>>& 2) - // tiny format for "+nm+", code size = " + string codeSize); + // tiny format for "+nm+", code size = " + string codeSize) let instrs,_,lab2pc,raw2nextLab = seekReadTopCode ctxt numtypars codeSize codeBase seqpoints (* Convert the linear code format to the nested code format *) let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos let code = buildILCode nm lab2pc instrs [] localPdbInfos2 MethodBody.IL - { IsZeroInit=false; - MaxStack= 8; - NoInlining=noinline; - Locals=ILList.empty; - SourceMarker=methRangePdbInfo; + { IsZeroInit=false + MaxStack= 8 + NoInlining=noinline + Locals=ILList.empty + SourceMarker=methRangePdbInfo Code=code } elif (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat then @@ -2975,10 +2973,10 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = let locals = if localToken = 0x0 then [] else - if localsTab <> TableNames.StandAloneSig then dprintn "strange table for locals token"; + if localsTab <> TableNames.StandAloneSig then dprintn "strange table for locals token" readBlobHeapAsLocalsSig ctxt numtypars (seekReadStandAloneSigRow ctxt localToken) - // fat format for "+nm+", code size = " + string codeSize+", hasMoreSections = "+(if hasMoreSections then "true" else "false")+",b = "+string b); + // fat format for "+nm+", code size = " + string codeSize+", hasMoreSections = "+(if hasMoreSections then "true" else "false")+",b = "+string b) // Read the method body let instrs,rawToLabel,lab2pc,raw2nextLab = seekReadTopCode ctxt numtypars ( codeSize) codeBase seqpoints @@ -2991,11 +2989,11 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = while !moreSections do let sectionBase = !nextSectionBase let sectionFlag = seekReadByte ctxt.is sectionBase - // fat format for "+nm+", sectionFlag = " + string sectionFlag); + // fat format for "+nm+", sectionFlag = " + string sectionFlag) let sectionSize, clauses = if (sectionFlag &&& e_CorILMethod_Sect_FatFormat) <> 0x0uy then let bigSize = (seekReadInt32 ctxt.is sectionBase) >>>& 8 - // bigSize = "+string bigSize); + // bigSize = "+string bigSize) let clauses = if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then // WORKAROUND: The ECMA spec says this should be @@ -3022,11 +3020,11 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = // let numClauses = ((smallSize - 4) / 12) in // but the C# compiler (or some IL generator) generates multiples of 12 let numClauses = (smallSize / 12) - // dprintn (nm+" has " + string numClauses + " tiny seh clauses"); + // dprintn (nm+" has " + string numClauses + " tiny seh clauses") List.init numClauses (fun i -> let clauseBase = sectionBase + 4 + (i * 12) let kind = seekReadUInt16AsInt32 ctxt.is (clauseBase + 0) - if logging then dprintn ("One tiny SEH clause, kind = "+string kind); + if logging then dprintn ("One tiny SEH clause, kind = "+string kind) let st1 = seekReadUInt16AsInt32 ctxt.is (clauseBase + 2) let sz1 = seekReadByteAsInt32 ctxt.is (clauseBase + 4) let st2 = seekReadUInt16AsInt32 ctxt.is (clauseBase + 5) @@ -3059,7 +3057,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = elif kind = e_COR_ILEXCEPTION_CLAUSE_FAULT then ILExceptionClause.Fault(handlerStart, handlerFinish) else begin - dprintn (ctxt.infile + ": unknown exception handler kind: "+string kind); + dprintn (ctxt.infile + ": unknown exception handler kind: "+string kind) ILExceptionClause.Finally(handlerStart, handlerFinish) end @@ -3069,28 +3067,28 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = sehMap.[key] <- (prev @ [clause]) else sehMap.[key] <- [clause]) - clauses; + clauses ([],sehMap) ||> Seq.fold (fun acc (KeyValue(key,bs)) -> [ for b in bs -> {Range=key; Clause=b} : ILExceptionSpec ] @ acc) - seh := sehClauses; - moreSections := (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy; - nextSectionBase := sectionBase + sectionSize; - done; (* while *) + seh := sehClauses + moreSections := (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy + nextSectionBase := sectionBase + sectionSize + done (* while *) (* Convert the linear code format to the nested code format *) - if logging then dprintn ("doing localPdbInfos2"); + if logging then dprintn ("doing localPdbInfos2") let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos - if logging then dprintn ("done localPdbInfos2, checking code..."); + if logging then dprintn ("done localPdbInfos2, checking code...") let code = buildILCode nm lab2pc instrs !seh localPdbInfos2 - if logging then dprintn ("done checking code."); + if logging then dprintn ("done checking code.") MethodBody.IL - { IsZeroInit=initlocals; - MaxStack= maxstack; - NoInlining=noinline; - Locals=mkILLocals locals; - Code=code; + { IsZeroInit=initlocals + MaxStack= maxstack + NoInlining=noinline + Locals=mkILLocals locals + Code=code SourceMarker=methRangePdbInfo} else - if logging then failwith "unknown format"; + if logging then failwith "unknown format" MethodBody.Abstract end) @@ -3103,36 +3101,36 @@ and int32AsILVariantType ctxt (n:int32) = else (dprintn (ctxt.infile + ": int32AsILVariantType ctxt: unexpected variant type, n = "+string n) ; ILNativeVariant.Empty) and readBlobHeapAsNativeType ctxt blobIdx = - // reading native type blob "+string blobIdx); + // reading native type blob "+string blobIdx) let bytes = readBlobHeap ctxt blobIdx let res,_ = sigptrGetILNativeType ctxt bytes 0 res and sigptrGetILNativeType ctxt bytes sigptr = - // reading native type blob, sigptr= "+string sigptr); + // reading native type blob, sigptr= "+string sigptr) let ntbyte,sigptr = sigptrGetByte bytes sigptr if List.memAssoc ntbyte (Lazy.force ILNativeTypeMap) then List.assoc ntbyte (Lazy.force ILNativeTypeMap), sigptr elif ntbyte = 0x0uy then ILNativeType.Empty, sigptr elif ntbyte = nt_CUSTOMMARSHALER then - // reading native type blob (CM1) , sigptr= "+string sigptr+ ", bytes.Length = "+string bytes.Length); + // reading native type blob (CM1) , sigptr= "+string sigptr+ ", bytes.Length = "+string bytes.Length) let guidLen,sigptr = sigptrGetZInt32 bytes sigptr - // reading native type blob (CM2) , sigptr= "+string sigptr+", guidLen = "+string ( guidLen)); + // reading native type blob (CM2) , sigptr= "+string sigptr+", guidLen = "+string ( guidLen)) let guid,sigptr = sigptrGetBytes ( guidLen) bytes sigptr - // reading native type blob (CM3) , sigptr= "+string sigptr); + // reading native type blob (CM3) , sigptr= "+string sigptr) let nativeTypeNameLen,sigptr = sigptrGetZInt32 bytes sigptr - // reading native type blob (CM4) , sigptr= "+string sigptr+", nativeTypeNameLen = "+string ( nativeTypeNameLen)); + // reading native type blob (CM4) , sigptr= "+string sigptr+", nativeTypeNameLen = "+string ( nativeTypeNameLen)) let nativeTypeName,sigptr = sigptrGetString ( nativeTypeNameLen) bytes sigptr - // reading native type blob (CM4) , sigptr= "+string sigptr+", nativeTypeName = "+nativeTypeName); - // reading native type blob (CM5) , sigptr= "+string sigptr); + // reading native type blob (CM4) , sigptr= "+string sigptr+", nativeTypeName = "+nativeTypeName) + // reading native type blob (CM5) , sigptr= "+string sigptr) let custMarshallerNameLen,sigptr = sigptrGetZInt32 bytes sigptr - // reading native type blob (CM6) , sigptr= "+string sigptr+", custMarshallerNameLen = "+string ( custMarshallerNameLen)); + // reading native type blob (CM6) , sigptr= "+string sigptr+", custMarshallerNameLen = "+string ( custMarshallerNameLen)) let custMarshallerName,sigptr = sigptrGetString ( custMarshallerNameLen) bytes sigptr - // reading native type blob (CM7) , sigptr= "+string sigptr+", custMarshallerName = "+custMarshallerName); + // reading native type blob (CM7) , sigptr= "+string sigptr+", custMarshallerName = "+custMarshallerName) let cookieStringLen,sigptr = sigptrGetZInt32 bytes sigptr - // reading native type blob (CM8) , sigptr= "+string sigptr+", cookieStringLen = "+string ( cookieStringLen)); + // reading native type blob (CM8) , sigptr= "+string sigptr+", cookieStringLen = "+string ( cookieStringLen)) let cookieString,sigptr = sigptrGetBytes ( cookieStringLen) bytes sigptr - // reading native type blob (CM9) , sigptr= "+string sigptr); + // reading native type blob (CM9) , sigptr= "+string sigptr) ILNativeType.Custom (guid,nativeTypeName,custMarshallerName,cookieString), sigptr elif ntbyte = nt_FIXEDSYSSTRING then let i,sigptr = sigptrGetZInt32 bytes sigptr @@ -3173,7 +3171,7 @@ and sigptrGetILNativeType ctxt bytes sigptr = if sigptr >= bytes.Length then 0, sigptr else sigptrGetZInt32 bytes sigptr ILNativeType.Array (Some nt,Some(pnum,Some(additive))), sigptr - else (dprintn (ctxt.infile + ": unexpected native type, nt = "+string ntbyte); ILNativeType.Empty, sigptr) + else (ILNativeType.Empty, sigptr) and seekReadManifestResources ctxt () = mkILResourcesLazy @@ -3191,9 +3189,9 @@ and seekReadManifestResources ctxt () = | ILScopeRef.Assembly aref -> ILResourceLocation.Assembly aref let r = - { Name= readStringHeap ctxt nameIdx; - Location = datalab; - Access = (if (flags &&& 0x01) <> 0x0 then ILResourceAccess.Public else ILResourceAccess.Private); + { Name= readStringHeap ctxt nameIdx + Location = datalab + Access = (if (flags &&& 0x01) <> 0x0 then ILResourceAccess.Public else ILResourceAccess.Private) CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_ManifestResource, i)) } yield r ]) @@ -3211,9 +3209,9 @@ and seekReadNestedExportedTypes ctxt parentIdx = | tag when tag = i_ExportedType && idx = parentIdx -> let nm = readBlobHeapAsTypeName ctxt (nameIdx,namespaceIdx) yield - { Name=nm; - Access=(match typeAccessOfFlags flags with ILTypeDefAccess.Nested n -> n | _ -> failwith "non-nested access for a nested type described as being in an auxiliary module"); - Nested=seekReadNestedExportedTypes ctxt i; + { Name=nm + Access=(match typeAccessOfFlags flags with ILTypeDefAccess.Nested n -> n | _ -> failwith "non-nested access for a nested type described as being in an auxiliary module") + Nested=seekReadNestedExportedTypes ctxt i CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_ExportedType, i)) } | _ -> () ]) @@ -3233,14 +3231,14 @@ and seekReadTopExportedTypes ctxt () = let scoref = seekReadImplAsScopeRef ctxt implIdx let entry = - { ScopeRef=scoref; - Name=nm; - IsForwarder = ((flags &&& 0x00200000) <> 0); - Access=typeAccessOfFlags flags; - Nested=seekReadNestedExportedTypes ctxt i; + { ScopeRef=scoref + Name=nm + IsForwarder = ((flags &&& 0x00200000) <> 0) + Access=typeAccessOfFlags flags + Nested=seekReadNestedExportedTypes ctxt i CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_ExportedType, i)) } - res := entry :: !res; - done; + res := entry :: !res + done List.rev !res) #if FX_NO_PDB_READER @@ -3260,7 +3258,7 @@ let getPdbReader opts infile = ILSourceDocument.Create(language=Some (pdbDocumentGetLanguage pdbdoc), vendor = Some (pdbDocumentGetLanguageVendor pdbdoc), documentType = Some (pdbDocumentGetType pdbdoc), - file = url)); + file = url)) let docfun url = if tab.ContainsKey url then tab.[url] else failwith ("Document with URL "+url+" not found in list of documents in the PDB file") Some (pdbr, docfun) @@ -3281,7 +3279,7 @@ let rec genOpenBinaryReader infile is opts = let peFileHeaderPhysLoc = peSignaturePhysLoc + 0x04 let peOptionalHeaderPhysLoc = peFileHeaderPhysLoc + 0x14 let peSignature = seekReadInt32 is (peSignaturePhysLoc + 0) - if peSignature <> 0x4550 then failwithf "not a PE file - bad magic PE number 0x%08x, is = %A" peSignature is; + if peSignature <> 0x4550 then failwithf "not a PE file - bad magic PE number 0x%08x, is = %A" peSignature is (* PE SIGNATURE *) @@ -3289,7 +3287,7 @@ let rec genOpenBinaryReader infile is opts = let numSections = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 2) let optHeaderSize = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16) if optHeaderSize <> 0xe0 && - optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size"; + optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size" let x64adjust = optHeaderSize - 0xe0 let only64 = (optHeaderSize = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) let platform = match machine with | 0x8664 -> Some(AMD64) | 0x200 -> Some(IA64) | _ -> Some(X86) @@ -3389,16 +3387,16 @@ let rec genOpenBinaryReader infile is opts = let textSegmentPhysicalSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 16) let textSegmentPhysicalLoc = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 20) - if logging then dprintn (infile + ": textHeaderStart = "+string textHeaderStart); - if logging then dprintn (infile + ": dataHeaderStart = "+string dataHeaderStart); - if logging then dprintn (infile + ": dataSegmentAddr (pre section crack) = "+string dataSegmentAddr); + if logging then dprintn (infile + ": textHeaderStart = "+string textHeaderStart) + if logging then dprintn (infile + ": dataHeaderStart = "+string dataHeaderStart) + if logging then dprintn (infile + ": dataSegmentAddr (pre section crack) = "+string dataSegmentAddr) let dataSegmentSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 8) let dataSegmentAddr = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 12) let dataSegmentPhysicalSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 16) let dataSegmentPhysicalLoc = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 20) - if logging then dprintn (infile + ": dataSegmentAddr (post section crack) = "+string dataSegmentAddr); + if logging then dprintn (infile + ": dataSegmentAddr (post section crack) = "+string dataSegmentAddr) let anyV2P (n,v) = let rec look i pos = @@ -3411,11 +3409,11 @@ let rec genOpenBinaryReader infile is opts = else look (i+1) (pos + 0x28) look 0 sectionHeadersStartPhysLoc - if logging then dprintn (infile + ": numSections = "+string numSections); - if logging then dprintn (infile + ": cliHeaderAddr = "+string cliHeaderAddr); - if logging then dprintn (infile + ": cliHeaderPhys = "+string (anyV2P ("cli header",cliHeaderAddr))); - if logging then dprintn (infile + ": dataSegmentSize = "+string dataSegmentSize); - if logging then dprintn (infile + ": dataSegmentAddr = "+string dataSegmentAddr); + if logging then dprintn (infile + ": numSections = "+string numSections) + if logging then dprintn (infile + ": cliHeaderAddr = "+string cliHeaderAddr) + if logging then dprintn (infile + ": cliHeaderPhys = "+string (anyV2P ("cli header",cliHeaderAddr))) + if logging then dprintn (infile + ": dataSegmentSize = "+string dataSegmentSize) + if logging then dprintn (infile + ": dataSegmentAddr = "+string dataSegmentAddr) let cliHeaderPhysLoc = anyV2P ("cli header",cliHeaderAddr) @@ -3439,17 +3437,17 @@ let rec genOpenBinaryReader infile is opts = let vtableFixupsAddr = seekReadInt32 is (cliHeaderPhysLoc + 40) let _vtableFixupsSize = seekReadInt32 is (cliHeaderPhysLoc + 44) - if logging then dprintn (infile + ": metadataAddr = "+string metadataAddr); - if logging then dprintn (infile + ": resourcesAddr = "+string resourcesAddr); - if logging then dprintn (infile + ": resourcesSize = "+string resourcesSize); - if logging then dprintn (infile + ": nativeResourcesAddr = "+string nativeResourcesAddr); - if logging then dprintn (infile + ": nativeResourcesSize = "+string nativeResourcesSize); + if logging then dprintn (infile + ": metadataAddr = "+string metadataAddr) + if logging then dprintn (infile + ": resourcesAddr = "+string resourcesAddr) + if logging then dprintn (infile + ": resourcesSize = "+string resourcesSize) + if logging then dprintn (infile + ": nativeResourcesAddr = "+string nativeResourcesAddr) + if logging then dprintn (infile + ": nativeResourcesSize = "+string nativeResourcesSize) let metadataPhysLoc = anyV2P ("metadata",metadataAddr) let magic = seekReadUInt16AsInt32 is metadataPhysLoc - if magic <> 0x5342 then failwith (infile + ": bad metadata magic number: " + string magic); + if magic <> 0x5342 then failwith (infile + ": bad metadata magic number: " + string magic) let magic2 = seekReadUInt16AsInt32 is (metadataPhysLoc + 2) - if magic2 <> 0x424a then failwith "bad metadata magic number"; + if magic2 <> 0x424a then failwith "bad metadata magic number" let _majorMetadataVersion = seekReadUInt16 is (metadataPhysLoc + 4) let _minorMetadataVersion = seekReadUInt16 is (metadataPhysLoc + 6) @@ -3459,8 +3457,8 @@ let rec genOpenBinaryReader infile is opts = let numStreams = seekReadUInt16AsInt32 is (metadataPhysLoc + x + 2) let streamHeadersStart = (metadataPhysLoc + x + 4) - if logging then dprintn (infile + ": numStreams = "+string numStreams); - if logging then dprintn (infile + ": streamHeadersStart = "+string streamHeadersStart); + if logging then dprintn (infile + ": numStreams = "+string numStreams) + if logging then dprintn (infile + ": streamHeadersStart = "+string streamHeadersStart) (* Crack stream headers *) @@ -3479,7 +3477,7 @@ let rec genOpenBinaryReader infile is opts = if c = 0 then fin := true elif !n >= Array.length name || c <> name.[!n] then - res := false; + res := false incr n if !res then Some(offset + metadataPhysLoc,length) else look (i+1) (align 0x04 (pos + 8 + (!n))) @@ -3490,14 +3488,14 @@ let rec genOpenBinaryReader infile is opts = | None -> (0x0, 0x0) | Some positions -> positions - let (tablesStreamPhysLoc, tablesStreamSize) = + let (tablesStreamPhysLoc, _tablesStreamSize) = match tryFindStream [| 0x23; 0x7e |] (* #~ *) with | Some res -> res | None -> match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *) with | Some res -> res | None -> - dprintf "no metadata tables found under stream names '#~' or '#-', please report this\n"; + dprintf "no metadata tables found under stream names '#~' or '#-', please report this\n" let firstStreamOffset = seekReadInt32 is (streamHeadersStart + 0) let firstStreamLength = seekReadInt32 is (streamHeadersStart + 4) firstStreamOffset,firstStreamLength @@ -3507,84 +3505,71 @@ let rec genOpenBinaryReader infile is opts = let (guidsStreamPhysicalLoc, _guidsStreamSize) = findStream [| 0x23; 0x47; 0x55; 0x49; 0x44; |] (* #GUID *) let (blobsStreamPhysicalLoc, blobsStreamSize) = findStream [| 0x23; 0x42; 0x6c; 0x6f; 0x62; |] (* #Blob *) - if logging then dprintn (infile + ": tablesAddr = "+string tablesStreamPhysLoc); - if logging then dprintn (infile + ": tablesSize = "+string tablesStreamSize); - if logging then dprintn (infile + ": stringsAddr = "+string stringsStreamPhysicalLoc); - if logging then dprintn (infile + ": stringsSize = "+string stringsStreamSize); - if logging then dprintn (infile + ": user_stringsAddr = "+string userStringsStreamPhysicalLoc); - if logging then dprintn (infile + ": guidsAddr = "+string guidsStreamPhysicalLoc); - if logging then dprintn (infile + ": blobsAddr = "+string blobsStreamPhysicalLoc); - - let tables_streamMajor_version = seekReadByteAsInt32 is (tablesStreamPhysLoc + 4) - let tables_streamMinor_version = seekReadByteAsInt32 is (tablesStreamPhysLoc + 5) - - let usingWhidbeyBeta1TableSchemeForGenericParam = (tables_streamMajor_version = 1) && (tables_streamMinor_version = 1) - let tableKinds = - [|kindModule (* Table 0 *); - kindTypeRef (* Table 1 *); - kindTypeDef (* Table 2 *); - kindIllegal (* kindFieldPtr *) (* Table 3 *); - kindFieldDef (* Table 4 *); - kindIllegal (* kindMethodPtr *) (* Table 5 *); - kindMethodDef (* Table 6 *); - kindIllegal (* kindParamPtr *) (* Table 7 *); - kindParam (* Table 8 *); - kindInterfaceImpl (* Table 9 *); - kindMemberRef (* Table 10 *); - kindConstant (* Table 11 *); - kindCustomAttribute (* Table 12 *); - kindFieldMarshal (* Table 13 *); - kindDeclSecurity (* Table 14 *); - kindClassLayout (* Table 15 *); - kindFieldLayout (* Table 16 *); - kindStandAloneSig (* Table 17 *); - kindEventMap (* Table 18 *); - kindIllegal (* kindEventPtr *) (* Table 19 *); - kindEvent (* Table 20 *); - kindPropertyMap (* Table 21 *); - kindIllegal (* kindPropertyPtr *) (* Table 22 *); - kindProperty (* Table 23 *); - kindMethodSemantics (* Table 24 *); - kindMethodImpl (* Table 25 *); - kindModuleRef (* Table 26 *); - kindTypeSpec (* Table 27 *); - kindImplMap (* Table 28 *); - kindFieldRVA (* Table 29 *); - kindIllegal (* kindENCLog *) (* Table 30 *); - kindIllegal (* kindENCMap *) (* Table 31 *); - kindAssembly (* Table 32 *); - kindIllegal (* kindAssemblyProcessor *) (* Table 33 *); - kindIllegal (* kindAssemblyOS *) (* Table 34 *); - kindAssemblyRef (* Table 35 *); - kindIllegal (* kindAssemblyRefProcessor *) (* Table 36 *); - kindIllegal (* kindAssemblyRefOS *) (* Table 37 *); - kindFileRef (* Table 38 *); - kindExportedType (* Table 39 *); - kindManifestResource (* Table 40 *); - kindNested (* Table 41 *); - (if usingWhidbeyBeta1TableSchemeForGenericParam then kindGenericParam_v1_1 else kindGenericParam_v2_0); (* Table 42 *) - kindMethodSpec (* Table 43 *); - kindGenericParamConstraint (* Table 44 *); - kindIllegal (* Table 45 *); - kindIllegal (* Table 46 *); - kindIllegal (* Table 47 *); - kindIllegal (* Table 48 *); - kindIllegal (* Table 49 *); - kindIllegal (* Table 50 *); - kindIllegal (* Table 51 *); - kindIllegal (* Table 52 *); - kindIllegal (* Table 53 *); - kindIllegal (* Table 54 *); - kindIllegal (* Table 55 *); - kindIllegal (* Table 56 *); - kindIllegal (* Table 57 *); - kindIllegal (* Table 58 *); - kindIllegal (* Table 59 *); - kindIllegal (* Table 60 *); - kindIllegal (* Table 61 *); - kindIllegal (* Table 62 *); - kindIllegal (* Table 63 *); + [|kindModule (* Table 0 *) + kindTypeRef (* Table 1 *) + kindTypeDef (* Table 2 *) + kindIllegal (* kindFieldPtr *) (* Table 3 *) + kindFieldDef (* Table 4 *) + kindIllegal (* kindMethodPtr *) (* Table 5 *) + kindMethodDef (* Table 6 *) + kindIllegal (* kindParamPtr *) (* Table 7 *) + kindParam (* Table 8 *) + kindInterfaceImpl (* Table 9 *) + kindMemberRef (* Table 10 *) + kindConstant (* Table 11 *) + kindCustomAttribute (* Table 12 *) + kindFieldMarshal (* Table 13 *) + kindDeclSecurity (* Table 14 *) + kindClassLayout (* Table 15 *) + kindFieldLayout (* Table 16 *) + kindStandAloneSig (* Table 17 *) + kindEventMap (* Table 18 *) + kindIllegal (* kindEventPtr *) (* Table 19 *) + kindEvent (* Table 20 *) + kindPropertyMap (* Table 21 *) + kindIllegal (* kindPropertyPtr *) (* Table 22 *) + kindProperty (* Table 23 *) + kindMethodSemantics (* Table 24 *) + kindMethodImpl (* Table 25 *) + kindModuleRef (* Table 26 *) + kindTypeSpec (* Table 27 *) + kindImplMap (* Table 28 *) + kindFieldRVA (* Table 29 *) + kindIllegal (* kindENCLog *) (* Table 30 *) + kindIllegal (* kindENCMap *) (* Table 31 *) + kindAssembly (* Table 32 *) + kindIllegal (* kindAssemblyProcessor *) (* Table 33 *) + kindIllegal (* kindAssemblyOS *) (* Table 34 *) + kindAssemblyRef (* Table 35 *) + kindIllegal (* kindAssemblyRefProcessor *) (* Table 36 *) + kindIllegal (* kindAssemblyRefOS *) (* Table 37 *) + kindFileRef (* Table 38 *) + kindExportedType (* Table 39 *) + kindManifestResource (* Table 40 *) + kindNested (* Table 41 *) + kindGenericParam_v2_0 (* Table 42 *) + kindMethodSpec (* Table 43 *) + kindGenericParamConstraint (* Table 44 *) + kindIllegal (* Table 45 *) + kindIllegal (* Table 46 *) + kindIllegal (* Table 47 *) + kindIllegal (* Table 48 *) + kindIllegal (* Table 49 *) + kindIllegal (* Table 50 *) + kindIllegal (* Table 51 *) + kindIllegal (* Table 52 *) + kindIllegal (* Table 53 *) + kindIllegal (* Table 54 *) + kindIllegal (* Table 55 *) + kindIllegal (* Table 56 *) + kindIllegal (* Table 57 *) + kindIllegal (* Table 58 *) + kindIllegal (* Table 59 *) + kindIllegal (* Table 60 *) + kindIllegal (* Table 61 *) + kindIllegal (* Table 62 *) + kindIllegal (* Table 63 *) |] let heapSizes = seekReadByteAsInt32 is (tablesStreamPhysLoc + 6) @@ -3596,8 +3581,8 @@ let rec genOpenBinaryReader infile is opts = let prevNumRowIdx = ref (tablesStreamPhysLoc + 24) for i = 0 to 63 do if (valid &&& (int64 1 <<< i)) <> int64 0 then - present := i :: !present; - numRows.[i] <- (seekReadInt32 is !prevNumRowIdx); + present := i :: !present + numRows.[i] <- (seekReadInt32 is !prevNumRowIdx) prevNumRowIdx := !prevNumRowIdx + 4 List.rev !present, numRows, !prevNumRowIdx @@ -3607,9 +3592,9 @@ let rec genOpenBinaryReader infile is opts = let guidsBigness = (heapSizes &&& 2) <> 0 let blobsBigness = (heapSizes &&& 4) <> 0 - if logging then dprintn (infile + ": numTables = "+string numTables); - if logging && stringsBigness then dprintn (infile + ": strings are big"); - if logging && blobsBigness then dprintn (infile + ": blobs are big"); + if logging then dprintn (infile + ": numTables = "+string numTables) + if logging && stringsBigness then dprintn (infile + ": strings are big") + if logging && blobsBigness then dprintn (infile + ": blobs are big") let tableBigness = Array.map (fun n -> n >= 0x10000) tableRowCount @@ -3729,9 +3714,9 @@ let rec genOpenBinaryReader infile is opts = let res = Array.create 64 0x0 let prevTablePhysLoc = ref startOfTables for i = 0 to 63 do - res.[i] <- !prevTablePhysLoc; - prevTablePhysLoc := !prevTablePhysLoc + (tableRowCount.[i] * tableRowSizes.[i]); - if logging then dprintf "tablePhysLocations.[%d] = %d, offset from startOfTables = 0x%08x\n" i res.[i] (res.[i] - startOfTables); + res.[i] <- !prevTablePhysLoc + prevTablePhysLoc := !prevTablePhysLoc + (tableRowCount.[i] * tableRowSizes.[i]) + if logging then dprintf "tablePhysLocations.[%d] = %d, offset from startOfTables = 0x%08x\n" i res.[i] (res.[i] - startOfTables) res let inbase = Filename.fileNameOfPath infile + ": " @@ -3771,7 +3756,7 @@ let rec genOpenBinaryReader infile is opts = let count = ref 0 #if DEBUG #if STATISTICS - addReport (fun oc -> if !count <> 0 then oc.WriteLine (inbase+string !count + " "+_nm+" rows read")); + addReport (fun oc -> if !count <> 0 then oc.WriteLine (inbase+string !count + " "+_nm+" rows read")) #endif #else _nm |> ignore @@ -3834,110 +3819,110 @@ let rec genOpenBinaryReader infile is opts = // Build the reader context // Use an initialization hole let ctxtH = ref None - let ctxt = { ilg=opts.ilGlobals; - dataEndPoints = dataEndPoints ctxtH; - pdb=pdb; - sorted=sorted; - getNumRows=getNumRows; - textSegmentPhysicalLoc=textSegmentPhysicalLoc; - textSegmentPhysicalSize=textSegmentPhysicalSize; - dataSegmentPhysicalLoc=dataSegmentPhysicalLoc; - dataSegmentPhysicalSize=dataSegmentPhysicalSize; - anyV2P=anyV2P; - metadataAddr=metadataAddr; - sectionHeaders=sectionHeaders; - nativeResourcesAddr=nativeResourcesAddr; - nativeResourcesSize=nativeResourcesSize; - resourcesAddr=resourcesAddr; - strongnameAddr=strongnameAddr; - vtableFixupsAddr=vtableFixupsAddr; - is=is; - infile=infile; - userStringsStreamPhysicalLoc = userStringsStreamPhysicalLoc; - stringsStreamPhysicalLoc = stringsStreamPhysicalLoc; - blobsStreamPhysicalLoc = blobsStreamPhysicalLoc; - blobsStreamSize = blobsStreamSize; - memoizeString = Tables.memoize id; - readUserStringHeap = cacheUserStringHeap (readUserStringHeapUncached ctxtH); - readStringHeap = cacheStringHeap (readStringHeapUncached ctxtH); - readBlobHeap = cacheBlobHeap (readBlobHeapUncached ctxtH); - seekReadNestedRow = cacheNestedRow (seekReadNestedRowUncached ctxtH); - seekReadConstantRow = cacheConstantRow (seekReadConstantRowUncached ctxtH); - seekReadMethodSemanticsRow = cacheMethodSemanticsRow (seekReadMethodSemanticsRowUncached ctxtH); - seekReadTypeDefRow = cacheTypeDefRow (seekReadTypeDefRowUncached ctxtH); - seekReadInterfaceImplRow = cacheInterfaceImplRow (seekReadInterfaceImplRowUncached ctxtH); - seekReadFieldMarshalRow = cacheFieldMarshalRow (seekReadFieldMarshalRowUncached ctxtH); - seekReadPropertyMapRow = cachePropertyMapRow (seekReadPropertyMapRowUncached ctxtH); - seekReadAssemblyRef = cacheAssemblyRef (seekReadAssemblyRefUncached ctxtH); - seekReadMethodSpecAsMethodData = cacheMethodSpecAsMethodData (seekReadMethodSpecAsMethodDataUncached ctxtH); - seekReadMemberRefAsMethodData = cacheMemberRefAsMemberData (seekReadMemberRefAsMethodDataUncached ctxtH); - seekReadMemberRefAsFieldSpec = seekReadMemberRefAsFieldSpecUncached ctxtH; - seekReadCustomAttr = cacheCustomAttr (seekReadCustomAttrUncached ctxtH); - seekReadSecurityDecl = seekReadSecurityDeclUncached ctxtH; - seekReadTypeRef = cacheTypeRef (seekReadTypeRefUncached ctxtH); - readBlobHeapAsPropertySig = cacheBlobHeapAsPropertySig (readBlobHeapAsPropertySigUncached ctxtH); - readBlobHeapAsFieldSig = cacheBlobHeapAsFieldSig (readBlobHeapAsFieldSigUncached ctxtH); - readBlobHeapAsMethodSig = cacheBlobHeapAsMethodSig (readBlobHeapAsMethodSigUncached ctxtH); - readBlobHeapAsLocalsSig = readBlobHeapAsLocalsSigUncached ctxtH; - seekReadTypeDefAsType = cacheTypeDefAsType (seekReadTypeDefAsTypeUncached ctxtH); - seekReadTypeRefAsType = cacheTypeRefAsType (seekReadTypeRefAsTypeUncached ctxtH); - seekReadMethodDefAsMethodData = cacheMethodDefAsMethodData (seekReadMethodDefAsMethodDataUncached ctxtH); - seekReadGenericParams = cacheGenericParams (seekReadGenericParamsUncached ctxtH); - seekReadFieldDefAsFieldSpec = cacheFieldDefAsFieldSpec (seekReadFieldDefAsFieldSpecUncached ctxtH); - guidsStreamPhysicalLoc = guidsStreamPhysicalLoc; - rowAddr=rowAddr; - entryPointToken=entryPointToken; - rsBigness=rsBigness; - tdorBigness=tdorBigness; - tomdBigness=tomdBigness; - hcBigness=hcBigness; - hcaBigness=hcaBigness; - hfmBigness=hfmBigness; - hdsBigness=hdsBigness; - mrpBigness=mrpBigness; - hsBigness=hsBigness; - mdorBigness=mdorBigness; - mfBigness=mfBigness; - iBigness=iBigness; - catBigness=catBigness; - stringsBigness=stringsBigness; - guidsBigness=guidsBigness; - blobsBigness=blobsBigness; - tableBigness=tableBigness; - countTypeRef = countTypeRef; - countTypeDef = countTypeDef; - countField = countField; - countMethod = countMethod; - countParam = countParam; - countInterfaceImpl = countInterfaceImpl; - countMemberRef = countMemberRef; - countConstant = countConstant; - countCustomAttribute = countCustomAttribute; - countFieldMarshal = countFieldMarshal; - countPermission = countPermission; - countClassLayout = countClassLayout; - countFieldLayout = countFieldLayout; - countStandAloneSig = countStandAloneSig; - countEventMap = countEventMap; - countEvent = countEvent; - countPropertyMap = countPropertyMap; - countProperty = countProperty; - countMethodSemantics = countMethodSemantics; - countMethodImpl = countMethodImpl; - countModuleRef = countModuleRef; - countTypeSpec = countTypeSpec; - countImplMap = countImplMap; - countFieldRVA = countFieldRVA; - countAssembly = countAssembly; - countAssemblyRef = countAssemblyRef; - countFile = countFile; - countExportedType = countExportedType; - countManifestResource = countManifestResource; - countNested = countNested; - countGenericParam = countGenericParam; - countGenericParamConstraint = countGenericParamConstraint; - countMethodSpec = countMethodSpec; } - ctxtH := Some ctxt; + let ctxt = { ilg=opts.ilGlobals + dataEndPoints = dataEndPoints ctxtH + pdb=pdb + sorted=sorted + getNumRows=getNumRows + textSegmentPhysicalLoc=textSegmentPhysicalLoc + textSegmentPhysicalSize=textSegmentPhysicalSize + dataSegmentPhysicalLoc=dataSegmentPhysicalLoc + dataSegmentPhysicalSize=dataSegmentPhysicalSize + anyV2P=anyV2P + metadataAddr=metadataAddr + sectionHeaders=sectionHeaders + nativeResourcesAddr=nativeResourcesAddr + nativeResourcesSize=nativeResourcesSize + resourcesAddr=resourcesAddr + strongnameAddr=strongnameAddr + vtableFixupsAddr=vtableFixupsAddr + is=is + infile=infile + userStringsStreamPhysicalLoc = userStringsStreamPhysicalLoc + stringsStreamPhysicalLoc = stringsStreamPhysicalLoc + blobsStreamPhysicalLoc = blobsStreamPhysicalLoc + blobsStreamSize = blobsStreamSize + memoizeString = Tables.memoize id + readUserStringHeap = cacheUserStringHeap (readUserStringHeapUncached ctxtH) + readStringHeap = cacheStringHeap (readStringHeapUncached ctxtH) + readBlobHeap = cacheBlobHeap (readBlobHeapUncached ctxtH) + seekReadNestedRow = cacheNestedRow (seekReadNestedRowUncached ctxtH) + seekReadConstantRow = cacheConstantRow (seekReadConstantRowUncached ctxtH) + seekReadMethodSemanticsRow = cacheMethodSemanticsRow (seekReadMethodSemanticsRowUncached ctxtH) + seekReadTypeDefRow = cacheTypeDefRow (seekReadTypeDefRowUncached ctxtH) + seekReadInterfaceImplRow = cacheInterfaceImplRow (seekReadInterfaceImplRowUncached ctxtH) + seekReadFieldMarshalRow = cacheFieldMarshalRow (seekReadFieldMarshalRowUncached ctxtH) + seekReadPropertyMapRow = cachePropertyMapRow (seekReadPropertyMapRowUncached ctxtH) + seekReadAssemblyRef = cacheAssemblyRef (seekReadAssemblyRefUncached ctxtH) + seekReadMethodSpecAsMethodData = cacheMethodSpecAsMethodData (seekReadMethodSpecAsMethodDataUncached ctxtH) + seekReadMemberRefAsMethodData = cacheMemberRefAsMemberData (seekReadMemberRefAsMethodDataUncached ctxtH) + seekReadMemberRefAsFieldSpec = seekReadMemberRefAsFieldSpecUncached ctxtH + seekReadCustomAttr = cacheCustomAttr (seekReadCustomAttrUncached ctxtH) + seekReadSecurityDecl = seekReadSecurityDeclUncached ctxtH + seekReadTypeRef = cacheTypeRef (seekReadTypeRefUncached ctxtH) + readBlobHeapAsPropertySig = cacheBlobHeapAsPropertySig (readBlobHeapAsPropertySigUncached ctxtH) + readBlobHeapAsFieldSig = cacheBlobHeapAsFieldSig (readBlobHeapAsFieldSigUncached ctxtH) + readBlobHeapAsMethodSig = cacheBlobHeapAsMethodSig (readBlobHeapAsMethodSigUncached ctxtH) + readBlobHeapAsLocalsSig = readBlobHeapAsLocalsSigUncached ctxtH + seekReadTypeDefAsType = cacheTypeDefAsType (seekReadTypeDefAsTypeUncached ctxtH) + seekReadTypeRefAsType = cacheTypeRefAsType (seekReadTypeRefAsTypeUncached ctxtH) + seekReadMethodDefAsMethodData = cacheMethodDefAsMethodData (seekReadMethodDefAsMethodDataUncached ctxtH) + seekReadGenericParams = cacheGenericParams (seekReadGenericParamsUncached ctxtH) + seekReadFieldDefAsFieldSpec = cacheFieldDefAsFieldSpec (seekReadFieldDefAsFieldSpecUncached ctxtH) + guidsStreamPhysicalLoc = guidsStreamPhysicalLoc + rowAddr=rowAddr + entryPointToken=entryPointToken + rsBigness=rsBigness + tdorBigness=tdorBigness + tomdBigness=tomdBigness + hcBigness=hcBigness + hcaBigness=hcaBigness + hfmBigness=hfmBigness + hdsBigness=hdsBigness + mrpBigness=mrpBigness + hsBigness=hsBigness + mdorBigness=mdorBigness + mfBigness=mfBigness + iBigness=iBigness + catBigness=catBigness + stringsBigness=stringsBigness + guidsBigness=guidsBigness + blobsBigness=blobsBigness + tableBigness=tableBigness + countTypeRef = countTypeRef + countTypeDef = countTypeDef + countField = countField + countMethod = countMethod + countParam = countParam + countInterfaceImpl = countInterfaceImpl + countMemberRef = countMemberRef + countConstant = countConstant + countCustomAttribute = countCustomAttribute + countFieldMarshal = countFieldMarshal + countPermission = countPermission + countClassLayout = countClassLayout + countFieldLayout = countFieldLayout + countStandAloneSig = countStandAloneSig + countEventMap = countEventMap + countEvent = countEvent + countPropertyMap = countPropertyMap + countProperty = countProperty + countMethodSemantics = countMethodSemantics + countMethodImpl = countMethodImpl + countModuleRef = countModuleRef + countTypeSpec = countTypeSpec + countImplMap = countImplMap + countFieldRVA = countFieldRVA + countAssembly = countAssembly + countAssemblyRef = countAssemblyRef + countFile = countFile + countExportedType = countExportedType + countManifestResource = countManifestResource + countNested = countNested + countGenericParam = countGenericParam + countGenericParamConstraint = countGenericParamConstraint + countMethodSpec = countMethodSpec } + ctxtH := Some ctxt let ilModule = seekReadModule ctxt (subsys, (subsysMajor, subsysMinor), useHighEnthropyVA, ilOnly,only32,is32bitpreferred,only64,platform,isDll, alignVirt,alignPhys,imageBaseReal,System.Text.Encoding.UTF8.GetString (ilMetadataVersion, 0, ilMetadataVersion.Length)) 1 let ilAssemblyRefs = lazy [ for i in 1 .. getNumRows TableNames.AssemblyRef do yield seekReadAssemblyRef ctxt i ] @@ -3945,8 +3930,8 @@ let rec genOpenBinaryReader infile is opts = ilModule,ilAssemblyRefs,pdb let mkDefault ilg = - { optimizeForMemory=false; - pdbPath= None; + { optimizeForMemory=false + pdbPath= None ilGlobals = ilg } let ClosePdbReader pdb = @@ -3964,16 +3949,16 @@ let OpenILModuleReader infile opts = try let mmap = MemoryMappedFile.Create infile let modul,ilAssemblyRefs,pdb = genOpenBinaryReader infile mmap opts - { modul = modul; - ilAssemblyRefs=ilAssemblyRefs; + { modul = modul + ilAssemblyRefs=ilAssemblyRefs dispose = (fun () -> - mmap.Close(); + mmap.Close() ClosePdbReader pdb) } with _ -> let mc = ByteFile(infile |> FileSystem.ReadAllBytesShim) let modul,ilAssemblyRefs,pdb = genOpenBinaryReader infile mc opts - { modul = modul; - ilAssemblyRefs = ilAssemblyRefs; + { modul = modul + ilAssemblyRefs = ilAssemblyRefs dispose = (fun () -> ClosePdbReader pdb) } @@ -3999,7 +3984,7 @@ let OpenILModuleReaderAfterReadingAllBytes infile opts = let mc = ByteFile(infile |> FileSystem.ReadAllBytesShim) let modul,ilAssemblyRefs,pdb = genOpenBinaryReader infile mc opts let ilModuleReader = - { modul = modul; + { modul = modul ilAssemblyRefs = ilAssemblyRefs dispose = (fun () -> ClosePdbReader pdb) } if isNone pdb && succeeded then @@ -4011,7 +3996,7 @@ let OpenILModuleReaderFromBytes fileNameForDebugOutput bytes opts = let mc = ByteFile(bytes) let modul,ilAssemblyRefs,pdb = genOpenBinaryReader fileNameForDebugOutput mc opts let ilModuleReader = - { modul = modul; + { modul = modul ilAssemblyRefs = ilAssemblyRefs dispose = (fun () -> ClosePdbReader pdb) } ilModuleReader diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index f820d62d02..37b459d817 100755 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -1476,10 +1476,10 @@ let CollectErrorOrWarning (implicitIncludeDir,showFullPaths,flattenErrors,errorS match err.Exception with | ReportedError _ -> - dprintf "Unexpected ReportedError" (* this should actually never happen *) + assert ("" = "Unexpected ReportedError") // this should never happen Seq.empty | StopProcessing -> - dprintf "Unexpected StopProcessing" (* this should actually never happen *) + assert ("" = "Unexpected StopProcessing") // this should never happen Seq.empty | _ -> let errors = ResizeArray() @@ -2962,6 +2962,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = let logmessage showMessages = if showMessages && tcConfig.showReferenceResolutions then (fun (message:string)->dprintf "%s\n" message) else ignore + let logwarning showMessages = (fun code message-> if showMessages && mode = ReportErrors then @@ -2975,6 +2976,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = | _ -> (if code = "MSB3245" then errorR else warning) (MSBuildReferenceResolutionWarning(code,message,errorAndWarningRange))) + let logerror showMessages = (fun code message -> if showMessages && mode = ReportErrors then @@ -2988,10 +2990,12 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = | Some(X86) -> "x86" | Some(AMD64) -> "amd64" | Some(IA64) -> "ia64" + let outputDirectory = match tcConfig.outputFile with | Some(outputFile) -> tcConfig.MakePathAbsolute outputFile | None -> tcConfig.implicitIncludeDir + let targetFrameworkDirectories = match tcConfig.clrRoot with | Some(clrRoot) -> [tcConfig.MakePathAbsolute clrRoot] @@ -3033,6 +3037,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = |> Array.map(fun i->(p13 groupedReferences.[i]),(p23 groupedReferences.[i]),i) |> Array.filter (fun (_,i0,_)->resolvedAsFile|>Array.exists(fun (i1,_) -> i0=i1)|>not) |> Array.map(fun (ref,_,i)->ref,string i) + let resolutions = Resolve(toMsBuild,(*showMessages*)true) // Map back to original assembly resolutions. diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index c34e18d20c..45c776bc00 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -160,31 +160,32 @@ type TcValF = (ValRef -> ValUseFlag -> TType list -> range -> Expr * TType) type ConstraintSolverState = { - g: TcGlobals; - amap: Import.ImportMap; - InfoReader : InfoReader; + g: TcGlobals + amap: Import.ImportMap + InfoReader : InfoReader TcVal : TcValF /// This table stores all unsolved, ungeneralized trait constraints, indexed by free type variable. /// That is, there will be one entry in this table for each free type variable in /// each outstanding, unsolved, ungeneralized trait constraint. Constraints are removed from the table and resolved /// each time a solution to an index variable is found. - mutable ExtraCxs: HashMultiMap; + mutable ExtraCxs: HashMultiMap } static member New(g,amap,infoReader, tcVal) = - { g=g; amap=amap; + { g=g + amap=amap ExtraCxs= HashMultiMap(10, HashIdentity.Structural) InfoReader=infoReader - TcVal = tcVal } ; + TcVal = tcVal } type ConstraintSolverEnv = { - SolverState: ConstraintSolverState; + SolverState: ConstraintSolverState eContextInfo: ContextInfo MatchingOnly : bool - m: range; - EquivEnv: TypeEquivEnv; + m: range + EquivEnv: TypeEquivEnv DisplayEnv : DisplayEnv } member csenv.InfoReader = csenv.SolverState.InfoReader @@ -192,12 +193,12 @@ type ConstraintSolverEnv = member csenv.amap = csenv.SolverState.amap let MakeConstraintSolverEnv contextInfo css m denv = - { SolverState=css; - m=m; + { SolverState=css + m=m eContextInfo = contextInfo // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved - MatchingOnly=false; - EquivEnv=TypeEquivEnv.Empty; + MatchingOnly=false + EquivEnv=TypeEquivEnv.Empty DisplayEnv = denv } @@ -303,9 +304,10 @@ let BakedInTraitConstraintNames = // Run the constraint solver with undo (used during method overload resolution) type Trace = - | Trace of (unit -> unit) list ref - static member New () = Trace (ref []) - member t.Undo () = let (Trace trace) = t in List.iter (fun a -> a ()) !trace + { mutable actions: (unit -> unit) list } + static member New () = { actions = [] } + member t.Undo () = List.iter (fun a -> a ()) t.actions + member t.Push f = t.actions <- f :: t.actions type OptionalTrace = | NoTrace @@ -417,7 +419,7 @@ let rec TransactStaticReq (csenv:ConstraintSolverEnv) trace (tpr:Typar) req = let orig = tpr.StaticReq match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> tpr.SetStaticReq orig) :: !actions + | WithTrace trace -> trace.Push (fun () -> tpr.SetStaticReq orig) tpr.SetStaticReq req; CompleteD @@ -446,7 +448,7 @@ let rec TransactDynamicReq trace (tpr:Typar) req = let orig = tpr.DynamicReq match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> tpr.SetDynamicReq orig) :: !actions + | WithTrace trace -> trace.Push (fun () -> tpr.SetDynamicReq orig) tpr.SetDynamicReq req; CompleteD @@ -673,7 +675,7 @@ let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty = let tpdata = r.Data match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> tpdata.typar_solution <- None) :: !actions + | WithTrace trace -> trace.Push (fun () -> tpdata.typar_solution <- None) tpdata.typar_solution <- Some ty; (* dprintf "setting typar %d to type %s at %a\n" r.Stamp ((DebugPrint.showType ty)) outputRange m; *) @@ -1343,7 +1345,7 @@ and TransactMemberConstraintSolution traitInfo trace sln = traitInfo.Solution <- Some sln match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> traitInfo.Solution <- prev) :: !actions + | WithTrace trace -> trace.Push (fun () -> traitInfo.Solution <- prev) /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads @@ -1410,7 +1412,7 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn,cx))) :: !actions + | WithTrace trace -> trace.Push (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn,cx))) cxs |> AtLeastOneD (fun (traitInfo,m2) -> let csenv = { csenv with m = m2 } @@ -1437,7 +1439,7 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup if not (cxs |> List.exists (fun (traitInfo2,_) -> traitsAEquiv g aenv traitInfo traitInfo2)) then match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) :: !actions + | WithTrace trace -> trace.Push (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) csenv.SolverState.ExtraCxs.Add (tpn,(traitInfo,m2)) ); @@ -1613,7 +1615,7 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = let orig = d.typar_constraints begin match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> d.typar_constraints <- orig) :: !actions + | WithTrace trace -> trace.Push (fun () -> d.typar_constraints <- orig) end; d.typar_constraints <- newConstraints; @@ -2409,7 +2411,7 @@ let EliminateConstraintsForGeneralizedTypars csenv trace (generalizedTypars: Typ cxst.Remove tpn; match trace with | NoTrace -> () - | WithTrace (Trace actions) -> actions := (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn,cx))) :: !actions) + | WithTrace trace -> trace.Push (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn,cx)))) ) diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 63238ec1c4..3c71ffe57e 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -98,7 +98,8 @@ val BakedInTraitConstraintNames : string list val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv -type Trace = Trace of (unit -> unit) list ref +[] +type Trace type OptionalTrace = | NoTrace diff --git a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj index 8e5334f9b9..3325a28de5 100644 --- a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj +++ b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj @@ -434,12 +434,6 @@ IlxGen.fs - - TraceCall.fsi - - - TraceCall.fs - CompileOps.fsi diff --git a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj index 0e8e0e6953..b247219d83 100644 --- a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj +++ b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj @@ -141,12 +141,6 @@ Utilities\lib.fs - - Utilities\TraceCall.fsi - - - Utilities\TraceCall.fs - Utilities\rational.fsi diff --git a/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj b/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj index 6044b34a6b..8db0f1f893 100644 --- a/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj +++ b/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj @@ -151,9 +151,6 @@ Utilities\rational.fs - - Utilities\TraceCall.fs - ErrorLogging\range.fsi @@ -564,7 +561,6 @@ - diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index 66f421f352..0635dc3c18 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -29,9 +29,9 @@ open Microsoft.FSharp.Compiler.Infos type env = Nix type cenv = - { g: TcGlobals; - amap: Import.ImportMap; - denv: DisplayEnv; + { g: TcGlobals + amap: Import.ImportMap + denv: DisplayEnv mutable unsolved: Typars } let accTy cenv _env ty = @@ -50,29 +50,29 @@ let rec accExpr (cenv:cenv) (env:env) expr = let expr = stripExpr expr match expr with | Expr.Sequential (e1,e2,_,_,_) -> - accExpr cenv env e1; + accExpr cenv env e1 accExpr cenv env e2 | Expr.Let (bind,body,_,_) -> - accBind cenv env bind ; + accBind cenv env bind accExpr cenv env body | Expr.Const (_,_,ty) -> accTy cenv env ty | Expr.Val (_v,_vFlags,_m) -> () | Expr.Quote(ast,_,_,_m,ty) -> - accExpr cenv env ast; - accTy cenv env ty; + accExpr cenv env ast + accTy cenv env ty | Expr.Obj (_,typ,basev,basecall,overrides,iimpls,_m) -> accTy cenv env typ - accExpr cenv env basecall; - accMethods cenv env basev overrides ; - accIntfImpls cenv env basev iimpls; + accExpr cenv env basecall + accMethods cenv env basev overrides + accIntfImpls cenv env basev iimpls | Expr.Op (c,tyargs,args,m) -> accOp cenv env (c,tyargs,args,m) | Expr.App(f,fty,tyargs,argsl,_m) -> - accTy cenv env fty; - accTypeInst cenv env tyargs; - accExpr cenv env f; + accTy cenv env fty + accTypeInst cenv env tyargs + accExpr cenv env f accExprs cenv env argsl // REVIEW: fold the next two cases together | Expr.Lambda(_,_ctorThisValOpt,_baseValOpt,argvs,_body,m,rty) -> @@ -81,24 +81,24 @@ let rec accExpr (cenv:cenv) (env:env) expr = accLambdas cenv env topValInfo expr ty | Expr.TyLambda(_,tps,_body,_m,rty) -> let topValInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps,[],ValReprInfo.unnamedRetVal) - accTy cenv env rty; + accTy cenv env rty let ty = tryMkForallTy tps rty accLambdas cenv env topValInfo expr ty | Expr.TyChoose(_tps,e1,_m) -> accExpr cenv env e1 | Expr.Match(_,_exprm,dtree,targets,m,ty) -> - accTy cenv env ty; - accDTree cenv env dtree; - accTargets cenv env m ty targets; + accTy cenv env ty + accDTree cenv env dtree + accTargets cenv env m ty targets | Expr.LetRec (binds,e,_m,_) -> - accBinds cenv env binds; + accBinds cenv env binds accExpr cenv env e | Expr.StaticOptimization (constraints,e2,e3,_m) -> - accExpr cenv env e2; - accExpr cenv env e3; + accExpr cenv env e2 + accExpr cenv env e3 constraints |> List.iter (function | TTyconEqualsTycon(ty1,ty2) -> - accTy cenv env ty1; + accTy cenv env ty1 accTy cenv env ty2 | TTyconIsStruct(ty1) -> accTy cenv env ty1) @@ -106,7 +106,7 @@ let rec accExpr (cenv:cenv) (env:env) expr = and accMethods cenv env baseValOpt l = List.iter (accMethod cenv env baseValOpt) l and accMethod cenv env _baseValOpt (TObjExprMethod(_slotsig,_attribs,_tps,vs,e,_m)) = - vs |> List.iterSquared (accVal cenv env); + vs |> List.iterSquared (accVal cenv env) accExpr cenv env e and accIntfImpls cenv env baseValOpt l = List.iter (accIntfImpl cenv env baseValOpt) l @@ -116,16 +116,16 @@ and accIntfImpl cenv env baseValOpt (ty,overrides) = and accOp cenv env (op,tyargs,args,_m) = // Special cases - accTypeInst cenv env tyargs; - accExprs cenv env args; + accTypeInst cenv env tyargs + accExprs cenv env args match op with // Handle these as special cases since mutables are allowed inside their bodies | TOp.ILCall (_,_,_,_,_,_,_,_,enclTypeArgs,methTypeArgs,tys) -> - accTypeInst cenv env enclTypeArgs; - accTypeInst cenv env methTypeArgs; + accTypeInst cenv env enclTypeArgs + accTypeInst cenv env methTypeArgs accTypeInst cenv env tys | TOp.TraitCall(TTrait(tys,_nm,_,argtys,rty,_sln)) -> - argtys |> accTypeInst cenv env ; + argtys |> accTypeInst cenv env rty |> Option.iter (accTy cenv env) tys |> List.iter (accTy cenv env) @@ -139,11 +139,11 @@ and accLambdas cenv env topValInfo e ety = | Expr.Lambda _ | Expr.TyLambda _ -> let _tps,ctorThisValOpt,baseValOpt,vsl,body,bodyty = destTopLambda cenv.g cenv.amap topValInfo (e, ety) - accTy cenv env bodyty; - vsl |> List.iterSquared (accVal cenv env); - baseValOpt |> Option.iter (accVal cenv env); - ctorThisValOpt |> Option.iter (accVal cenv env); - accExpr cenv env body; + accTy cenv env bodyty + vsl |> List.iterSquared (accVal cenv env) + baseValOpt |> Option.iter (accVal cenv env) + ctorThisValOpt |> Option.iter (accVal cenv env) + accExpr cenv env body | _ -> accExpr cenv env e @@ -151,17 +151,17 @@ and accExprs cenv env exprs = exprs |> List.iter (accExpr cenv env) and accFlatExprs cenv env exprs = exprs |> FlatList.iter (accExpr cenv env) and accTargets cenv env m ty targets = Array.iter (accTarget cenv env m ty) targets -and accTarget cenv env _m _ty (TTarget(_vs,e,_)) = accExpr cenv env e; +and accTarget cenv env _m _ty (TTarget(_vs,e,_)) = accExpr cenv env e and accDTree cenv env x = match x with - | TDSuccess (es,_n) -> accFlatExprs cenv env es; + | TDSuccess (es,_n) -> accFlatExprs cenv env es | TDBind(bind,rest) -> accBind cenv env bind; accDTree cenv env rest | TDSwitch (e,cases,dflt,m) -> accSwitch cenv env (e,cases,dflt,m) and accSwitch cenv env (e,cases,dflt,_m) = - accExpr cenv env e; - cases |> List.iter (fun (TCase(discrim,e)) -> accDiscrim cenv env discrim; accDTree cenv env e) ; + accExpr cenv env e + cases |> List.iter (fun (TCase(discrim,e)) -> accDiscrim cenv env discrim; accDTree cenv env e) dflt |> Option.iter (accDTree cenv env) and accDiscrim cenv env d = @@ -172,31 +172,31 @@ and accDiscrim cenv env d = | Test.IsNull -> () | Test.IsInst (srcty,tgty) -> accTy cenv env srcty; accTy cenv env tgty | Test.ActivePatternCase (exp, tys, _, _, _) -> - accExpr cenv env exp; + accExpr cenv env exp accTypeInst cenv env tys and accAttrib cenv env (Attrib(_,_k,args,props,_,_,_m)) = - args |> List.iter (fun (AttribExpr(e1,_)) -> accExpr cenv env e1); + args |> List.iter (fun (AttribExpr(e1,_)) -> accExpr cenv env e1) props |> List.iter (fun (AttribNamedArg(_nm,_ty,_flg,AttribExpr(expr,_))) -> accExpr cenv env expr) and accAttribs cenv env attribs = List.iter (accAttrib cenv env) attribs and accValReprInfo cenv env (ValReprInfo(_,args,ret)) = - args |> List.iterSquared (accArgReprInfo cenv env); - ret |> accArgReprInfo cenv env; + args |> List.iterSquared (accArgReprInfo cenv env) + ret |> accArgReprInfo cenv env and accArgReprInfo cenv env (argInfo: ArgReprInfo) = accAttribs cenv env argInfo.Attribs and accVal cenv env v = - v.Attribs |> accAttribs cenv env; - v.ValReprInfo |> Option.iter (accValReprInfo cenv env); + v.Attribs |> accAttribs cenv env + v.ValReprInfo |> Option.iter (accValReprInfo cenv env) v.Type |> accTy cenv env and accBind cenv env (bind:Binding) = - accVal cenv env bind.Var; + accVal cenv env bind.Var let topValInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData - accLambdas cenv env topValInfo bind.Expr bind.Var.Type; + accLambdas cenv env topValInfo bind.Expr bind.Var.Type and accBinds cenv env xs = xs |> FlatList.iter (accBind cenv env) @@ -205,15 +205,15 @@ and accBinds cenv env xs = xs |> FlatList.iter (accBind cenv env) //-------------------------------------------------------------------------- let accTyconRecdField cenv env _tycon (rfield:RecdField) = - accAttribs cenv env rfield.PropertyAttribs; + accAttribs cenv env rfield.PropertyAttribs accAttribs cenv env rfield.FieldAttribs let accTycon cenv env (tycon:Tycon) = - accAttribs cenv env tycon.Attribs; - tycon.AllFieldsArray |> Array.iter (accTyconRecdField cenv env tycon); + accAttribs cenv env tycon.Attribs + tycon.AllFieldsArray |> Array.iter (accTyconRecdField cenv env tycon) if tycon.IsUnionTycon then (* This covers finite unions. *) tycon.UnionCasesAsList |> List.iter (fun uc -> - accAttribs cenv env uc.Attribs; + accAttribs cenv env uc.Attribs uc.RecdFields |> List.iter (accTyconRecdField cenv env tycon)) @@ -232,7 +232,7 @@ and accModuleOrNamespaceDefs cenv env x = List.iter (accModuleOrNamespaceDef cen and accModuleOrNamespaceDef cenv env x = match x with | TMDefRec(_,tycons,mbinds,_m) -> - accTycons cenv env tycons; + accTycons cenv env tycons accModuleOrNamespaceBinds cenv env mbinds | TMDefLet(bind,_m) -> accBind cenv env bind | TMDefDo(e,_m) -> accExpr cenv env e @@ -246,12 +246,12 @@ and accModuleOrNamespaceBind cenv env x = let UnsolvedTyparsOfModuleDef g amap denv (mdef, extraAttribs) = let cenv = - { g =g ; - amap=amap; - denv=denv; + { g =g + amap=amap + denv=denv unsolved = [] } - accModuleOrNamespaceDef cenv Nix mdef; - accAttribs cenv Nix extraAttribs; + accModuleOrNamespaceDef cenv Nix mdef + accAttribs cenv Nix extraAttribs List.rev cenv.unsolved diff --git a/src/fsharp/LexFilter.fs b/src/fsharp/LexFilter.fs index e4ef817ca7..66112b4608 100755 --- a/src/fsharp/LexFilter.fs +++ b/src/fsharp/LexFilter.fs @@ -534,7 +534,6 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, new LexbufState(lexbuf.StartPos, lexbuf.EndPos, lexbuf.IsPastEndOfStream) let setLexbufState (p:LexbufState) = - // if debug then dprintf "SET lex state to; %a\n" output_any p; lexbuf.StartPos <- p.StartPos lexbuf.EndPos <- p.EndPos lexbuf.IsPastEndOfStream <- p.PastEOF diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 6bff652145..55632d51a6 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -310,7 +310,7 @@ let ShowCounterExample g denv m refuted = match refutations with | [] -> raise CannotRefute | h :: t -> - if verbose then dprintf "h = %s\n" (Layout.showL (exprL h)); + if verbose then dprintf "h = %s\n" (Layout.showL (exprL h)) List.fold (CombineRefutations g) h t let text = Layout.showL (NicePrint.dataExprL denv counterExample) let failingWhenClause = refuted |> List.exists (function RefutedWhenClause -> true | _ -> false) @@ -320,7 +320,7 @@ let ShowCounterExample g denv m refuted = | CannotRefute -> None | e -> - warning(InternalError(sprintf "" (e.ToString()),m)); + warning(InternalError(sprintf "" (e.ToString()),m)) None //--------------------------------------------------------------------------- @@ -494,7 +494,7 @@ let (|ListEmptyDiscrim|_|) g = function /// switches, string switches and floating point switches are treated in the /// same way as Test.IsInst. let rec BuildSwitch inpExprOpt g expr edges dflt m = - if verbose then dprintf "--> BuildSwitch@%a, #edges = %A, dflt.IsSome = %A\n" outputRange m (List.length edges) (Option.isSome dflt); + if verbose then dprintf "--> BuildSwitch@%a, #edges = %A, dflt.IsSome = %A\n" outputRange m (List.length edges) (Option.isSome dflt) match edges,dflt with | [], None -> failwith "internal error: no edges and no default" | [], Some dflt -> dflt (* NOTE: first time around, edges<>[] *) @@ -562,7 +562,6 @@ let rec BuildSwitch inpExprOpt g expr edges dflt m = | _ -> failwith "illtyped term during pattern compilation" let edges' = List.sortWith edgeCompare edges let rec compactify curr edges = - if debug then dprintf "--> compactify@%a\n" outputRange m; match curr,edges with | None,[] -> [] | Some last,[] -> [List.rev last] @@ -592,7 +591,7 @@ let rec BuildSwitch inpExprOpt g expr edges dflt m = // For a total pattern match, run the active pattern, bind the result and // recursively build a switch in the choice type | (TCase(Test.ActivePatternCase _,_)::_), _ -> - error(InternalError("Test.ActivePatternCase should have been eliminated",m)); + error(InternalError("Test.ActivePatternCase should have been eliminated",m)) // For a complete match, optimize one test to be the default | (TCase(_,tree)::rest), None -> TDSwitch (expr,rest,Some tree,m) @@ -602,7 +601,6 @@ let rec BuildSwitch inpExprOpt g expr edges dflt m = #if DEBUG let rec layoutPat pat = - if debug then dprintf "--> layoutPat\n"; match pat with | TPat_query (_,pat,_) -> Layout.(--) (Layout.wordL "query") (layoutPat pat) | TPat_wild _ -> Layout.wordL "wild" @@ -696,9 +694,9 @@ let CompilePatternBasic if warnOnIncomplete then match actionOnFailure with | ThrowIncompleteMatchException -> - warning (MatchIncomplete (false,ShowCounterExample g denv matchm refuted, matchm)); + warning (MatchIncomplete (false,ShowCounterExample g denv matchm refuted, matchm)) | IgnoreWithWarning -> - warning (MatchIncomplete (true,ShowCounterExample g denv matchm refuted, matchm)); + warning (MatchIncomplete (true,ShowCounterExample g denv matchm refuted, matchm)) | _ -> () @@ -722,8 +720,8 @@ let CompilePatternBasic | ThrowIncompleteMatchException -> mkThrow matchm resultTy (mkExnExpr(mk_MFCore_tcref g.fslibCcu "MatchFailureException", - [ mkString g matchm matchm.FileName; - mkInt g matchm matchm.StartLine; + [ mkString g matchm matchm.FileName + mkInt g matchm matchm.StartLine mkInt g matchm matchm.StartColumn],matchm)) | IgnoreWithWarning -> @@ -737,9 +735,9 @@ let CompilePatternBasic // will run the handler and hit the sequence point there. // That sequence point will have the pattern variables bound, which is exactly what we want. let tg = TTarget(FlatList.empty,throwExpr,SuppressSequencePointAtTarget ) - mbuilder.AddTarget tg |> ignore; + mbuilder.AddTarget tg |> ignore let clause = TClause(TPat_wild matchm,None,tg,matchm) - incompleteMatchClauseOnce := Some(clause); + incompleteMatchClauseOnce := Some(clause) clause | Some c -> c @@ -769,7 +767,6 @@ let CompilePatternBasic // The main recursive loop of the pattern match compiler let rec InvestigateFrontiers refuted frontiers = - if debug then dprintf "frontiers = %s\n" (String.concat ";" (List.map (getRuleIndex >> string) frontiers)); match frontiers with | [] -> failwith "CompilePattern:compile - empty clauses: at least the final clause should always succeed" | (Frontier (i,active,valMap)) :: rest -> @@ -779,7 +776,6 @@ let CompilePatternBasic | [] -> CompileSuccessPointAndGuard i refuted valMap rest | _ -> - if debug then dprintf "Investigating based on rule %d, #active = %d\n" i (List.length active); (* Otherwise choose a point (i.e. a path) to investigate. *) let (Active(path,subexpr,pat)) = ChooseInvestigationPointLeftToRight frontiers match pat with @@ -789,7 +785,6 @@ let CompilePatternBasic // Leaving the ones where we have real work to do | _ -> - if debug then dprintf "chooseSimultaneousEdgeSet\n"; let simulSetOfEdgeDiscrims,fallthroughPathFrontiers = ChooseSimultaneousEdges frontiers path let inpExprOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr @@ -797,13 +792,7 @@ let CompilePatternBasic // For each case, recursively compile the residue decision trees that result if that case successfully matches let simulSetOfCases, _ = CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims inpExprOpt - assert (nonNil(simulSetOfCases)); - - if debug then - dprintf "#fallthroughPathFrontiers = %d, #simulSetOfEdgeDiscrims = %d\n" (List.length fallthroughPathFrontiers) (List.length simulSetOfEdgeDiscrims); - dprintf "Making cases for each discriminator...\n"; - dprintf "#edges = %d\n" (List.length simulSetOfCases); - dprintf "Checking for completeness of edge set from earlier investigation of rule %d, #active = %d\n" i (List.length active); + assert (nonNil(simulSetOfCases)) // Work out what the default/fall-through tree looks like, is any // Check if match is complete, if so optimize the default case away. @@ -822,7 +811,6 @@ let CompilePatternBasic and CompileSuccessPointAndGuard i refuted valMap rest = - if debug then dprintf "generating success node for rule %d\n" i; let vs2 = GetValsBoundByClause i refuted let es2 = vs2 |> FlatList.map (fun v -> @@ -832,7 +820,6 @@ let CompilePatternBasic let rhs' = TDSuccess(es2, i) match GetWhenGuardOfClause i refuted with | Some whenExpr -> - if debug then dprintf "generating success node for rule %d, with 'when' clause\n" i; let m = whenExpr.Range @@ -856,16 +843,14 @@ let CompilePatternBasic /// Record the rule numbers so we know which rule the TPat_query cam from, so that when we project through /// the frontier we only project the right rule. and ChooseSimultaneousEdges frontiers path = - if debug then dprintf "chooseSimultaneousEdgeSet\n"; frontiers |> chooseSimultaneousEdgeSet None (fun prevOpt (Frontier (i',active',_)) -> if isMemOfActives path active' then let p = lookupActive path active' |> snd match getDiscrimOfPattern p with | Some discrim -> - if (match prevOpt with None -> true | Some (EdgeDiscrim(_,discrimPrev,_)) -> discrimsHaveSameSimultaneousClass g discrim discrimPrev) then ( - if debug then dprintf "taking rule %d\n" i'; + if (match prevOpt with None -> true | Some (EdgeDiscrim(_,discrimPrev,_)) -> discrimsHaveSameSimultaneousClass g discrim discrimPrev) then Some (EdgeDiscrim(i',discrim,p.Range)),true - ) else + else None,false | None -> @@ -892,7 +877,7 @@ let CompilePatternBasic let v,vexp = mkCompGenLocal m "typeTestResult" tgty if topv.IsMemberOrModuleBinding then - AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData let argexp = GetSubExprOfInput subexpr let appexp = mkIsInst tgty argexp matchm Some(vexp),Some(mkInvisibleBind v appexp) @@ -907,7 +892,7 @@ let CompilePatternBasic | None -> Some addrexp, None | Some (v,e) -> if topv.IsMemberOrModuleBinding then - AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData Some addrexp, Some (mkInvisibleBind v e) @@ -923,7 +908,7 @@ let CompilePatternBasic let ucaseTy = (mkProvenUnionCaseTy g.cons_ucref tinst) let v,vexp = mkCompGenLocal m "unionTestResult" ucaseTy if topv.IsMemberOrModuleBinding then - AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData let argexp = GetSubExprOfInput subexpr let appexp = mkIsInst ucaseTy argexp matchm Some vexp,Some (mkInvisibleBind v appexp) @@ -931,13 +916,12 @@ let CompilePatternBasic // Active pattern matches: create a variable to hold the results of executing the active pattern. | (EdgeDiscrim(_,(Test.ActivePatternCase(pexp,resTys,_,_,apinfo)),m) :: _) -> - if debug then dprintf "Building result var for active pattern...\n"; - if nonNil topgtvs then error(InternalError("Unexpected generalized type variables when compiling an active pattern",m)); + if nonNil topgtvs then error(InternalError("Unexpected generalized type variables when compiling an active pattern",m)) let rty = apinfo.ResultType g m resTys let v,vexp = mkCompGenLocal m "activePatternResult" rty if topv.IsMemberOrModuleBinding then - AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData let argexp = GetSubExprOfInput subexpr let appexp = mkApps g ((pexp,tyOfExpr g pexp), [], [argexp],m) @@ -990,7 +974,7 @@ let CompilePatternBasic let aparity = apinfo.Names.Length let total = apinfo.IsTotal if not total && aparity > 1 then - error(Error(FSComp.SR.patcPartialActivePatternsGenerateOneResult(),m)); + error(Error(FSComp.SR.patcPartialActivePatternsGenerateOneResult(),m)) if not total then Test.UnionCase(mkSomeCase g,resTys) elif aparity <= 1 then Test.Const(Const.Unit) @@ -1033,7 +1017,6 @@ let CompilePatternBasic (* Add to the refuted set *) let refuted = (RefutedInvestigation(path,simulSetOfDiscrims)) :: refuted - if debug then dprintf "Edge set was incomplete. Compiling remaining cases\n"; match fallthroughPathFrontiers with | [] -> None @@ -1043,11 +1026,9 @@ let CompilePatternBasic // Build a new frontier that represents the result of a successful investigation // at rule point (i',discrim,path) and GenerateNewFrontiersAfterSucccessfulInvestigation inpExprOpt resPostBindOpt (Investigation(i',discrim,path)) (Frontier (i, active,valMap) as frontier) = - if debug then dprintf "projecting success of investigation encompassing rule %d through rule %d \n" i' i; if (isMemOfActives path active) then let (SubExpr(accessf,ve)),pat = lookupActive path active - if debug then dprintf "active...\n"; let mkSubFrontiers path accessf' active' argpats pathBuilder = let mkSubActive j p = @@ -1273,7 +1254,6 @@ let rec CompilePattern g denv amap exprm matchm warnOnUnused actionOnFailure (t let warnOnIncomplete = false let rec atMostOnePartialAtATime clauses = - if debug then dprintf "atMostOnePartialAtATime: #clauses = %A\n" clauses; match List.takeUntil isPartialOrWhenClause clauses with | l,[] -> CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (topv,topgtvs) l inputTy resultTy @@ -1282,7 +1262,6 @@ let rec CompilePattern g denv amap exprm matchm warnOnUnused actionOnFailure (t doGroupWithAtMostOnePartial (l @ [h]) t and doGroupWithAtMostOnePartial group rest = - if debug then dprintf "doGroupWithAtMostOnePartial: #group = %A\n" group; // Compile the remaining clauses let dtree,targets = atMostOnePartialAtATime rest diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 9d9804fcad..5311156db0 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -133,11 +133,11 @@ type env = { boundTyparNames: string list boundTypars: TyparMap /// "module remap info", i.e. hiding information down the signature chain, used to compute what's hidden by a signature - sigToImplRemapInfo: (Remap * SignatureHidingInfo) list; + sigToImplRemapInfo: (Remap * SignatureHidingInfo) list /// Constructor limited - are we in the prelude of a constructor, prior to object initialization - limited: bool; + limited: bool /// Are we in a quotation? - quote : bool; + quote : bool /// Are we under []? reflect : bool } @@ -153,21 +153,21 @@ let BindTypars g env (tps:Typar list) = let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) env.boundTyparNames tps (tps,nms) ||> List.iter2 (fun tp nm -> if PrettyTypes.NeedsPrettyTyparName tp then - tp.Data.typar_id <- ident (nm,tp.Range)); + tp.Data.typar_id <- ident (nm,tp.Range)) List.fold BindTypar env tps type cenv = - { boundVals: Dictionary; // really a hash set - mutable potentialUnboundUsesOfVals: StampMap; - g: TcGlobals; - amap: Import.ImportMap; + { boundVals: Dictionary // really a hash set + mutable potentialUnboundUsesOfVals: StampMap + g: TcGlobals + amap: Import.ImportMap /// For reading metadata - infoReader: InfoReader; - internalsVisibleToPaths : CompilationPath list; - denv: DisplayEnv; - viewCcu : CcuThunk; - reportErrors: bool; - isLastCompiland : bool*bool; + infoReader: InfoReader + internalsVisibleToPaths : CompilationPath list + denv: DisplayEnv + viewCcu : CcuThunk + reportErrors: bool + isLastCompiland : bool*bool // outputs mutable usesQuotations : bool mutable entryPointGiven:bool } @@ -220,7 +220,7 @@ let rec CheckTypeDeep ((visitTyp,visitTyconRefOpt,visitByrefsOfByrefsOpt,visitTr match typ with | TType_forall (tps,body) -> let env = BindTypars g env tps - CheckTypeDeep f g env body; + CheckTypeDeep f g env body tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep f g env)) | TType_measure _ -> () @@ -261,9 +261,9 @@ and CheckTypeConstraintDeep f g env x = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> () and CheckTraitInfoDeep ((_,_,_,visitTraitSolutionOpt,_) as f) g env (TTrait(typs,_,_,argtys,rty,soln)) = - CheckTypesDeep f g env typs; - CheckTypesDeep f g env argtys; - Option.iter (CheckTypeDeep f g env) rty; + CheckTypesDeep f g env typs + CheckTypesDeep f g env argtys + Option.iter (CheckTypeDeep f g env) rty match visitTraitSolutionOpt, !soln with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () @@ -465,28 +465,28 @@ let rec CheckExpr (cenv:cenv) (env:env) expr = and CheckVal (cenv:cenv) (env:env) v m context = if cenv.reportErrors then - if is_splice cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)); - if is_splice cenv.g v then errorR(Error(FSComp.SR.chkNoFirstClassSplicing(), m)); - if valRefEq cenv.g v cenv.g.addrof_vref then errorR(Error(FSComp.SR.chkNoFirstClassAddressOf(), m)); - if valRefEq cenv.g v cenv.g.reraise_vref then errorR(Error(FSComp.SR.chkNoFirstClassRethrow(), m)); + if is_splice cenv.g v && not env.quote then errorR(Error(FSComp.SR.chkSplicingOnlyInQuotations(), m)) + if is_splice cenv.g v then errorR(Error(FSComp.SR.chkNoFirstClassSplicing(), m)) + if valRefEq cenv.g v cenv.g.addrof_vref then errorR(Error(FSComp.SR.chkNoFirstClassAddressOf(), m)) + if valRefEq cenv.g v cenv.g.reraise_vref then errorR(Error(FSComp.SR.chkNoFirstClassRethrow(), m)) if isByrefLikeTy cenv.g v.Type then // byref typed val can only occur in permitting contexts if context <> DirectArg then errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) CheckTypePermitByrefs cenv env m v.Type and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = - // dprintf "CheckExpr: %s\n" (showL(exprL expr)); + // dprintf "CheckExpr: %s\n" (showL(exprL expr)) let expr = stripExpr expr match expr with | Expr.Sequential (e1,e2,dir,_,_) -> - CheckExpr cenv env e1; + CheckExpr cenv env e1 match dir with | NormalSeq -> CheckExprInContext cenv env e2 context // carry context into _;RHS (normal sequencing only) | ThenDoSeq -> CheckExpr cenv {env with limited=false} e2 | Expr.Let (bind,body,_,_) -> - CheckBinding cenv env false bind ; + CheckBinding cenv env false bind BindVal cenv bind.Var CheckExprInContext cenv env body context @@ -500,12 +500,12 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = if (match vFlags with NormalValUse -> true | _ -> false) && v.IsConstructor && (match v.ActualParent with Parent tcref -> isAbstractTycon tcref.Deref | _ -> false) then - errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(),m)); + errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(),m)) CheckVal cenv env v m context | Expr.Quote(ast,savedConv,_isFromQueryExpression,m,ty) -> - CheckExpr cenv {env with quote=true} ast; + CheckExpr cenv {env with quote=true} ast if cenv.reportErrors then cenv.usesQuotations <- true try @@ -521,9 +521,9 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = CheckTypeNoByrefs cenv env m ty | Expr.Obj (_,typ,basev,superInitCall,overrides,iimpls,m) -> - CheckExpr cenv env superInitCall; - CheckMethods cenv env basev overrides ; - CheckInterfaceImpls cenv env basev iimpls; + CheckExpr cenv env superInitCall + CheckMethods cenv env basev overrides + CheckInterfaceImpls cenv env basev iimpls CheckTypePermitByrefs cenv env m typ let interfaces = [ if isInterfaceTy cenv.g typ then @@ -540,12 +540,12 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = // dprintfn "GOT BASE VAL USE" let memberInfo = Option.get v.MemberInfo if memberInfo.MemberFlags.IsDispatchSlot then - errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName),m)); + errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName),m)) else CheckVal cenv env v m GeneralContext CheckVal cenv env baseVal m GeneralContext - CheckTypePermitByrefs cenv env m fty; - CheckTypeInstPermitByrefs cenv env m tyargs; + CheckTypePermitByrefs cenv env m fty + CheckTypeInstPermitByrefs cenv env m tyargs CheckExprsInContext cenv env rest (argAritiesOfFunExpr f) // Allow base calls to IL methods @@ -562,13 +562,13 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = // equality. It would be better to make this check in tc.fs when we have the Abstract IL metadata for the method to hand. let mdef = resolveILMethodRef tcref.ILTyconRawMetadata mref if mdef.IsAbstract then - errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(mdef.Name),m)); + errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(mdef.Name),m)) with _ -> () // defensive coding | _ -> () - CheckTypeInstNoByrefs cenv env m tyargs; - CheckTypeInstNoByrefs cenv env m enclTypeArgs; - CheckTypeInstNoByrefs cenv env m methTypeArgs; - CheckTypeInstNoByrefs cenv env m tys; + CheckTypeInstNoByrefs cenv env m tyargs + CheckTypeInstNoByrefs cenv env m enclTypeArgs + CheckTypeInstNoByrefs cenv env m methTypeArgs + CheckTypeInstNoByrefs cenv env m tys CheckVal cenv env baseVal m GeneralContext CheckExprDirectArgs cenv env rest @@ -584,7 +584,7 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = // Allow '%expr' in quotations | Expr.App(Expr.Val(vref,_,_),_,tinst,[arg],m) when is_splice cenv.g vref && env.quote -> - CheckTypeInstPermitByrefs cenv env m tinst; + CheckTypeInstPermitByrefs cenv env m tinst CheckExpr cenv env arg @@ -621,10 +621,10 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = | _ -> () - CheckTypeInstNoByrefs cenv env m tyargs; - CheckTypePermitByrefs cenv env m fty; - CheckTypeInstPermitByrefs cenv env m tyargs; - CheckExpr cenv env f; + CheckTypeInstNoByrefs cenv env m tyargs + CheckTypePermitByrefs cenv env m fty + CheckTypeInstPermitByrefs cenv env m tyargs + CheckExpr cenv env f CheckExprsInContext cenv env argsl (argAritiesOfFunExpr f) (* REVIEW: fold the next two cases together *) @@ -692,31 +692,31 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = CheckExprs cenv env [e1;e2] | TOp.TryFinally _,[_],[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[_],e2,_,_)],_ -> - CheckTypeInstNoByrefs cenv env m tyargs; - limitedCheck(); + CheckTypeInstNoByrefs cenv env m tyargs + limitedCheck() CheckExprs cenv env [e1;e2] | TOp.For(_),_,[Expr.Lambda(_,_,_,[_],e1,_,_);Expr.Lambda(_,_,_,[_],e2,_,_);Expr.Lambda(_,_,_,[_],e3,_,_)],_ -> - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprs cenv env [e1;e2;e3] | TOp.TryCatch _,[_],[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[_],_e2,_,_); Expr.Lambda(_,_,_,[_],e3,_,_)],_ -> - CheckTypeInstNoByrefs cenv env m tyargs; - limitedCheck(); + CheckTypeInstNoByrefs cenv env m tyargs + limitedCheck() CheckExprs cenv env [e1;(* e2; -- don't check filter body - duplicates logic in 'catch' body *) e3] | TOp.ILCall (_,_,_,_,_,_,_,_,enclTypeArgs,methTypeArgs,tys),_,_,_ -> - CheckTypeInstNoByrefs cenv env m tyargs; - CheckTypeInstNoByrefs cenv env m enclTypeArgs; - CheckTypeInstNoByrefs cenv env m methTypeArgs; - CheckTypeInstNoByrefs cenv env m tys; + CheckTypeInstNoByrefs cenv env m tyargs + CheckTypeInstNoByrefs cenv env m enclTypeArgs + CheckTypeInstNoByrefs cenv env m methTypeArgs + CheckTypeInstNoByrefs cenv env m tys CheckExprDirectArgs cenv env args // Tuple expression in known tuple context | TOp.Tuple,_,_,KnownArityTuple nArity -> if cenv.reportErrors then if args.Length <> nArity then - errorR(InternalError("Tuple arity does not correspond to planned function argument arity",m)); + errorR(InternalError("Tuple arity does not correspond to planned function argument arity",m)) // This tuple should not be generated. The known function arity // means it just bundles arguments. CheckExprDirectArgs cenv env args @@ -728,16 +728,16 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = if cenv.reportErrors then errorR(Error(FSComp.SR.chkNoAddressOfAtThisPoint(v.DisplayName), m)) | TOp.ValFieldGet _rf,_,[arg1],_arity -> - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprDirectArgs cenv env [arg1] (* See mkRecdFieldGetViaExprAddr -- byref arg1 when #args =1 *) (* Property getters on mutable structs come through here. *) | TOp.ValFieldSet _rf,_,[arg1;arg2],_arity -> - CheckTypeInstNoByrefs cenv env m tyargs; - CheckExprDirectArgs cenv env [arg1]; (* See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 *) + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprDirectArgs cenv env [arg1] (* See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 *) CheckExprs cenv env [arg2] (* Property setters on mutable structs come through here (TBC). *) | TOp.Coerce,[_ty1;_ty2],[x],_arity -> - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprInContext cenv env x context | TOp.Reraise,[_ty1],[],_arity -> @@ -745,15 +745,15 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = | TOp.ValFieldGetAddr rfref,tyargs,[],_ -> if context <> DirectArg && cenv.reportErrors then - errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)); + errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)) CheckTypeInstNoByrefs cenv env m tyargs (* NOTE: there are no arg exprs to check in this case *) | TOp.ValFieldGetAddr rfref,tyargs,[rx],_ -> if context <> DirectArg && cenv.reportErrors then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)); + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)) (* This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. *) - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprInContext cenv env rx DirectArg (* allow rx to be byref here *) | TOp.UnionCaseFieldGet _,_,[arg1],_arity -> @@ -771,12 +771,12 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = CheckExprInContext cenv env rx DirectArg // allow rx to be byref here | TOp.ILAsm (instrs,tys),_,_,_ -> - CheckTypeInstPermitByrefs cenv env m tys; - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstPermitByrefs cenv env m tys + CheckTypeInstNoByrefs cenv env m tyargs begin match instrs,args with | [ I_stfld (_alignment,_vol,_fspec) ],[lhs;rhs] -> - CheckExprInContext cenv env lhs DirectArg; (* permit byref for lhs lvalue *) + CheckExprInContext cenv env lhs DirectArg (* permit byref for lhs lvalue *) CheckExpr cenv env rhs | [ I_ldfld (_alignment,_vol,_fspec) ],[lhs] -> CheckExprInContext cenv env lhs DirectArg (* permit byref for lhs lvalue *) @@ -784,11 +784,11 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = CheckExprInContext cenv env lhs DirectArg (* permit byref for lhs lvalue of readonly value *) | [ I_ldflda (fspec) | I_ldsflda (fspec) ],[lhs] -> if context <> DirectArg && cenv.reportErrors then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(fspec.Name), m)); + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(fspec.Name), m)) CheckExprInContext cenv env lhs DirectArg (* permit byref for lhs lvalue *) | [ I_ldelema (_,isNativePtr,_,_) ],lhsArray::indices -> if not(isNativePtr) && context <> DirectArg && cenv.reportErrors then - errorR(Error(FSComp.SR.chkNoAddressOfArrayElementAtThisPoint(), m)); + errorR(Error(FSComp.SR.chkNoAddressOfArrayElementAtThisPoint(), m)) CheckExprInContext cenv env lhsArray DirectArg (* permit byref for lhs lvalue *) CheckExprs cenv env indices | [ AI_conv _ ],_ -> @@ -798,7 +798,7 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = end | TOp.TraitCall _,_,_,_ -> - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprDirectArgs cenv env args (* allow args to be byref here *) | ( TOp.Tuple @@ -819,7 +819,7 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = | TOp.RefAddrGet | _ (* catch all! *) ),_,_,_ -> - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprs cenv env args and CheckLambdas (memInfo: ValMemberInfo option) cenv env inlined topValInfo alwaysCheckNoReraise e m ety = @@ -851,18 +851,18 @@ and CheckLambdas (memInfo: ValMemberInfo option) cenv env inlined topValInfo alw // any byRef arguments are considered used, as they may be 'out's restArgs |> List.iter (fun arg -> if isByrefTy cenv.g arg.Type then arg.SetHasBeenReferenced()) - syntacticArgs |> List.iter (CheckValSpec cenv env); - syntacticArgs |> List.iter (BindVal cenv); + syntacticArgs |> List.iter (CheckValSpec cenv env) + syntacticArgs |> List.iter (BindVal cenv) // Allow access to protected things within members match memInfo with | None -> () | Some membInfo -> - testHookMemberBody membInfo body; + testHookMemberBody membInfo body - let freesOpt = CheckEscapes cenv (isSome(memInfo)) m syntacticArgs body; - CheckNoReraise cenv freesOpt body; (* no reraise under lambda expression *) - CheckExpr cenv env body; + let freesOpt = CheckEscapes cenv (isSome(memInfo)) m syntacticArgs body + CheckNoReraise cenv freesOpt body (* no reraise under lambda expression *) + CheckExpr cenv env body if cenv.reportErrors then if not inlined then CheckForByrefLikeType cenv env bodyty (fun () -> @@ -875,13 +875,13 @@ and CheckLambdas (memInfo: ValMemberInfo option) cenv env inlined topValInfo alw errorR(Error(FSComp.SR.chkTyparMultipleClassConstraints(), m)) | _ -> - CheckTypePermitByrefs cenv env m ety; + CheckTypePermitByrefs cenv env m ety if not inlined && isByrefLikeTy cenv.g ety then CheckExprInContext cenv env e DirectArg (* allow byref to occur as RHS of byref binding. *) else CheckExpr cenv env e if alwaysCheckNoReraise then - CheckNoReraise cenv None e; (* no reraise *) + CheckNoReraise cenv None e (* no reraise *) and CheckExprsInContext cenv env exprs arities = let arities = Array.ofList arities @@ -907,7 +907,7 @@ and CheckDecisionTreeTarget cenv env context (TTarget(vs,e,_)) = and CheckDecisionTree cenv env x = match x with - | TDSuccess (es,_) -> CheckFlatExprs cenv env es; + | TDSuccess (es,_) -> CheckFlatExprs cenv env es | TDBind(bind,rest) -> CheckBinding cenv env false bind; CheckDecisionTree cenv env rest | TDSwitch (e,cases,dflt,m) -> CheckDecisionTreeSwitch cenv env (e,cases,dflt,m) @@ -926,13 +926,13 @@ and CheckDecisionTreeTest cenv env m discrim = | Test.ActivePatternCase (exp,_,_,_,_) -> CheckExpr cenv env exp and CheckAttrib cenv env (Attrib(_,_,args,props,_,_,_)) = - props |> List.iter (fun (AttribNamedArg(_,_,_,expr)) -> CheckAttribExpr cenv env expr); + props |> List.iter (fun (AttribNamedArg(_,_,_,expr)) -> CheckAttribExpr cenv env expr) args |> List.iter (CheckAttribExpr cenv env) and CheckAttribExpr cenv env (AttribExpr(expr,vexpr)) = - CheckExpr cenv env expr; - CheckExpr cenv env vexpr; - CheckNoReraise cenv None expr; + CheckExpr cenv env expr + CheckExpr cenv env vexpr + CheckNoReraise cenv None expr CheckAttribArgExpr cenv env vexpr and CheckAttribArgExpr cenv env expr = @@ -971,7 +971,7 @@ and CheckAttribArgExpr cenv env expr = | EnumExpr cenv.g arg1 -> CheckAttribArgExpr cenv env arg1 | AttribBitwiseOrExpr cenv.g (arg1,arg2) -> - CheckAttribArgExpr cenv env arg1; + CheckAttribArgExpr cenv env arg1 CheckAttribArgExpr cenv env arg2 | _ -> if cenv.reportErrors then @@ -998,15 +998,15 @@ and CheckAttribs cenv env (attribs: Attribs) = attribs |> List.iter (CheckAttrib cenv env) and CheckValInfo cenv env (ValReprInfo(_,args,ret)) = - args |> List.iterSquared (CheckArgInfo cenv env); - ret |> CheckArgInfo cenv env; + args |> List.iterSquared (CheckArgInfo cenv env) + ret |> CheckArgInfo cenv env and CheckArgInfo cenv env (argInfo : ArgReprInfo) = CheckAttribs cenv env argInfo.Attribs and CheckValSpec cenv env (v:Val) = - v.Attribs |> CheckAttribs cenv env; - v.ValReprInfo |> Option.iter (CheckValInfo cenv env); + v.Attribs |> CheckAttribs cenv env + v.ValReprInfo |> Option.iter (CheckValInfo cenv env) v.Type |> CheckTypePermitByrefs cenv env v.Range and AdjustAccess isHidden (cpath: unit -> CompilationPath) access = @@ -1032,9 +1032,9 @@ and CheckBinding cenv env alwaysCheckNoReraise (TBind(v,e,_) as bind) = let nm = v.DisplayName errorR(Error(FSComp.SR.chkMemberUsedInInvalidWay(nm, nm, stringOfRange m), v.Range)) - v.Type |> CheckTypePermitByrefs cenv env v.Range; - v.Attribs |> CheckAttribs cenv env; - v.ValReprInfo |> Option.iter (CheckValInfo cenv env); + v.Type |> CheckTypePermitByrefs cenv env v.Range + v.Attribs |> CheckAttribs cenv env + v.ValReprInfo |> Option.iter (CheckValInfo cenv env) if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then let access = AdjustAccess (IsHiddenVal env.sigToImplRemapInfo v) (fun () -> v.TopValActualParent.CompilationPath) v.Accessibility CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv v) access v.Range v.Type @@ -1043,7 +1043,7 @@ and CheckBinding cenv env alwaysCheckNoReraise (TBind(v,e,_) as bind) = if cenv.reportErrors then if isByrefLikeTy cenv.g v.Type && isSome bind.Var.ValReprInfo then - errorR(Error(FSComp.SR.chkNoByrefAsTopValue(), v.Range)); + errorR(Error(FSComp.SR.chkNoByrefAsTopValue(), v.Range)) // Check top-level let-bound values (arity=0 so not compiled not method) for byref types (not allowed) match bind.Var.ValReprInfo with @@ -1113,7 +1113,7 @@ and CheckBinding cenv env alwaysCheckNoReraise (TBind(v,e,_) as bind) = let inlined = v.MustInline // certain inline functions are permitted to have byref return types // e.g. for the byref operator itself, &. - CheckLambdas v.MemberInfo cenv env inlined topValInfo alwaysCheckNoReraise e v.Range v.Type; + CheckLambdas v.MemberInfo cenv env inlined topValInfo alwaysCheckNoReraise e v.Range v.Type and CheckBindings cenv env xs = FlatList.iter (CheckBinding cenv env false) xs @@ -1121,7 +1121,7 @@ and CheckBindings cenv env xs = FlatList.iter (CheckBinding cenv env false) xs let CheckModuleBinding cenv env (TBind(v,e,_) as bind) = let isExplicitEntryPoint = HasFSharpAttribute cenv.g cenv.g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then - cenv.entryPointGiven <- true; + cenv.entryPointGiven <- true let isLastCompiland = fst cenv.isLastCompiland if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) @@ -1166,20 +1166,20 @@ let CheckModuleBinding cenv env (TBind(v,e,_) as bind) = tcref.ModuleOrNamespaceType.AllValsByLogicalName.ContainsKey(nm) && not (valEq tcref.ModuleOrNamespaceType.AllValsByLogicalName.[nm] v) then - error(Duplicate(kind,v.DisplayName,v.Range)); + error(Duplicate(kind,v.DisplayName,v.Range)) #if CASES_IN_NESTED_CLASS if tcref.IsUnionTycon && nm = "Cases" then - errorR(NameClash(nm,kind,v.DisplayName,v.Range, "generated type","Cases",tcref.Range)); + errorR(NameClash(nm,kind,v.DisplayName,v.Range, "generated type","Cases",tcref.Range)) #endif if tcref.IsUnionTycon then match nm with - | "Tag" -> errorR(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedProperty(),"Tag",tcref.Range)); - | "Tags" -> errorR(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedType(),"Tags",tcref.Range)); + | "Tag" -> errorR(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedProperty(),"Tag",tcref.Range)) + | "Tags" -> errorR(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedType(),"Tags",tcref.Range)) | _ -> if hasDefaultAugmentation then match tcref.GetUnionCaseByName(nm) with - | Some(uc) -> error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoUnionCase(),uc.DisplayName,uc.Range)); + | Some(uc) -> error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoUnionCase(),uc.DisplayName,uc.Range)) | None -> () let hasNoArgs = @@ -1191,24 +1191,24 @@ let CheckModuleBinding cenv env (TBind(v,e,_) as bind) = if tcref.UnionCasesArray.Length = 1 && hasNoArgs then let ucase1 = tcref.UnionCasesArray.[0] for f in ucase1.RecdFieldsArray do - if f.Name = nm then error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedProperty(),f.Name,ucase1.Range)); + if f.Name = nm then error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.typeInfoGeneratedProperty(),f.Name,ucase1.Range)) // Default augmentation contains the nasty 'Case' etc. let prefix = "New" if nm.StartsWith prefix then match tcref.GetUnionCaseByName(nm.[prefix.Length ..]) with - | Some(uc) -> error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.chkUnionCaseCompiledForm(),uc.DisplayName,uc.Range)); + | Some(uc) -> error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.chkUnionCaseCompiledForm(),uc.DisplayName,uc.Range)) | None -> () // Default augmentation contains the nasty 'Is' etc. let prefix = "Is" if nm.StartsWith prefix && hasDefaultAugmentation then match tcref.GetUnionCaseByName(nm.[prefix.Length ..]) with - | Some(uc) -> error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(),uc.DisplayName,uc.Range)); + | Some(uc) -> error(NameClash(nm,kind,v.DisplayName,v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(),uc.DisplayName,uc.Range)) | None -> () match tcref.GetFieldByName(nm) with - | Some(rf) -> error(NameClash(nm,kind,v.DisplayName,v.Range,"field",rf.Name,rf.Range)); + | Some(rf) -> error(NameClash(nm,kind,v.DisplayName,v.Range,"field",rf.Name,rf.Range)) | None -> () check false v.CoreDisplayName @@ -1238,7 +1238,7 @@ let CheckModuleBinding cenv env (TBind(v,e,_) as bind) = match TryChopPropertyName v.DisplayName with | Some res -> check true res | None -> () - with e -> errorRecovery e v.Range; + with e -> errorRecovery e v.Range end CheckBinding cenv env true bind @@ -1255,10 +1255,10 @@ let CheckRecdField isUnion cenv env (tycon:Tycon) (rfield:RecdField) = IsHiddenTyconRepr env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo ((mkLocalTyconRef tycon).MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility - CheckTypeForAccess cenv env (fun () -> rfield.Name) access rfield.Range rfield.FormalType; - CheckTypePermitByrefs cenv env rfield.Range rfield.FormalType; - CheckAttribs cenv env rfield.PropertyAttribs; - CheckAttribs cenv env rfield.FieldAttribs; + CheckTypeForAccess cenv env (fun () -> rfield.Name) access rfield.Range rfield.FormalType + CheckTypePermitByrefs cenv env rfield.Range rfield.FormalType + CheckAttribs cenv env rfield.PropertyAttribs + CheckAttribs cenv env rfield.FieldAttribs if cenv.reportErrors then CheckForByrefLikeType cenv env rfield.FormalType (fun () -> errorR(Error(FSComp.SR.chkCantStoreByrefValue(), tycon.Range))) @@ -1269,7 +1269,7 @@ let CheckEntityDefn cenv env (tycon:Entity) = let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute tycon.Attribs } let m = tycon.Range let env = BindTypars cenv.g env (tycon.Typars(m)) - CheckAttribs cenv env tycon.Attribs; + CheckAttribs cenv env tycon.Attribs if cenv.reportErrors then begin if not tycon.IsTypeAbbrev then @@ -1457,23 +1457,23 @@ let CheckEntityDefn cenv env (tycon:Entity) = else errorR(Error(FSComp.SR.chkDuplicateMethodInheritedTypeWithSuffix(nm),m)) - end; + end // Considers TFSharpObjectRepr, TRecdRepr and TUnionRepr. // [Review] are all cases covered: TILObjectRepr,TAsmRepr. [Yes - these are FSharp.Core.dll only] - tycon.AllFieldsArray |> Array.iter (CheckRecdField false cenv env tycon); - abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> CheckTypePermitByrefs cenv env m); (* check vslots = abstract slots *) - tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypePermitByrefs cenv env m); (* check implemented interface types *) - superOfTycon cenv.g tycon |> CheckTypePermitByrefs cenv env m; (* check super type *) + tycon.AllFieldsArray |> Array.iter (CheckRecdField false cenv env tycon) + abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> CheckTypePermitByrefs cenv env m) (* check vslots = abstract slots *) + tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypePermitByrefs cenv env m) (* check implemented interface types *) + superOfTycon cenv.g tycon |> CheckTypePermitByrefs cenv env m (* check super type *) if tycon.IsUnionTycon then (* This covers finite unions. *) tycon.UnionCasesAsList |> List.iter (fun uc -> - CheckAttribs cenv env uc.Attribs; + CheckAttribs cenv env uc.Attribs uc.RecdFields |> List.iter (CheckRecdField true cenv env tycon)) let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty - abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType); (* check vslots = abstract slots *) + abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) (* check vslots = abstract slots *) superOfTycon cenv.g tycon |> visitType // We do not have to check access of interface implementations. See FSharp 1.0 5042 //implements_of_tycon cenv.g tycon |> List.iter visitType @@ -1484,7 +1484,7 @@ let CheckEntityDefn cenv env (tycon:Entity) = | TTyconDelegate ss -> //ss.ClassTypars //ss.MethodTypars - ss.FormalReturnType |> Option.iter visitType; + ss.FormalReturnType |> Option.iter visitType ss.FormalParams |> List.iterSquared (fun (TSlotParam(_,ty,_,_,_,_)) -> visitType ty) | _ -> () | _ -> () @@ -1514,7 +1514,7 @@ let CheckEntityDefn cenv env (tycon:Entity) = if zeroInitUnsafe = Some(true) then let ty' = generalizedTyconRef (mkLocalTyconRef tycon) if not (TypeHasDefaultValue cenv.g m ty') then - errorR(Error(FSComp.SR.chkValueWithDefaultValueMustHaveDefaultValue(), m)); + errorR(Error(FSComp.SR.chkValueWithDefaultValueMustHaveDefaultValue(), m)) ) match tycon.TypeAbbrev with (* And type abbreviations *) | None -> () @@ -1555,7 +1555,7 @@ and CheckDefnInModule cenv env x = BindVal cenv bind.Var | TMDefDo(e,m) -> CheckNothingAfterEntryPoint cenv m - CheckNoReraise cenv None e; + CheckNoReraise cenv None e CheckExpr cenv env e | TMAbstract(def) -> CheckModuleExpr cenv env def | TMDefs(defs) -> CheckDefnsInModule cenv env defs @@ -1566,23 +1566,23 @@ and CheckModuleSpec cenv env x = BindVals cenv (valsOfBinds [bind]) CheckModuleBinding cenv env bind | ModuleOrNamespaceBinding.Module (mspec, rhs) -> - CheckEntityDefn cenv env mspec; + CheckEntityDefn cenv env mspec let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } CheckDefnInModule cenv env rhs let CheckTopImpl (g,amap,reportErrors,infoReader,internalsVisibleToPaths,viewCcu,denv ,mexpr,extraAttribs,(isLastCompiland:bool*bool)) = let cenv = - { g =g ; - reportErrors=reportErrors; - boundVals= new Dictionary<_,_>(100, HashIdentity.Structural); - potentialUnboundUsesOfVals=Map.empty; - usesQuotations=false; - infoReader=infoReader; - internalsVisibleToPaths=internalsVisibleToPaths; - amap=amap; - denv=denv; - viewCcu= viewCcu; - isLastCompiland=isLastCompiland; + { g =g + reportErrors=reportErrors + boundVals= new Dictionary<_,_>(100, HashIdentity.Structural) + potentialUnboundUsesOfVals=Map.empty + usesQuotations=false + infoReader=infoReader + internalsVisibleToPaths=internalsVisibleToPaths + amap=amap + denv=denv + viewCcu= viewCcu + isLastCompiland=isLastCompiland entryPointGiven=false} // Certain type equality checks go faster if these TyconRefs are pre-resolved. @@ -1604,8 +1604,8 @@ let CheckTopImpl (g,amap,reportErrors,infoReader,internalsVisibleToPaths,viewCcu boundTypars= TyparMap.Empty reflect=false } - CheckModuleExpr cenv env mexpr; - CheckAttribs cenv env extraAttribs; + CheckModuleExpr cenv env mexpr + CheckAttribs cenv env extraAttribs if cenv.usesQuotations && QuotationTranslator.QuotationGenerationScope.ComputeQuotationFormat(cenv.g) = QuotationTranslator.QuotationSerializationFormat.FSharp_20_Plus then viewCcu.UsesFSharp20PlusQuotations <- true cenv.entryPointGiven diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 3361b5ec54..8b1dd7e188 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -38,9 +38,9 @@ type QuotationSerializationFormat = | FSharp_20_Plus type QuotationGenerationScope = - { g: TcGlobals; - amap: Import.ImportMap; - scope: CcuThunk; + { g: TcGlobals + amap: Import.ImportMap + scope: CcuThunk // Accumulate the references to type definitions referencedTypeDefs: ResizeArray referencedTypeDefsTable: Dictionary @@ -78,10 +78,10 @@ type QuotationGenerationScope = type QuotationTranslationEnv = { //Map from Val to binding index - vs: ValMap; - nvs: int; + vs: ValMap + nvs: int //Map from typar stamps to binding index - tyvs: StampMap; + tyvs: StampMap // Map for values bound by the // 'let v = isinst e in .... if nonnull v then ...v .... ' // construct arising out the compilation of pattern matching. We decode these back to the form @@ -90,9 +90,9 @@ type QuotationTranslationEnv = substVals: ValMap } static member Empty = - { vs=ValMap<_>.Empty; - nvs=0; - tyvs = Map.empty ; + { vs=ValMap<_>.Empty + nvs=0 + tyvs = Map.empty isinstVals = ValMap<_>.Empty substVals = ValMap<_>.Empty } @@ -182,11 +182,11 @@ let rec EmitDebugInfoIfNecessary cenv env m astExpr : QP.ExprData = let rangeExpr = mk_tuple cenv.g m - [ mkString cenv.g m m.FileName; - mkInt cenv.g m m.StartLine; - mkInt cenv.g m m.StartColumn; - mkInt cenv.g m m.EndLine; - mkInt cenv.g m m.EndColumn; ] + [ mkString cenv.g m m.FileName + mkInt cenv.g m m.StartLine + mkInt cenv.g m m.StartColumn + mkInt cenv.g m m.EndLine + mkInt cenv.g m m.EndColumn; ] let attrExpr = mk_tuple cenv.g m [ mkString cenv.g m "DebugRange"; rangeExpr ] @@ -224,7 +224,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. match (freeInExpr CollectTyparsAndLocalsNoCaching x0).FreeLocals |> Seq.tryPick (fun v -> if env.vs.ContainsVal v then Some(v) else None) with | Some v -> errorR(Error(FSComp.SR.crefBoundVarUsedInSplice(v.DisplayName), v.Range)) | None -> () - cenv.exprSplices.Add((x0, m)); + cenv.exprSplices.Add((x0, m)) let hole = QP.mkHole(ConvType cenv env m ty,idx) (hole, rest) ||> List.fold (fun fR arg -> QP.mkApp (fR,ConvExpr cenv env arg)) @@ -345,7 +345,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. // Simple applications | Expr.App(f,_fty,tyargs,args,m) -> - if nonNil tyargs then wfail(Error(FSComp.SR.crefQuotationsCantContainGenericExprs(), m)); + if nonNil tyargs then wfail(Error(FSComp.SR.crefQuotationsCantContainGenericExprs(), m)) List.fold (fun fR arg -> QP.mkApp (fR,ConvExpr cenv env arg)) (ConvExpr cenv env f) args // REVIEW: what is the quotation view of literals accessing enumerations? Currently they show up as integers. @@ -478,8 +478,8 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. let methArgTypesR = ConvTypes cenv env m argtys let argsR = ConvExprs cenv env args let objR = - QP.mkCtorCall( { ctorParent = parentTyconR; - ctorArgTypes = methArgTypesR }, + QP.mkCtorCall( { ctorParent = parentTyconR + ctorArgTypes = methArgTypesR }, [], argsR) let exnTypeR = ConvType cenv env m cenv.g.exn_ty QP.mkCoerce(exnTypeR, objR) @@ -687,17 +687,19 @@ and ConvObjectModelCallCore cenv env m (isPropGet,isPropSet,isNewObj,parentTycon QP.mkPropSet( (parentTyconR, propName,propTy,args),tyargsR, callArgsR) elif isNewObj then - QP.mkCtorCall( { ctorParent = parentTyconR; - ctorArgTypes = methArgTypesR }, - tyargsR, callArgsR) + let ctorR : QuotationPickler.CtorData = + { ctorParent = parentTyconR + ctorArgTypes = methArgTypesR } + QP.mkCtorCall(ctorR, tyargsR, callArgsR) else - QP.mkMethodCall( { methParent = parentTyconR; - methArgTypes = methArgTypesR; - methRetType = methRetTypeR; - methName = methName; - numGenericArgs=numGenericArgs }, - tyargsR, callArgsR) + let methR : QuotationPickler.MethodData = + { methParent = parentTyconR + methArgTypes = methArgTypesR + methRetType = methRetTypeR + methName = methName + numGenericArgs=numGenericArgs } + QP.mkMethodCall(methR, tyargsR, callArgsR) and ConvModuleValueApp cenv env m (vref:ValRef) tyargs (args: Expr list list) = EmitDebugInfoIfNecessary cenv env m (ConvModuleValueAppCore cenv env m vref tyargs args) @@ -727,7 +729,7 @@ and private ConvValRefCore holeOk cenv env m (vref:ValRef) tyargs = let e = env.substVals.[v] ConvExpr cenv env e elif env.vs.ContainsVal v then - if nonNil tyargs then wfail(InternalError("ignoring generic application of local quoted variable",m)); + if nonNil tyargs then wfail(InternalError("ignoring generic application of local quoted variable",m)) QP.mkVar(env.vs.[v]) elif v.BaseOrThisInfo = CtorThisVal && cenv.isReflectedDefinition = IsReflectedDefinition.Yes then QP.mkThisVar(ConvType cenv env m v.Type) @@ -738,7 +740,7 @@ and private ConvValRefCore holeOk cenv env m (vref:ValRef) tyargs = // References to local values are embedded by value if not holeOk then wfail(Error(FSComp.SR.crefNoSetOfHole(),m)) let idx = cenv.exprSplices.Count - cenv.exprSplices.Add((mkCallLiftValueWithName cenv.g m vty v.LogicalName (exprForValRef m vref), m)); + cenv.exprSplices.Add((mkCallLiftValueWithName cenv.g m vty v.LogicalName (exprForValRef m vref), m)) QP.mkHole(ConvType cenv env m vty,idx) | Parent _ -> ConvModuleValueApp cenv env m vref tyargs [] @@ -772,7 +774,7 @@ and ConvTyparRef cenv env m (tp:Typar) = | Some idx -> idx | None -> let idx = cenv.typeSplices.Count - cenv.typeSplices.Add((tp, m)); + cenv.typeSplices.Add((tp, m)) idx and FilterMeasureTyargs tys = @@ -1022,14 +1024,14 @@ let ConvMethodBase cenv env (methName, v:Val) = if isNewObj then QP.MethodBaseData.Ctor - { ctorParent = parentTyconR; + { ctorParent = parentTyconR ctorArgTypes = methArgTypesR } else QP.MethodBaseData.Method - { methParent = parentTyconR; - methArgTypes = methArgTypesR; - methRetType = methRetTypeR; - methName = methName; + { methParent = parentTyconR + methArgTypes = methArgTypesR + methRetType = methRetTypeR + methName = methName numGenericArgs=numGenericArgs } | _ when v.IsExtensionMember -> @@ -1050,8 +1052,8 @@ let ConvMethodBase cenv env (methName, v:Val) = | _ -> QP.MethodBaseData.ModuleDefn - { Name = methName; - Module = parentTyconR; + { Name = methName + Module = parentTyconR IsProperty = IsCompiledAsStaticProperty cenv.g v } diff --git a/src/fsharp/TraceCall.fs b/src/fsharp/TraceCall.fs deleted file mode 100644 index db24974fec..0000000000 --- a/src/fsharp/TraceCall.fs +++ /dev/null @@ -1,172 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. - -namespace Internal.Utilities.Debug - -open System -open System.IO -open System.Threading -open System.Diagnostics -open System.Runtime.InteropServices - - -module internal TraceInterop = - type MessageBeepType = - | Default = -1 - | Ok = 0x00000000 - | Error = 0x00000010 - | Question = 0x00000020 - | Warning = 0x00000030 - | Information = 0x00000040 - - [] - let MessageBeep(_mbt:MessageBeepType):bool=failwith "" - -[] -[] -type internal Trace private() = - static let mutable log = "" -#if DEBUG_WITH_TIME_AND_THREAD_INFO - static let TMinusZero = DateTime.Now -#endif - static let noopDisposable = - { new IDisposable with - member this.Dispose() = () - } - static let mutable out = Console.Out - [] [] static val mutable private indent:int - [] [] static val mutable private threadName:string - - /// Set to the semicolon-delimited names of the logging classes to be reported. - /// Use * to mean all. - static member Log - with get() = log - and set(value) = log<-value - - /// Output destination. - static member Out - with get() = out - and set(value:TextWriter) = out<-value - - /// True if the given logging class should be logged. - static member ShouldLog(loggingClass) = - let result = Trace.Log = "*" || Trace.Log.Contains(loggingClass^";") || Trace.Log.EndsWith(loggingClass,StringComparison.Ordinal) - result - - /// Description of the current thread. - static member private CurrentThreadInfo() = - if String.IsNullOrEmpty(Trace.threadName) then sprintf "(id=%d)" Thread.CurrentThread.ManagedThreadId - else sprintf "(id=%d,name=%s)" Thread.CurrentThread.ManagedThreadId Trace.threadName - - /// Report the elapsed time since start. - static member private ElapsedTime(start) = - let elapsed : TimeSpan = (DateTime.Now-start) - sprintf "%A ms" elapsed.TotalMilliseconds - - /// Get a string with spaces for indention. - static member private IndentSpaces() = new string(' ', Trace.indent) - - /// Log a message. - static member private LogMessage(msg:string) = - Trace.Out.Write(sprintf "%s%s" (Trace.IndentSpaces()) msg) - Trace.Out.Flush() - if Trace.Out<>Console.Out then - // Always log to console. - Console.Out.Write(sprintf "%s%s" (Trace.IndentSpaces()) msg) - - /// Name the current thread. - static member private NameCurrentThread(threadName) = - match threadName with - | Some(threadName)-> - let current = Trace.threadName - if String.IsNullOrEmpty(current) then Trace.threadName <- threadName - else if not(current.Contains(threadName)) then Trace.threadName <- current^","^threadName - | None -> () - - /// Base implementation of the call function. - static member private CallImpl(loggingClass,functionName,descriptionFunc,threadName:string option) : IDisposable = - #if DEBUG - if Trace.ShouldLog(loggingClass) then - Trace.NameCurrentThread(threadName) - - let description = try descriptionFunc() with e->"No description because of exception" - -#if DEBUG_WITH_TIME_AND_THREAD_INFO - let threadInfo = Trace.CurrentThreadInfo() - let indent = Trace.IndentSpaces() - let start = DateTime.Now - Trace.LogMessage(sprintf "Entering %s(%s) %s t-plus %fms %s\n" - functionName - loggingClass - threadInfo - (start-TMinusZero).TotalMilliseconds - description) -#else - Trace.LogMessage(sprintf "Entering %s(%s) %s\n" - functionName - loggingClass - description) -#endif - Trace.indent<-Trace.indent+1 - - {new IDisposable with - member d.Dispose() = - Trace.indent<-Trace.indent-1 -#if DEBUG_WITH_TIME_AND_THREAD_INFO - Trace.LogMessage(sprintf "Exitting %s %s %s\n" - functionName - threadInfo - (Trace.ElapsedTime(start)))} -#else - Trace.LogMessage(sprintf "Exiting %s\n" - functionName)} -#endif - else - noopDisposable : IDisposable - #else - ignore(loggingClass,functionName,descriptionFunc,threadName) - noopDisposable : IDisposable - #endif - - /// Log a method as it's called. - static member Call(loggingClass:string,functionName:string,descriptionFunc:unit->string) = Trace.CallImpl(loggingClass,functionName,descriptionFunc,None) - /// Log a method as it's called. Expected always to be called on the same thread which will be named 'threadName'. - static member CallByThreadNamed(loggingClass:string,functionName:string,threadName:string,descriptionFunc:unit->string) = Trace.CallImpl(loggingClass,functionName,descriptionFunc,Some(threadName)) - /// Log a message by logging class. - static member PrintLine(loggingClass:string, messageFunc:unit->string) = - #if DEBUG - if Trace.ShouldLog(loggingClass) then - let message = try messageFunc() with _-> "No message because of exception.\n" - Trace.LogMessage(sprintf "%s%s" message System.Environment.NewLine) - #else - ignore(loggingClass,messageFunc) - #endif - - /// Log a message by logging class. - static member Print(loggingClass:string, messageFunc:unit->string) = - #if DEBUG - if Trace.ShouldLog(loggingClass) then - let message = try messageFunc() with _-> "No message because of exception.\n" - Trace.LogMessage(message) - #else - ignore(loggingClass,messageFunc) - #endif - - /// Make a beep when the given loggingClass is matched. - static member private BeepHelper(loggingClass,beeptype) = - #if DEBUG - if Trace.ShouldLog(loggingClass) then - TraceInterop.MessageBeep(beeptype) |> ignore - #else - ignore(loggingClass,beeptype) - #endif - - /// Make the "OK" sound when the given loggingClass is matched. - static member BeepOk(loggingClass:string) = Trace.BeepHelper(loggingClass,TraceInterop.MessageBeepType.Ok) - - /// Make the "Error" sound when the given loggingClass is matched. - static member BeepError(loggingClass:string) = Trace.BeepHelper(loggingClass,TraceInterop.MessageBeepType.Error) - - /// Make the default sound when the given loggingClass is matched. - static member Beep(loggingClass:string) = Trace.BeepHelper(loggingClass,TraceInterop.MessageBeepType.Default) - - diff --git a/src/fsharp/TraceCall.fsi b/src/fsharp/TraceCall.fsi deleted file mode 100644 index 609d1d1bb0..0000000000 --- a/src/fsharp/TraceCall.fsi +++ /dev/null @@ -1,25 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. - -namespace Internal.Utilities.Debug - module internal TraceInterop = - type MessageBeepType = - | Default = -1 - | Ok = 0 - | Error = 16 - | Question = 32 - | Warning = 48 - | Information = 64 - val MessageBeep : MessageBeepType -> bool - [] - type internal Trace = - static member Beep : loggingClass:string -> unit - static member BeepError : loggingClass:string -> unit - static member BeepOk : loggingClass:string -> unit - static member Call : loggingClass:string * functionName:string * descriptionFunc:(unit->string) -> System.IDisposable - static member CallByThreadNamed : loggingClass:string * functionName:string * threadName:string * descriptionFunc:(unit->string) -> System.IDisposable - static member Print : loggingClass:string * messageFunc:(unit->string) -> unit - static member PrintLine : loggingClass:string * messageFunc:(unit->string) -> unit - static member ShouldLog : loggingClass:string -> bool - static member Log : string with get, set - static member Out : System.IO.TextWriter with get, set - diff --git a/src/fsharp/vs/IncrementalBuild.fs b/src/fsharp/vs/IncrementalBuild.fs index 3113758808..0db1e3f6e5 100755 --- a/src/fsharp/vs/IncrementalBuild.fs +++ b/src/fsharp/vs/IncrementalBuild.fs @@ -12,6 +12,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.CompileOps @@ -1063,8 +1064,6 @@ module IncrementalBuilderEventTesting = module Tc = Microsoft.FSharp.Compiler.TypeChecker -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Internal.Utilities.Debug /// Accumulated results of type checking. [] diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs index 85f5f53108..73e501726b 100755 --- a/src/fsharp/vs/ServiceLexing.fs +++ b/src/fsharp/vs/ServiceLexing.fs @@ -18,7 +18,6 @@ open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Lexhelp open Microsoft.FSharp.Compiler.Lib -open Internal.Utilities.Debug type Position = int * int type Range = Position * Position @@ -649,9 +648,7 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, | EOF lexcont -> // End of text! No more tokens. None,lexcont,0 - | LEX_FAILURE s -> - // REVIEW: report this error - Trace.PrintLine("Lexing", fun _ -> sprintf "LEX_FAILURE:%s\n" s) + | LEX_FAILURE _ -> None, LexerStateEncoding.revertToDefaultLexCont, 0 | _ -> // Get the information about the token diff --git a/src/fsharp/vs/ServiceParamInfoLocations.fs b/src/fsharp/vs/ServiceParamInfoLocations.fs index df0ca0bc40..7f29854c4b 100755 --- a/src/fsharp/vs/ServiceParamInfoLocations.fs +++ b/src/fsharp/vs/ServiceParamInfoLocations.fs @@ -2,7 +2,6 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices -open Internal.Utilities.Debug open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast @@ -104,7 +103,6 @@ module internal NoteworthyParamInfoLocationsImpl = if AstTraversal.rangeContainsPosEdgesExclusive parenRange pos then let commasAndCloseParen = ((synExprList,commaRanges@[parenRange]) ||> List.map2 (fun e c -> c.End, getNamedParamName e)) let r = Found (parenRange.Start, commasAndCloseParen, rpRangeOpt.IsSome) - Trace.PrintLine("LanguageServiceParamInfo", fun () -> sprintf "Found paren tuple ranges %+A from %+A" r expr) r, None else NotFound, None @@ -124,7 +122,6 @@ module internal NoteworthyParamInfoLocationsImpl = | SynExpr.ArbitraryAfterError(_debugStr, range) -> // single argument when e.g. after open paren you hit EOF if AstTraversal.rangeContainsPosEdgesExclusive range pos then let r = Found (range.Start, [range.End, null], false) - Trace.PrintLine("LanguageServiceParamInfo", fun () -> sprintf "Found ArbitraryAfterError range %+A from %+A" r expr) r, None else NotFound, None @@ -132,7 +129,6 @@ module internal NoteworthyParamInfoLocationsImpl = | SynExpr.Const(SynConst.Unit, unitRange) -> if AstTraversal.rangeContainsPosEdgesExclusive unitRange pos then let r = Found (unitRange.Start, [unitRange.End, null], true) - Trace.PrintLine("LanguageServiceParamInfo", fun () -> sprintf "Found unit range %+A from %+A" r expr) r, None else NotFound, None @@ -203,7 +199,6 @@ module internal NoteworthyParamInfoLocationsImpl = if isInfix then // This seems to be an infix operator, since the start of the argument is a position earlier than the end of the long-id being applied to it. // For now, we don't support infix operators. - Trace.PrintLine("LanguageServiceParamInfo", fun () -> sprintf "Found apparent infix operator, ignoring dug-out ident from %+A" expr) None else Some (FSharpNoteworthyParamInfoLocations(lid, lidRange, parenLoc, args |> List.map fst, isThereACloseParen, args |> List.map snd)) @@ -212,7 +207,7 @@ module internal NoteworthyParamInfoLocationsImpl = | _ -> traverseSynExpr synExpr2 // ID and error recovery of these - | SynExpr.TypeApp(synExpr, openm, tyArgs, commas, closemOpt, _, wholem) as seta -> + | SynExpr.TypeApp(synExpr, openm, tyArgs, commas, closemOpt, _, wholem) -> match traverseSynExpr synExpr with | Some _ as r -> r | None -> @@ -220,7 +215,6 @@ module internal NoteworthyParamInfoLocationsImpl = if AstTraversal.rangeContainsPosEdgesExclusive typeArgsm pos && tyArgs |> List.forall isStaticArg then let commasAndCloseParen = [ for c in commas -> c.End ] @ [ wholem.End ] let r = FSharpNoteworthyParamInfoLocations(["dummy"], synExpr.Range, openm.Start, commasAndCloseParen, closemOpt.IsSome, tyArgs |> List.map digOutIdentFromStaticArg) - Trace.PrintLine("LanguageServiceParamInfo", fun () -> sprintf "Found SynExpr.TypeApp with ranges %+A from %+A" r seta) Some r else None diff --git a/src/fsharp/vs/ServiceUntypedParse.fs b/src/fsharp/vs/ServiceUntypedParse.fs index b8e58a15ab..67585e840a 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fs +++ b/src/fsharp/vs/ServiceUntypedParse.fs @@ -19,8 +19,6 @@ open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.Lib -open Internal.Utilities.Debug - /// Methods for dealing with F# sources files. module internal SourceFile = /// Source file extensions @@ -98,7 +96,6 @@ type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput ErrorScope.Protect Range.range0 (fun () -> - use t = Trace.Call("CompilerServices", "GetNavigationItems", fun _ -> "") match input with | Some(ParsedInput.ImplFile(ParsedImplFileInput(_modname,_isScript,_qualName,_pragmas,_hashDirectives,modules,_isLastCompiland))) -> NavigationImpl.getNavigationFromImplFile modules @@ -364,12 +361,10 @@ type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput // Get items for the navigation drop down bar member scope.GetNavigationItems() = - use t = Trace.Call("SyncOp","GetNavigationItems", fun _->"") // This does not need to be run on the background thread scope.GetNavigationItemsImpl() member scope.ValidateBreakpointLocation(pos) = - use t = Trace.Call("SyncOp","ValidateBreakpointLocation", fun _->"") // This does not need to be run on the background thread scope.ValidateBreakpointLocationImpl(pos) diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs index 3884082282..91c10f9a8b 100755 --- a/src/fsharp/vs/service.fs +++ b/src/fsharp/vs/service.fs @@ -39,13 +39,11 @@ open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.TypeChecker +open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionsImpl -open Internal.Utilities.Collections -open Internal.Utilities.Debug open Internal.Utilities -open Internal.Utilities.StructuredFormat +open Internal.Utilities.Collections -open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionsImpl [] module EnvMisc = @@ -571,7 +569,6 @@ type TypeCheckInfo |> FilterItemsForCtors filterCtors if nonNil items then - Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: Results in %d items!\n" items.Length) if hasTextChangedSinceLastTypecheck(textSnapshotInfo, m) then NameResResult.TypecheckStaleAndTextChanged // typecheck is stale, wait for second-chance IntelliSense to bring up right result else @@ -579,7 +576,6 @@ type TypeCheckInfo else NameResResult.Empty let GetCapturedNameResolutions endOfNamesPos resolveOverloads = - Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: endOfNamesPos = %s\n" (stringOfPos endOfNamesPos)) let quals = match resolveOverloads with @@ -596,7 +592,6 @@ type TypeCheckInfo let GetPreciseItemsFromNameResolution(line, colAtEndOfNames, membersByResidue, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck) = let endOfNamesPos = mkPos line colAtEndOfNames - Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: endOfNamesPos = %s\n" (stringOfPos endOfNamesPos)) // Logic below expects the list to be in reverse order of resolution let items = GetCapturedNameResolutions endOfNamesPos resolveOverloads |> ResizeArray.toList |> List.rev @@ -902,14 +897,13 @@ type TypeCheckInfo | NameResResult.TypecheckStaleAndTextChanged -> None // second-chance intellisense will try again | NameResResult.Cancel(denv,m) -> Some([], denv, m) | NameResResult.Members(FilterRelevantItems exactMatchResidueOpt items) -> - Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on name resolution results successful, #items = %d, exists ctor = %b\n" (p13 items).Length (items |> p13 |> List.exists (function Item.CtorGroup _ -> true | _ -> false))) + // lookup based on name resolution results successful Some items | _ -> match origLongIdentOpt with | None -> None | Some _ -> - Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: plid = %+A, residue = %+A, colAtEndOfNamesAndResidue = %+A\n" plid exactMatchResidueOpt colAtEndOfNamesAndResidue) // Try to use the type of the expression on the left to help generate a completion list let qualItems, thereIsADotInvolved = @@ -939,7 +933,7 @@ type TypeCheckInfo // and then return to the qualItems. This is because the expression typings are a little inaccurate, primarily because // it appears we're getting some typings recorded for non-atomic expressions like "f x" when (match plid with [] -> true | _ -> false) -> - Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on expression typings successful\n") + // lookup based on expression typings successful Some items | GetPreciseCompletionListFromExprTypingsResult.NoneBecauseThereWereTypeErrors, _ -> // There was an error, e.g. we have "." and there is an error determining the type of @@ -961,13 +955,13 @@ type TypeCheckInfo // First, use unfiltered name resolution items, if they're not empty | NameResResult.Members(items, denv, m), _, _ when nonNil items -> - Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on name resolution results successful, #items = %d, exists ctor = %b\n" (items).Length (items |> List.exists (function Item.CtorGroup _ -> true | _ -> false))) + // lookup based on name resolution results successful Some(items, denv, m) // If we have nonempty items from environment that were resolved from a type, then use them... // (that's better than the next case - here we'd return 'int' as a type) | _, FilterRelevantItems exactMatchResidueOpt (items, denv, m), _ when nonNil items -> - Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on name and environment successful\n") + // lookup based on name and environment successful Some(items, denv, m) // Try again with the qualItems From 308d7ee30c59af4886afeb71b7d3300795416c3c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 14:23:52 +0100 Subject: [PATCH 2/7] resolve merge conflict --- .../src/FSharp.LanguageService/Vs.fs | 1 - .../Project/AssemblyReferenceNode.cs | 29 ++++++------------- .../Project/ProjectNode.cs | 11 ------- 3 files changed, 9 insertions(+), 32 deletions(-) diff --git a/vsintegration/src/FSharp.LanguageService/Vs.fs b/vsintegration/src/FSharp.LanguageService/Vs.fs index 360f322979..a79e42f008 100644 --- a/vsintegration/src/FSharp.LanguageService/Vs.fs +++ b/vsintegration/src/FSharp.LanguageService/Vs.fs @@ -14,7 +14,6 @@ open Microsoft.VisualStudio.Text open Microsoft.VisualStudio.TextManager.Interop open Microsoft.VisualStudio.OLE.Interop open Microsoft.FSharp.Compiler.Range -open Internal.Utilities.Debug open System.Runtime.InteropServices /// Helper methods for interoperating with COM diff --git a/vsintegration/src/FSharp.ProjectSystem.Base/Project/AssemblyReferenceNode.cs b/vsintegration/src/FSharp.ProjectSystem.Base/Project/AssemblyReferenceNode.cs index 274d3a7285..91ce730e4a 100644 --- a/vsintegration/src/FSharp.ProjectSystem.Base/Project/AssemblyReferenceNode.cs +++ b/vsintegration/src/FSharp.ProjectSystem.Base/Project/AssemblyReferenceNode.cs @@ -486,9 +486,6 @@ private void ResolveAssemblyReferenceByFullPath(string assemblyFullPath, AddRefe } Debug.Assert(isValidPath, string.Format("Expected assemblyFullPath to be a full path, but it was {0}", assemblyFullPath)); - // AddComPlusReferenceByFullPath - Action Trace = (s) => FSharpTrace.PrintLine("ProjectSystemReferenceResolution", () => "ResolveAssemblyReferenceByFullPath: " + s); - Trace("starting: \""+assemblyFullPath+"\""); this.msbuildProjectionInfo.WantHintPath = false; this.msbuildProjectionInfo.WantFusionName = false; this.msbuildProjectionInfo.WantSpecificVersion = null; @@ -503,18 +500,16 @@ private void ResolveAssemblyReferenceByFullPath(string assemblyFullPath, AddRefe } if (!this.resolvedInfo.WasSuccessfullyResolved) { - Trace("simple name resolution did not succeed"); this.msbuildProjectionInfo.WantHintPath = true; AddToProjectFileAndTryResolve(assemblyFullPath); } else { this.myAssemblyPath = assemblyFullPath; - Trace("simple name resolution succeeded"); // we successfully resolved it via simple name if (!this.resolvedInfo.IsPlatformAssembly) { - Trace("not a platform assembly"); + // not a platform assembly if (resolvedInfo.AssemblyName != null) { // Project file contains different reference than picked/shown in UI @@ -529,21 +524,21 @@ private void ResolveAssemblyReferenceByFullPath(string assemblyFullPath, AddRefe if (tab == AddReferenceDialogTab.DotNetTab) { - Trace("from .Net tab"); + // from .Net tab this.msbuildProjectionInfo.WantFusionName = true; this.msbuildProjectionInfo.WantSpecificVersion = true; } else { Debug.Assert(tab == AddReferenceDialogTab.BrowseTab); - Trace("not from .Net tab"); + // not from .Net tab this.msbuildProjectionInfo.WantHintPath = true; } } else { // platform assemblies can just resolve to simple name - Trace("it was a platform assembly"); + // it was a platform assembly } } // TODO - not accounting for case described below @@ -567,7 +562,7 @@ private void ResolveAssemblyReferenceByFullPath(string assemblyFullPath, AddRefe { this.ProjectMgr.AddReferenceCouldNotBeAddedErrorMessage(assemblyFullPath); } - Trace("finished: \"" + assemblyFullPath + "\""); + // "finished: assemblyFullPath } /// @@ -576,25 +571,19 @@ private void ResolveAssemblyReferenceByFullPath(string assemblyFullPath, AddRefe /// Either a full path to a file on disk, or a simple name or fusion name private void AddToProjectFileAndTryResolve(string assemblyInclude) { - Action Trace = (s) => FSharpTrace.PrintLine("ProjectSystemReferenceResolution", () => "ResolveAssemblyReferenceCore: " + s); - Trace("starting: \"" + assemblyInclude + "\""); + // starting: assemblyInclude ProjectInstance instance = null; instance = this.ProjectMgr.BuildProject.CreateProjectInstance(); // use a fresh instance... instance.AddItem(ProjectFileConstants.Reference, assemblyInclude); // ...and mutate it as through there were another there - Trace("instance[Configuration]=" + instance.GetPropertyValue("Configuration")); - Trace("instance[Platform]=" + instance.GetPropertyValue("Platform")); var result = BuildInstance(this.ProjectMgr, ref instance, MsBuildTarget.ResolveAssemblyReferences); this.ResolveFromBuiltProject(assemblyInclude, result); - Trace("finished without finding original item: \"" + assemblyInclude + "\""); } private void ResolveFromBuiltProject(string assemblyInclude, BuildResult buildResult) { - Action Trace = (s) => FSharpTrace.PrintLine("ProjectSystemReferenceResolution", () => "ResolveAssemblyReferenceCore: " + s); - Trace("starting: \"" + assemblyInclude + "\""); if (!buildResult.IsSuccessful) { - Trace("ResolveAssemblyReferences build failed."); + // ResolveAssemblyReferences build failed. return; } System.Collections.Generic.IEnumerable group = buildResult.ProjectInstance.GetItems(ProjectFileConstants.ReferencePath); @@ -622,12 +611,12 @@ private void ResolveFromBuiltProject(string assemblyInclude, BuildResult buildRe { this.myAssemblyPath = Path.Combine(this.ProjectMgr.ProjectFolder, this.myAssemblyPath); } - Trace("finished and found original item: \"" + assemblyInclude + "\""); + // finished and found original item return; } } } - Trace("finished without finding original item: \"" + assemblyInclude + "\""); + // finished without finding original item } /// diff --git a/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs b/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs index ed5588d7ec..a5b803a273 100644 --- a/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs +++ b/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs @@ -41,17 +41,6 @@ namespace Microsoft.VisualStudio.FSharp.ProjectSystem { - internal class FSharpTrace - { - static public void PrintLine(string traceClass, Func msg) - { - if (global::Internal.Utilities.Debug.Trace.ShouldLog(traceClass)) - { - var fsFunc = Microsoft.FSharp.Core.FuncConvert.ToFSharpFunc(new Converter((u) => msg())); - global::Internal.Utilities.Debug.Trace.PrintLine(traceClass, fsFunc); - } - } - } internal delegate void MSBuildCoda(MSBuildResult result, ProjectInstance instance); From 8cc10814370fed8aa4adc2b5e2023241eafc3dd0 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 14:32:58 +0100 Subject: [PATCH 3/7] fix build --- vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs b/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs index 915b061e15..4f97f4ceb0 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs @@ -41,7 +41,6 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem open EnvDTE open Microsoft.Build.BuildEngine - open Internal.Utilities.Debug module internal VSHiveUtilities = /// For a given sub-hive, check to see if a 3rd party has specified any From 69ecc0fed0328d0fd6d09e493c3f503d2e9fea40 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 14:44:03 +0100 Subject: [PATCH 4/7] fix build --- .../FSharp.ProjectSystem.FSharp/Project.fs | 45 ++----------------- 1 file changed, 3 insertions(+), 42 deletions(-) diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs b/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs index 4f97f4ceb0..2ea05c35a7 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs @@ -388,13 +388,8 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem // for example. If necessary, this can be changed - but please just try to avoid doing a gratuitous rename. let mutable sourcesAndFlags : option<(array * array)> = None #if DEBUG - let mutable shouldLog = false // can poke this in the debugger to turn on logging let logger = new Microsoft.Build.BuildEngine.ConsoleLogger(Microsoft.Build.Framework.LoggerVerbosity.Diagnostic, - (fun s -> - let self = this - ignore self // ensure debugger has local in scope, so can poke self.shouldLog - if shouldLog then - Trace.Print("MSBuild", fun _ -> "MSBuild: " + s)), + (fun s -> Trace.WriteLine("MSBuild: " + s)), (fun _ -> ()), (fun _ -> ()) ) #endif @@ -439,12 +434,7 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem this.AddCATIDMapping(typeof, typeof.GUID) #if DEBUG - if Trace.ShouldLog("MSBuild") then - - this.SetDebugLogger(logger) - Trace.PrintLine("ProjectSystem", fun _ -> "attached MSBuild logger") - else - Trace.PrintLine("ProjectSystem", fun _ -> "not choosing to attach MSBuild logger") + this.SetDebugLogger(logger) #endif member private this.GetCurrentFrameworkName() = let tfm = this.GetTargetFrameworkMoniker() @@ -1318,9 +1308,6 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem override x.InvokeMsBuild(target, extraProperties) = let result = base.InvokeMsBuild(target, extraProperties) -#if DEBUG - Trace.PrintLine("ProjectSystem", fun _ -> sprintf "Called InvokeMsBuild(%s), result: %A" target result) -#endif result // Fulfill HostObject contract with Fsc task, and enable 'capture' of compiler flags for the project. @@ -1337,10 +1324,6 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem let normalizedSources = sources |> Array.map (fun fn -> System.IO.Path.GetFullPath(System.IO.Path.Combine(x.ProjectFolder, fn))) let r = (normalizedSources, flags) sourcesAndFlags <- Some(r) -#if DEBUG - Trace.PrintLine("ProjectSystem", fun _ -> sprintf "FSharpProjectNode(%s) sourcesAndFlags: %A" x.ProjectFile sourcesAndFlags) - Trace.PrintLine("ProjectSystem", fun _ -> sprintf "Compile() was called on FSharpProjectNode(%s); will we actually build? %A" x.ProjectFile actuallyBuild) -#endif if projectSite.State = ProjectSiteOptionLifetimeState.Opening then // This is the first time, so set up interface for language service to talk to us projectSite.Open(x.CreateRunningProjectSite()) @@ -1372,9 +1355,6 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem if not(inMidstOfReloading) && not(VsBuildManagerAccessorExtensionMethods.IsInProgress(accessor)) then #else if not(inMidstOfReloading) && not(FSharpBuildStatus.IsInProgress) then -#endif -#if DEBUG - use t = Trace.Call("ProjectSystem", "FSharpProjectNode::ComputeSourcesAndFlags()", fun _ -> x.ProjectFile) #endif // REVIEW CompilerFlags will be stale since last 'save' of MSBuild .fsproj file - can we do better? try @@ -1399,20 +1379,7 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem // If property is not set - msbuild will resolve only primary dependencies, // and compiler will be very unhappy when during processing of referenced assembly it will discover that all fundamental types should be // taken from System.Runtime that is not supplied - let success = x.InvokeMsBuild("Compile", isBeingCalledByComputeSourcesAndFlags = true, extraProperties = [KeyValuePair("_ResolveReferenceDependencies", "true")]) -#if DEBUG - Trace.PrintLine("ProjectSystem", fun _ -> sprintf "InvokeMsBuild('Compile') success: %A" success.IsSuccessful) - if not compileWasActuallyCalled then - Trace.PrintLine("ProjectSystem", fun _ -> "BUG? In ComputeSourcesAndFlags(), but Compile() was not called") -#if DEBUG_BUT_CANT_TURN_ON_BECAUSE_FAILS_ON_NEW_PROJECT - Debug.Assert(false, "Please report: This assert means that we invoked MSBuild but Compile was not called. Unless you have a weird project file that would fail to build from the command-line with 'msbuild foo.fsproj', this should never happen.") -#endif - else - Trace.PrintLine("ProjectSystem", fun _ -> "In ComputeSourcesAndFlags(), Compile() was called, hurrah") - -#else - ignore(success) -#endif + let _ = x.InvokeMsBuild("Compile", isBeingCalledByComputeSourcesAndFlags = true, extraProperties = [KeyValuePair("_ResolveReferenceDependencies", "true")]) sourcesAndFlagsNotifier.Notify() finally actuallyBuild <- true @@ -1466,9 +1433,6 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem x.DoFixupAppConfigOnTargetFXChange(runtime, sku, targetFSharpCoreVersion, autoGenerateBindingRedirects) override x.SetHostObject(targetName, taskName, hostObject) = -#if DEBUG - Trace.PrintLine("ProjectSystem", fun _ -> sprintf "about to set HostObject to %s" x.ProjectFile) -#endif base.SetHostObject(targetName, taskName, hostObject) override x.SetBuildProject newProj = @@ -1558,9 +1522,6 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem // which will finally populate sourcesAndFlags with good values. // This means that ones the user fixes the problem, proper intellisense etc. should start immediately lighting up. sourcesAndFlags <- Some([||],[||]) -#if DEBUG - Trace.PrintLine("ProjectSystem", fun _ -> "First call to ComputeSourcesAndFlags failed") -#endif projectSite.Open(x.CreateRunningProjectSite()) () | _ -> () From 19d592de9f80fc6095354b8b97473364bd68d1d8 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 17:23:58 +0100 Subject: [PATCH 5/7] fix build --- vsintegration/tests/Salsa/salsa.fs | 56 +++---------------- .../unittests/TestLib.LanguageService.fs | 6 -- 2 files changed, 8 insertions(+), 54 deletions(-) diff --git a/vsintegration/tests/Salsa/salsa.fs b/vsintegration/tests/Salsa/salsa.fs index c16cdc461d..fefddbc7dc 100644 --- a/vsintegration/tests/Salsa/salsa.fs +++ b/vsintegration/tests/Salsa/salsa.fs @@ -18,7 +18,6 @@ open System.Text open System.Collections.Generic open System.Runtime.InteropServices open System.Threading -open Internal.Utilities.Debug open Microsoft.VisualStudio open Microsoft.VisualStudio.Shell.Interop open Microsoft.VisualStudio.FSharp.ProjectSystem @@ -49,8 +48,6 @@ module internal Salsa = #else member th.Compile(compile:System.Converter, flags:string[], sources:string[]) = #endif - use t = Trace.Call("MSBuild", "Compile", fun _ -> "Host compile invoke by Fsc task") - Trace.PrintLine("MSBuild", fun _ -> sprintf "flags=%A" flags) capturedFlags <- flags capturedSources <- sources if actuallyBuild then @@ -79,20 +76,9 @@ module internal Salsa = let engine = Utilities.InitializeMsBuildEngine(null) if not hasAttachedLogger then hasAttachedLogger<-true - let logRegular = Trace.ShouldLog("MSBuild") - let logPerf = Trace.ShouldLog("MSBuildPerf") - if logRegular || logPerf then - let l = if logRegular then - Trace.PrintLine("MSBuild", fun () -> "Detailed logging.") - new Microsoft.Build.BuildEngine.ConsoleLogger(LoggerVerbosity.Detailed) - else - Trace.PrintLine("MSBuild", fun () -> "Quiet logging.") - new Microsoft.Build.BuildEngine.ConsoleLogger(LoggerVerbosity.Quiet) - Trace.PrintLine("MSBuild", fun () -> "About to attach MSBuild console logger.") - // For Dev10 build we pass the logger to the Build call on the project object. - theAttachedLogger <- l - Trace.PrintLine("MSBuild", fun () -> "Attached MSBuild console logger.") - if logPerf then l.ApplyParameter("PERFORMANCESUMMARY", null) + let l = new Microsoft.Build.BuildEngine.ConsoleLogger(LoggerVerbosity.Detailed) + // For Dev10 build we pass the logger to the Build call on the project object. + theAttachedLogger <- l engine /// Set a global property on the given project. @@ -113,7 +99,6 @@ module internal Salsa = | _ -> failwith "multiple projects found" match project with | null -> - use t = Trace.Call("MSBuildPerf","Creating new project", fun _-> projectFileName) let project = GlobalEngine().LoadProject(projectFileName) // Set global properties. SetGlobalProperty(project,"BuildingInsideVisualStudio", "true") @@ -126,7 +111,6 @@ module internal Salsa = hostObjectCachePerFilename.[projectFileName] <- theHostObject project, true, theHostObject | project-> - use t = Trace.Call("MSBuildPerf","Using existing project", fun _-> projectFileName) match hostObjectCachePerFilename.TryGetValue(projectFileName) with | true, theHostObject -> project, false, theHostObject @@ -148,10 +132,7 @@ module internal Salsa = if p = null then "" else p let items (project:Project) name = - let l = project.GetItems(name) |> Seq.map (fun i -> i.EvaluatedInclude) |> Seq.toList - //use t = Trace.Call("MSBuild","items", fun _ -> sprintf " %s: %A" name l) - l - + project.GetItems(name) |> Seq.map (fun i -> i.EvaluatedInclude) |> Seq.toList let oneItem (project:Project) name = match (items project name) with @@ -166,8 +147,7 @@ module internal Salsa = true /// Build the given target on the given project. Return the name of the main output assembly. - let Build(projectFileName, target, configuration, platform) : BuildResult = - use t = Trace.Call("MSBuild","build", fun _-> sprintf " target=%s project=%s configruation=%s platform=%s" target projectFileName configuration platform) + let Build(projectFileName, target:string, configuration, platform) : BuildResult = let project,_,_ = GetProject(projectFileName, configuration, platform) let projectInstance = project.CreateProjectInstance() let buildResult = projectInstance.Build(target, Seq.append project.ProjectCollection.Loggers (if theAttachedLogger=null then [] else [theAttachedLogger])) @@ -182,7 +162,6 @@ module internal Salsa = /// Return the name of the main output assembly but don't build let GetMainOutputAssembly(projectFileName, configuration, platform) : string = - use t = Trace.Call("MSBuild","GetMainOutputAssembly", fun _-> sprintf " project=%s configruation=%s platform=%s" projectFileName configuration platform) let project,_,_ = GetProject(projectFileName, configuration, platform) let baseName = Path.GetFileNameWithoutExtension(projectFileName)+".exe" let projectInstance = project.CreateProjectInstance() @@ -193,7 +172,6 @@ module internal Salsa = let CreateFSharpManifestResourceName(projectFileName,configuration, platform) : (string * string) list= let targetName = "CreateManifestResourceNames" - use t = Trace.Call("MSBuild", targetName, fun _-> sprintf " target=%s project=%s configruation=%s platform=%s" targetName projectFileName configuration platform) let project,_,_ = GetProject(projectFileName, configuration, platform) SetGlobalProperty(project, "CreateManifestResourceNamesDependsOn", "SplitResourcesByCulture") let projectInstance = project.CreateProjectInstance() @@ -216,15 +194,10 @@ module internal Salsa = /// Compute the Flags and Sources let GetFlagsAndSources(project:Project, host:HostCompile) : BuildFlags = let result = - use t = Trace.Call("MSBuildPerf","Calling compile to get flags", fun _-> "") use xx = host.CaptureSourcesAndFlagsWithoutBuildingForABit() project.IsBuildEnabled <- true - let loggers = - if Trace.ShouldLog("MSBuild") then - seq { yield (new Microsoft.Build.BuildEngine.ConsoleLogger(LoggerVerbosity.Detailed) :> ILogger) } - else - [] :> seq + let loggers = seq { yield (new Microsoft.Build.BuildEngine.ConsoleLogger(LoggerVerbosity.Detailed) :> ILogger) } let r = project.Build("Compile", loggers) if not(r) then @@ -243,16 +216,12 @@ module internal Salsa = sources = result.sources |> List.map Canonicalize } let CrackProject(projectFileName, configuration, platform) = - use t = Trace.Call("MSBuild","crackProject", fun _-> sprintf " project=%s" projectFileName) let project,created,host = GetProject(projectFileName, configuration, platform) - Trace.PrintLine("MSBuild", fun _ -> sprintf "Project text:\n %s " (File.ReadAllText(projectFileName))) try try - let result = GetFlagsAndSources(project,host) - Trace.PrintLine("MSBuild", fun _ -> sprintf "Resolved flags and sources:\n %A \n %A" result.flags result.sources) - result + GetFlagsAndSources(project,host) with e -> System.Diagnostics.Debug.Assert(false, sprintf "Bug seen in MSBuild CrackProject: %s %s %s\n" (e.GetType().Name) e.Message (e.StackTrace)) reraise() @@ -285,7 +254,6 @@ module internal Salsa = || flags = None || prevConfig <> curConfig || prevPlatform <> curPlatform then - Trace.PrintLine("ProjectSite", fun _ -> sprintf "Timestamp of %s changed. New timestamp=%A, old timestamp=%A" projectfile newtimestamp timestamp) timestamp <- newtimestamp prevConfig <- curConfig prevPlatform <- curPlatform @@ -312,7 +280,6 @@ module internal Salsa = member this.CompilerFlags() = let flags = GetFlags() let result = flags.flags - Trace.PrintLine("ProjectSite", fun _ -> sprintf "MSBuild flags were %A." result) result |> List.toArray member this.ProjectFileName() = projectfile @@ -660,7 +627,6 @@ module internal Salsa = let sb = new System.Text.StringBuilder() let Append (text:string) = - Trace.PrintLine("VisualFSharp.Salsa", fun _ -> text) sb.Append(text+"\r\n") |> ignore Append "" Append " " @@ -727,7 +693,6 @@ module internal Salsa = Append (sprintf " " targetsFileFolder) Append "" - Trace.PrintLine("VisualFSharp.Salsa", fun _ -> sprintf "Project text:\n%s" (sb.ToString()) ) sb.ToString() @@ -744,11 +709,9 @@ module internal Salsa = let Plat() = let _,p = ConfPlat() in p interface ProjectBehaviorHooks with member x.CreateProjectHook (projectName, files, references, projectReferences, disabledWarnings, defines, versionFile, otherFlags, preImportXml, targetFrameworkVersion : string) = - use t = Trace.Call("VisualFSharp.Salsa", "CreateMsBuildProject", fun _ -> sprintf " projectName=%s" projectName) if File.Exists(projectName) then File.Delete(projectName) let text = CreateMsBuildProjectText useInstalledTargets (files, references, projectReferences, disabledWarnings, defines, versionFile, otherFlags, preImportXml, targetFrameworkVersion) - Trace.PrintLine("VisualFSharp.Salsa", fun _ -> text) File.AppendAllText(projectName,text+"\r\n") member x.InitializeProjectHook op = openProject <- Some(op:?>IOpenProject) @@ -835,7 +798,6 @@ module internal Salsa = member vs.IsShiftKeyDown = shiftKeyDown member vs.PushUndo(u) = - Trace.PrintLine("SalsaUndo", fun _ -> sprintf "Pushing cleanup action %A" u) undoStack<-u::undoStack member vs.GetColorizer(view:IVsTextView) = let _,buffer = view.GetBuffer() @@ -886,7 +848,7 @@ module internal Salsa = vs.LanguageService.OnIdle() match focusFile with | Some(focusFile) -> focusFile.OnIdle() - | None -> Trace.PrintLine("ChangeEvents", fun _ -> "In TakeCoffeeBreak there was no focus file to idle.") + | None -> () member vs.ShiftKeyDown() = shiftKeyDown <- true member vs.ShiftKeyUp() = shiftKeyDown <- false member vs.TakeCoffeeBreak() = @@ -911,14 +873,12 @@ module internal Salsa = undoActions |> List.iter(function DeleteFile f -> - Trace.PrintLine("SalsaUndo", fun _ -> sprintf "Performing undo action: DeleteFile %s" f) try File.Delete(f) with e-> printf "Failed to Delete file '%s'" f raise e | RemoveFolder f -> - Trace.PrintLine("SalsaUndo", fun _ -> sprintf "Performing undo action: RemoveFolder %s" f) try if Directory.Exists(f) then Directory.Delete(f,true) with diff --git a/vsintegration/tests/unittests/TestLib.LanguageService.fs b/vsintegration/tests/unittests/TestLib.LanguageService.fs index e6dc71eb8e..efdc1e5543 100644 --- a/vsintegration/tests/unittests/TestLib.LanguageService.fs +++ b/vsintegration/tests/unittests/TestLib.LanguageService.fs @@ -12,7 +12,6 @@ open Salsa.VsMocks open UnitTests.TestLib.Salsa open UnitTests.TestLib.Utils open Microsoft.FSharp.Compiler -open Internal.Utilities.Debug open System.Text.RegularExpressions open Microsoft.FSharp.Compiler.SourceCodeServices #nowarn "52" // The value has been copied to ensure the original is not mutated @@ -376,7 +375,6 @@ type LanguageServiceBaseTests() = // Under .NET 4.0 we don't allow 3.5.0.0 assemblies let AssertNotBackVersionAssembly(args:AssemblyLoadEventArgs) = - Trace.PrintLine("AssembliesLoadedByUnittests",fun _ -> sprintf "ASSEMBLY LOAD: %A" (args.LoadedAssembly)) // We're worried about loading these when running against .NET 4.0: // Microsoft.Build.Tasks.v3.5, Version=3.5.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a @@ -429,11 +427,7 @@ type LanguageServiceBaseTests() = ShiftKeyUp(currentVS) ops.CleanInvisibleProject(currentVS) -// do setDiagnosticsChannel(Some(Console.Out)); do AbstractIL.Diagnostics.setDiagnosticsChannel(None); - // To disable a logging class, put an underscore _after_ its name. - //Trace.Log <- "ChangeEvents_;SyncOp_;Reactor_;ProjectSite_;IncrementalBuild_;Build_;Salsa_;SalsaUndo_;MSBuild_;MSBuildPerf_;IncrementalBuildWorkUnits_;LanguageService_;StripSystemImportsFromTcConfig_;ProjectSystem_" -// Trace.Log <- "*" ResetStopWatch() testStopwatch.Reset() testStopwatch.Start() From c625a8f676bbf42ab5244885fd31461d2fba6095 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 17:25:31 +0100 Subject: [PATCH 6/7] fix build --- src/absil/ildiag.fs | 3 +++ src/absil/ildiag.fsi | 2 ++ vsintegration/tests/unittests/TestLib.ProjectSystem.fs | 1 - 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/absil/ildiag.fs b/src/absil/ildiag.fs index 3cbb2852d5..ae5fd91546 100644 --- a/src/absil/ildiag.fs +++ b/src/absil/ildiag.fs @@ -7,6 +7,9 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Internal.Utilities let diagnosticsLog = ref (Some stdout) + +let setDiagnosticsChannel s = diagnosticsLog := s + let dflushn () = match !diagnosticsLog with None -> () | Some d -> d.WriteLine(); d.Flush() let dflush () = match !diagnosticsLog with None -> () | Some d -> d.Flush() let dprintn (s:string) = diff --git a/src/absil/ildiag.fsi b/src/absil/ildiag.fsi index 3974130fcd..b7aeb60341 100644 --- a/src/absil/ildiag.fsi +++ b/src/absil/ildiag.fsi @@ -11,6 +11,8 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open System.IO open Microsoft.FSharp.Core.Printf +val public setDiagnosticsChannel: TextWriter option -> unit + val public dprintfn: TextWriterFormat<'a> -> 'a val public dprintf: TextWriterFormat<'a> -> 'a val public dprintn: string -> unit diff --git a/vsintegration/tests/unittests/TestLib.ProjectSystem.fs b/vsintegration/tests/unittests/TestLib.ProjectSystem.fs index b37120877e..b09d61ebc5 100644 --- a/vsintegration/tests/unittests/TestLib.ProjectSystem.fs +++ b/vsintegration/tests/unittests/TestLib.ProjectSystem.fs @@ -9,7 +9,6 @@ open System.Runtime.Serialization open System.Collections.Generic open System.Text.RegularExpressions open System.Diagnostics -open Internal.Utilities.Debug open System.IO open System.Text open System.Xml.Linq From 49941f30501bb3bf21468be2186d8a64acfa6339 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 4 Jul 2016 17:58:31 +0100 Subject: [PATCH 7/7] fix build --- src/absil/ilread.fs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index 4a6c3cd59c..c02b35def8 100644 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -2692,6 +2692,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = !b = (i_unaligned &&& 0xff) || !b = (i_volatile &&& 0xff) || !b = (i_tail &&& 0xff)) do + begin if !b = (i_unaligned &&& 0xff) then let unal = seekReadByteAsInt32 ctxt.is (start + (!curr)) incr curr @@ -2708,6 +2709,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = let typ = seekReadTypeDefOrRef ctxt numtypars AsObject ILList.empty (uncodedTokenToTypeDefOrRefOrSpec uncoded) prefixes.constrained <- Some typ else prefixes.tl <- Tailcall + end get () end