open System.IO

open System.Reflection

open System.Collections.Generic

open Internal.Utilities

open Internal.Utilities.Collections

open Microsoft.FSharp.Compiler.AbstractIL

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library

open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX

open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types

open Microsoft.FSharp.Compiler.AbstractIL.Internal.BinaryConstants

open Microsoft.FSharp.Compiler

open Microsoft.FSharp.Compiler.AttributeChecking

open Microsoft.FSharp.Compiler.Ast

open Microsoft.FSharp.Compiler.ErrorLogger

open Microsoft.FSharp.Compiler.Infos

open Microsoft.FSharp.Compiler.Import

open Microsoft.FSharp.Compiler.Layout

open Microsoft.FSharp.Compiler.Lib

open Microsoft.FSharp.Compiler.PrettyNaming

open Microsoft.FSharp.Compiler.Range

open Microsoft.FSharp.Compiler.Tast

open Microsoft.FSharp.Compiler.Tastops

open Microsoft.FSharp.Compiler.Tastops.DebugPrint

open Microsoft.FSharp.Compiler.TcGlobals

open Microsoft.FSharp.Compiler.TypeRelations

let IsNonErasedTypar (tp:Typar) = not tp.IsErased

let DropErasedTypars (tps:Typar list) = tps |> List.filter IsNonErasedTypar

let DropErasedTyargs tys = tys |> List.filter (fun ty -> match ty with TType_measure _ -> false | _ -> true)

let AddNonUserCompilerGeneratedAttribs (g: TcGlobals) (mdef:ILMethodDef) = g.AddMethodGeneratedAttributes mdef

let debugDisplayMethodName = "__DebugDisplay"

let useHiddenInitCode = true

let iLdcZero = AI_ldc (DT_I4,ILConst.I4 0)

let iLdcInt64 i = AI_ldc (DT_I8,ILConst.I8 i)

let iLdcDouble i = AI_ldc (DT_R8,ILConst.R8 i)

let iLdcSingle i = AI_ldc (DT_R4,ILConst.R4 i)

let mkLdfldMethodDef (ilMethName,reprAccess,isStatic,ilTy,ilFieldName,ilPropType) =

let ilFieldSpec = mkILFieldSpecInTy(ilTy,ilFieldName,ilPropType)

let ilReturn = mkILReturn ilPropType

let ilMethodDef =

if isStatic then

mkILNonGenericStaticMethod (ilMethName,reprAccess,[],ilReturn,mkMethodBody(true,[],2,nonBranchingInstrsToCode [mkNormalLdsfld ilFieldSpec],None))

else

mkILNonGenericInstanceMethod (ilMethName,reprAccess,[],ilReturn,mkMethodBody (true,[],2,nonBranchingInstrsToCode [ mkLdarg0; mkNormalLdfld ilFieldSpec],None))

ilMethodDef.WithSpecialName

let ChooseParamNames fieldNamesAndTypes =

let takenFieldNames = fieldNamesAndTypes |> List.map p23 |> Set.ofList

fieldNamesAndTypes

|> List.map (fun (ilPropName,ilFieldName,ilPropType) ->

let lowerPropName = String.uncapitalize ilPropName

let ilParamName = if takenFieldNames.Contains(lowerPropName) then ilPropName else lowerPropName

ilParamName,ilFieldName,ilPropType)

let markup s = Seq.indexed s

let rec CheckCodeDoesSomething (code: ILCode) =

code.Instrs |> Array.exists (function AI_ldnull | AI_nop | AI_pop | I_ret | I_seqpoint _ -> false | _ -> true)

let ChooseFreeVarNames takenNames ts =

let tns = List.map (fun t -> (t,None)) ts

let rec chooseName names (t,nOpt) =

let tn = match nOpt with None -> t | Some n -> t + string n

if Zset.contains tn names then

chooseName names (t,Some(match nOpt with None -> 0 | Some n -> (n+1)))

else

let names = Zset.add tn names

tn,names

let names = Zset.empty String.order |> Zset.addList takenNames

let ts,_names = List.mapFold chooseName names tns

ts

let ilxgenGlobalNng = NiceNameGenerator ()

let IsILTypeByref = function ILType.Byref _ -> true | _ -> false

let mainMethName = CompilerGeneratedName "main"

type AttributeDecoder(namedArgs) =

let nameMap = namedArgs |> List.map (fun (AttribNamedArg(s,_,_,c)) -> s,c) |> NameMap.ofList

let findConst x = match NameMap.tryFind x nameMap with | Some(AttribExpr(_,Expr.Const(c,_,_))) -> Some c | _ -> None

let findAppTr x = match NameMap.tryFind x nameMap with | Some(AttribExpr(_,Expr.App(_,_,[TType_app(tr,_)],_,_))) -> Some tr | _ -> None

member self.FindInt16 x dflt = match findConst x with | Some(Const.Int16 x) -> x | _ -> dflt

member self.FindInt32 x dflt = match findConst x with | Some(Const.Int32 x) -> x | _ -> dflt

member self.FindBool x dflt = match findConst x with | Some(Const.Bool x) -> x | _ -> dflt

member self.FindString x dflt = match findConst x with | Some(Const.String x) -> x | _ -> dflt

member self.FindTypeName x dflt = match findAppTr x with | Some(tr) -> tr.DisplayName | _ -> dflt

let mutable reports = (fun _ -> ())

let AddReport f = let old = reports in reports <- (fun oc -> old oc; f oc)

let ReportStatistics (oc:TextWriter) = reports oc

let NewCounter nm =

let count = ref 0

AddReport (fun oc -> if !count <> 0 then oc.WriteLine (string !count + " " + nm))

(fun () -> incr count)

let CountClosure = NewCounter "closures"

let CountMethodDef = NewCounter "IL method defintitions corresponding to values"

let CountStaticFieldDef = NewCounter "IL field defintitions corresponding to values"

let CountCallFuncInstructions = NewCounter "callfunc instructions (indirect calls)"

type IlxGenIntraAssemblyInfo =

{ /// A table recording the generated name of the static backing fields for each mutable top level value where

/// we may need to take the address of that value, e.g. static mutable module-bound values which are structs. These are

/// only accessible intra-assembly. Across assemblies, taking the address of static mutable module-bound values is not permitted.

/// The key to the table is the method ref for the property getter for the value, which is a stable name for the Val's

/// that come from both the signature and the implementation.

StaticFieldInfo : Dictionary<ILMethodRef, ILFieldSpec> }

type IlxGenBackend =

| IlWriteBackend

| IlReflectBackend

type IlxGenOptions =

{ fragName: string

generateFilterBlocks: bool

workAroundReflectionEmitBugs: bool

emitConstantArraysUsingStaticDataBlobs: bool

/// If this is set, then the last module becomes the "main" module and its toplevel bindings are executed at startup

mainMethodInfo: Tast.Attribs option

localOptimizationsAreOn: bool

generateDebugSymbols: bool

testFlagEmitFeeFeeAs100001: bool

ilxBackend: IlxGenBackend

/// Indicates the code is being generated in FSI.EXE and is executed immediately after code generation

/// This includes all interactively compiled code, including #load, definitions, and expressions

isInteractive: bool

/// Indicates the code generated is an interactive 'it' expression. We generate a setter to allow clearing of the underlying

/// storage, even though 'it' is not logically mutable

isInteractiveItExpr: bool

/// Whenever possible, use callvirt instead of call

alwaysCallVirt: bool }

type cenv =

{ g: TcGlobals

TcVal : ConstraintSolver.TcValF

viewCcu: CcuThunk

opts: IlxGenOptions

/// Cache the generation of the "unit" type

mutable ilUnitTy: ILType option

amap: ImportMap

intraAssemblyInfo : IlxGenIntraAssemblyInfo

/// Cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType

casApplied : Dictionary<Stamp,bool>

/// Used to apply forced inlining optimizations to witnesses generated late during codegen

mutable optimizeDuringCodeGen : (Expr -> Expr) }

let mkTypeOfExpr cenv m ilty =

mkAsmExpr ([ mkNormalCall (mspec_Type_GetTypeFromHandle cenv.g) ], [],

[mkAsmExpr ([ I_ldtoken (ILToken.ILType ilty) ], [],[],[cenv.g.system_RuntimeTypeHandle_ty],m)],

[cenv.g.system_Type_ty],m)

let mkGetNameExpr cenv (ilt : ILType) m =

mkAsmExpr ([I_ldstr ilt.BasicQualifiedName],[],[],[cenv.g.string_ty],m)

let useCallVirt cenv boxity (mspec : ILMethodSpec) isBaseCall =

cenv.opts.alwaysCallVirt &&

(boxity = AsObject) &&

not mspec.CallingConv.IsStatic &&

not isBaseCall

type CompileLocation =

{ clocScope: IL.ILScopeRef

clocTopImplQualifiedName: string

clocNamespace: string option

clocEncl: string list

clocQualifiedNameOfFile : string }

let mkTopName ns n = String.concat "." (match ns with Some x -> [x;n] | None -> [n])

let CompLocForFragment fragName (ccu:CcuThunk) =

{ clocQualifiedNameOfFile =fragName

clocTopImplQualifiedName= fragName

clocScope=ccu.ILScopeRef

clocNamespace=None

clocEncl=[]}

let CompLocForCcu (ccu:CcuThunk) = CompLocForFragment ccu.AssemblyName ccu

let CompLocForSubModuleOrNamespace cloc (submod:ModuleOrNamespace) =

let n = submod.CompiledName

match submod.ModuleOrNamespaceType.ModuleOrNamespaceKind with

| FSharpModuleWithSuffix | ModuleOrType -> { cloc with clocEncl= cloc.clocEncl @ [n]}

| Namespace -> {cloc with clocNamespace=Some (mkTopName cloc.clocNamespace n)}

let CompLocForFixedPath fragName qname (CompPath(sref,cpath)) =

let ns,t = List.takeUntil (fun (_,mkind) -> mkind <> Namespace) cpath

let ns = List.map fst ns

let ns = textOfPath ns

let encl = t |> List.map (fun (s ,_)-> s)

let ns = if ns = "" then None else Some ns

{ clocQualifiedNameOfFile =fragName

clocTopImplQualifiedName=qname

clocScope=sref

clocNamespace=ns

clocEncl=encl }

let CompLocForFixedModule fragName qname (mspec:ModuleOrNamespace) =

let cloc = CompLocForFixedPath fragName qname mspec.CompilationPath

let cloc = CompLocForSubModuleOrNamespace cloc mspec

cloc

let NestedTypeRefForCompLoc cloc n =

match cloc.clocEncl with

| [] ->

let tyname = mkTopName cloc.clocNamespace n

mkILTyRef(cloc.clocScope,tyname)

| h::t -> mkILNestedTyRef(cloc.clocScope,mkTopName cloc.clocNamespace h :: t,n)

let CleanUpGeneratedTypeName (nm:string) =

if nm.IndexOfAny IllegalCharactersInTypeAndNamespaceNames = -1 then

nm

else

(nm,IllegalCharactersInTypeAndNamespaceNames) ||> Array.fold (fun nm c -> nm.Replace(string c, "-"))

let TypeNameForInitClass cloc = "<StartupCode$" + (CleanUpGeneratedTypeName cloc.clocQualifiedNameOfFile) + ">.$" + cloc.clocTopImplQualifiedName

let TypeNameForImplicitMainMethod cloc = TypeNameForInitClass cloc + "$Main"

let TypeNameForPrivateImplementationDetails cloc = "<PrivateImplementationDetails$" + (CleanUpGeneratedTypeName cloc.clocQualifiedNameOfFile) + ">"

let CompLocForInitClass cloc =

{cloc with clocEncl=[TypeNameForInitClass cloc]; clocNamespace=None}

let CompLocForImplicitMainMethod cloc =

{cloc with clocEncl=[TypeNameForImplicitMainMethod cloc]; clocNamespace=None}

let CompLocForPrivateImplementationDetails cloc =

{cloc with

clocEncl=[TypeNameForPrivateImplementationDetails cloc]; clocNamespace=None}

let rec TypeRefForCompLoc cloc =

match cloc.clocEncl with

| [] ->

mkILTyRef(cloc.clocScope,TypeNameForPrivateImplementationDetails cloc)

| [h] ->

let tyname = mkTopName cloc.clocNamespace h

mkILTyRef(cloc.clocScope,tyname)

| _ ->

let encl,n = List.frontAndBack cloc.clocEncl

NestedTypeRefForCompLoc {cloc with clocEncl=encl} n

let mkILTyForCompLoc cloc = mkILNonGenericBoxedTy (TypeRefForCompLoc cloc)

let ComputeMemberAccess hidden = if hidden then ILMemberAccess.Assembly else ILMemberAccess.Public

let ComputePublicTypeAccess() = ILTypeDefAccess.Public

let ComputeTypeAccess (tref:ILTypeRef) hidden =

match tref.Enclosing with

| [] -> if hidden then ILTypeDefAccess.Private else ComputePublicTypeAccess()

| _ -> ILTypeDefAccess.Nested (ComputeMemberAccess hidden)

type TypeReprEnv(reprs : Map<Stamp, uint16>, count: int) =

member tyenv.Item (tp:Typar, m:range) =

try reprs.[tp.Stamp]

with :? KeyNotFoundException ->

errorR(InternalError("Undefined or unsolved type variable: " + showL(typarL tp),m))

// Random value for post-hoc diagnostic analysis on generated tree *

uint16 666

member tyenv.AddOne (tp: Typar) =

if IsNonErasedTypar tp then

TypeReprEnv(reprs.Add (tp.Stamp, uint16 count), count + 1)

else

tyenv

member tyenv.Add tps =

(tyenv,tps) ||> List.fold (fun tyenv tp -> tyenv.AddOne tp)

member tyenv.Count = count

static member Empty =

TypeReprEnv(count = 0, reprs = Map.empty)

static member ForTypars tps =

TypeReprEnv.Empty.Add tps

static member ForTycon (tycon:Tycon) =

TypeReprEnv.ForTypars (tycon.TyparsNoRange)

static member ForTyconRef (tycon:TyconRef) =

TypeReprEnv.ForTycon tycon.Deref

let GenTyconRef (tcref:TyconRef) =

assert(not tcref.IsTypeAbbrev)

tcref.CompiledRepresentation

type VoidNotOK = VoidNotOK | VoidOK

#if DEBUG

let voidCheck m g permits ty =

if permits=VoidNotOK && isVoidTy g ty then

error(InternalError("System.Void unexpectedly detected in IL code generation. This should not occur.",m))

type PtrsOK =

| PtrTypesOK

| PtrTypesNotOK

let GenReadOnlyAttributeIfNecessary (g: TcGlobals) ty =

let add = isInByrefTy g ty && g.attrib_IsReadOnlyAttribute.TyconRef.CanDeref

if add then

let attr = mkILCustomAttribute g.ilg (g.attrib_IsReadOnlyAttribute.TypeRef, [], [], [])

Some attr

else

None

let GenReadOnlyModReqIfNecessary (g: TcGlobals) ty ilTy =

let add = isInByrefTy g ty && g.attrib_InAttribute.TyconRef.CanDeref

if add then

ILType.Modified(true, g.attrib_InAttribute.TypeRef, ilTy)

else

ilTy

let rec GenTypeArgAux amap m tyenv tyarg =

GenTypeAux amap m tyenv VoidNotOK PtrTypesNotOK tyarg

and GenTypeArgsAux amap m tyenv tyargs =

List.map (GenTypeArgAux amap m tyenv) (DropErasedTyargs tyargs)

and GenTyAppAux amap m tyenv repr tinst =

match repr with

| CompiledTypeRepr.ILAsmOpen ty ->

let ilTypeInst = GenTypeArgsAux amap m tyenv tinst

let ty = IL.instILType ilTypeInst ty

ty

| CompiledTypeRepr.ILAsmNamed (tref, boxity, ilTypeOpt) ->

match ilTypeOpt with

| None ->

let ilTypeInst = GenTypeArgsAux amap m tyenv tinst

mkILTy boxity (mkILTySpec (tref,ilTypeInst))

| Some ilType ->

ilType // monomorphic types include a cached ilType to avoid reallocation of an ILType node

and GenNamedTyAppAux (amap:ImportMap) m tyenv ptrsOK tcref tinst =

let g = amap.g

let tinst = DropErasedTyargs tinst

// See above note on ptrsOK

if ptrsOK = PtrTypesOK && tyconRefEq g tcref g.nativeptr_tcr && (freeInTypes CollectTypars tinst).FreeTypars.IsEmpty then

GenNamedTyAppAux amap m tyenv ptrsOK g.ilsigptr_tcr tinst

else

#if !NO_EXTENSIONTYPING

match tcref.TypeReprInfo with

// Generate the base type, because that is always the representation of the erased type, unless the assembly is being injected

| TProvidedTypeExtensionPoint info when info.IsErased ->

GenTypeAux amap m tyenv VoidNotOK ptrsOK (info.BaseTypeForErased (m,g.obj_ty))

| _ ->

GenTyAppAux amap m tyenv (GenTyconRef tcref) tinst

and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty =

let g = amap.g

#if DEBUG

voidCheck m g voidOK ty

ignore voidOK

match stripTyEqnsAndMeasureEqns g ty with

| TType_app (tcref, tinst) -> GenNamedTyAppAux amap m tyenv ptrsOK tcref tinst

| TType_tuple (tupInfo, args) -> GenTypeAux amap m tyenv VoidNotOK ptrsOK (mkCompiledTupleTy g (evalTupInfoIsStruct tupInfo) args)

| TType_fun (dty, returnTy) -> EraseClosures.mkILFuncTy g.ilxPubCloEnv (GenTypeArgAux amap m tyenv dty) (GenTypeArgAux amap m tyenv returnTy)

| TType_ucase (ucref, args) ->

let cuspec,idx = GenUnionCaseSpec amap m tyenv ucref args

EraseUnions.GetILTypeForAlternative cuspec idx

| TType_forall (tps, tau) ->

let tps = DropErasedTypars tps

if tps.IsEmpty then GenTypeAux amap m tyenv VoidNotOK ptrsOK tau

else EraseClosures.mkILTyFuncTy g.ilxPubCloEnv

| TType_var tp -> mkILTyvarTy tyenv.[tp,m]

| TType_measure _ -> g.ilg.typ_Int32

and GenUnionCaseRef (amap: ImportMap) m tyenv i (fspecs:RecdField[]) =

let g = amap.g

fspecs |> Array.mapi (fun j fspec ->

let ilFieldDef = IL.mkILInstanceField(fspec.Name,GenType amap m tyenv fspec.FormalType, None, ILMemberAccess.Public)

// These properties on the "field" of an alternative end up going on a property generated by cu_erase.fs

IlxUnionField

(ilFieldDef.With(customAttrs = mkILCustomAttrs [(mkCompilationMappingAttrWithVariantNumAndSeqNum g (int SourceConstructFlags.Field) i j )])))

and GenUnionRef (amap: ImportMap) m (tcref: TyconRef) =

let g = amap.g

let tycon = tcref.Deref

assert(not tycon.IsTypeAbbrev)

match tycon.UnionTypeInfo with

| None -> failwith "GenUnionRef m"

| Some funion ->

cached funion.CompiledRepresentation (fun () ->

let tyenvinner = TypeReprEnv.ForTycon tycon

match tcref.CompiledRepresentation with

| CompiledTypeRepr.ILAsmOpen _ -> failwith "GenUnionRef m: unexpected ASM tyrep"

| CompiledTypeRepr.ILAsmNamed (tref,_,_) ->

let alternatives =

tycon.UnionCasesArray |> Array.mapi (fun i cspec ->

{ altName=cspec.CompiledName

altCustomAttrs=emptyILCustomAttrs

altFields=GenUnionCaseRef amap m tyenvinner i cspec.RecdFieldsArray })

let nullPermitted = IsUnionTypeWithNullAsTrueValue g tycon

let hasHelpers = ComputeUnionHasHelpers g tcref

let boxity = (if tcref.IsStructOrEnumTycon then ILBoxity.AsValue else ILBoxity.AsObject)

IlxUnionRef(boxity, tref,alternatives,nullPermitted,hasHelpers))

and ComputeUnionHasHelpers g (tcref : TyconRef) =

if tyconRefEq g tcref g.unit_tcr_canon then NoHelpers

elif tyconRefEq g tcref g.list_tcr_canon then SpecialFSharpListHelpers

elif tyconRefEq g tcref g.option_tcr_canon then SpecialFSharpOptionHelpers

else

match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with

| Some(Attrib(_,_,[ AttribBoolArg (b) ],_,_,_,_)) ->

if b then AllHelpers else NoHelpers

| Some (Attrib(_,_,_,_,_,_,m)) ->

errorR(Error(FSComp.SR.ilDefaultAugmentationAttributeCouldNotBeDecoded(),m))

AllHelpers

| _ ->

AllHelpers (* not hiddenRepr *)

and GenUnionSpec amap m tyenv tcref tyargs =

let curef = GenUnionRef amap m tcref

let tinst = GenTypeArgs amap m tyenv tyargs

IlxUnionSpec(curef,tinst)

and GenUnionCaseSpec amap m tyenv (ucref:UnionCaseRef) tyargs =

let cuspec = GenUnionSpec amap m tyenv ucref.TyconRef tyargs

cuspec, ucref.Index

and GenType amap m tyenv ty =

GenTypeAux amap m tyenv VoidNotOK PtrTypesNotOK ty

and GenTypes amap m tyenv tys = List.map (GenType amap m tyenv) tys

and GenTypePermitVoid amap m tyenv ty = (GenTypeAux amap m tyenv VoidOK PtrTypesNotOK ty)

and GenTypesPermitVoid amap m tyenv tys = List.map (GenTypePermitVoid amap m tyenv) tys

and GenTyApp amap m tyenv repr tyargs = GenTyAppAux amap m tyenv repr tyargs

and GenNamedTyApp amap m tyenv tcref tinst = GenNamedTyAppAux amap m tyenv PtrTypesNotOK tcref tinst

and GenReturnType amap m tyenv returnTyOpt =

match returnTyOpt with

| None -> ILType.Void

| Some returnTy ->

let ilTy = GenTypeAux amap m tyenv VoidNotOK(*1*) PtrTypesOK returnTy (*1: generate void from unit, but not accept void *)

GenReadOnlyModReqIfNecessary amap.g returnTy ilTy

and GenParamType amap m tyenv isSlotSig ty =

let ilTy = GenTypeAux amap m tyenv VoidNotOK PtrTypesOK ty

if isSlotSig then

GenReadOnlyModReqIfNecessary amap.g ty ilTy

else

ilTy

and GenParamTypes amap m tyenv isSlotSig tys =

tys |> List.map (GenParamType amap m tyenv isSlotSig)

and GenTypeArgs amap m tyenv tyargs = GenTypeArgsAux amap m tyenv tyargs

let GenericParamHasConstraint (gp: ILGenericParameterDef) =

gp.Constraints.Length <> 0 ||

gp.Variance <> NonVariant ||

gp.HasReferenceTypeConstraint ||

gp.HasNotNullableValueTypeConstraint ||

gp.HasDefaultConstructorConstraint

let GenFieldSpecForStaticField (isInteractive, g, ilContainerTy, vspec:Val, nm, m, cloc, ilTy) =

if isInteractive || HasFSharpAttribute g g.attrib_LiteralAttribute vspec.Attribs then

let fieldName = vspec.CompiledName

let fieldName = if isInteractive then CompilerGeneratedName fieldName else fieldName

mkILFieldSpecInTy (ilContainerTy, fieldName, ilTy)

else

let fieldName = ilxgenGlobalNng.FreshCompilerGeneratedName (nm,m)

let ilFieldContainerTy = mkILTyForCompLoc (CompLocForInitClass cloc)

mkILFieldSpecInTy (ilFieldContainerTy, fieldName, ilTy)

let GenRecdFieldRef m cenv tyenv (rfref:RecdFieldRef) tyargs =

let tyenvinner = TypeReprEnv.ForTycon rfref.Tycon

mkILFieldSpecInTy(GenTyApp cenv.amap m tyenv rfref.TyconRef.CompiledRepresentation tyargs,

ComputeFieldName rfref.Tycon rfref.RecdField,

GenType cenv.amap m tyenvinner rfref.RecdField.FormalType)

let GenExnType amap m tyenv (ecref:TyconRef) = GenTyApp amap m tyenv ecref.CompiledRepresentation []

type ArityInfo = int list

type IlxClosureInfo =

{ cloExpr: Expr

cloName: string

cloArityInfo: ArityInfo

cloILFormalRetTy: ILType

/// An immutable array of free variable descriptions for the closure

cloILFreeVars: IlxClosureFreeVar[]

cloSpec: IlxClosureSpec

cloAttribs: Attribs

cloILGenericParams: IL.ILGenericParameterDefs

cloFreeVars: Val list (* nb. the freevars we actually close over *)

ilCloLambdas: IlxClosureLambdas

(* local type func support *)

/// The free type parameters occuring in the type of the closure (and not just its body)

/// This is used for local type functions, whose contract class must use these types

/// type Contract<'fv> =

/// abstract DirectInvoke : ty['fv]

/// type Implementation<'fv,'fv2> : Contract<'fv> =

/// override DirectInvoke : ty['fv] = expr['fv,'fv2]

///

/// At the callsite we generate

/// unbox ty['fv]

/// callvirt clo.DirectInvoke

localTypeFuncILGenericArgs: ILType list

localTypeFuncContractFreeTypars: Typar list

localTypeFuncDirectILGenericParams: IL.ILGenericParameterDefs

localTypeFuncInternalFreeTypars: Typar list}

type ValStorage =

/// Indicates the value is always null

| Null

/// Indicates the value is stored in a static field.

| StaticField of ILFieldSpec * ValRef * (*hasLiteralAttr:*)bool * ILType * string * ILType * ILMethodRef * ILMethodRef * OptionalShadowLocal

/// Indicates the value is "stored" as a property that recomputes it each time it is referenced. Used for simple constants that do not cause initialization triggers

| StaticProperty of ILMethodSpec * OptionalShadowLocal

/// Indicates the value is "stored" as a IL static method (in a "main" class for a F#

/// compilation unit, or as a member) according to its inferred or specified arity.

| Method of ValReprInfo * ValRef * ILMethodSpec * Range.range * ArgReprInfo list * TType list * ArgReprInfo

/// Indicates the value is stored at the given position in the closure environment accessed via "ldarg 0"

| Env of ILType * int * ILFieldSpec * NamedLocalIlxClosureInfo ref option

/// Indicates that the value is an argument of a method being generated

| Arg of int

/// Indicates that the value is stored in local of the method being generated. NamedLocalIlxClosureInfo is normally empty.

/// It is non-empty for 'local type functions', see comments on definition of NamedLocalIlxClosureInfo.

| Local of int * NamedLocalIlxClosureInfo ref option

and OptionalShadowLocal =

| NoShadowLocal

| ShadowLocal of ValStorage

and NamedLocalIlxClosureInfo =

| NamedLocalIlxClosureInfoGenerator of (IlxGenEnv -> IlxClosureInfo)

| NamedLocalIlxClosureInfoGenerated of IlxClosureInfo

and ModuleStorage =

{ Vals: Lazy<NameMap<ValStorage>>

SubModules: Lazy<NameMap<ModuleStorage>> }

and BranchCallItem =

| BranchCallClosure of ArityInfo

| BranchCallMethod of

// Argument counts for compiled form of F# method or value

ArityInfo *

// Arg infos for compiled form of F# method or value

(TType * ArgReprInfo) list list *

// Typars for F# method or value

Tast.Typars *

// Typars for F# method or value

int *

// num obj args

int

and Mark =

| Mark of ILCodeLabel (* places we can branch to *)

member x.CodeLabel = (let (Mark(lab)) = x in lab)

and IlxGenEnv =

{ tyenv: TypeReprEnv

someTypeInThisAssembly: ILType

isFinalFile: bool

/// Where to place the stuff we're currently generating

cloc: CompileLocation

/// Hiding information down the signature chain, used to compute what's public to the assembly

sigToImplRemapInfo: (Remap * SignatureHidingInfo) list

/// All values in scope

valsInScope: ValMap<Lazy<ValStorage>>

/// For optimizing direct tail recursion to a loop - mark says where to branch to. Length is 0 or 1.

/// REVIEW: generalize to arbitrary nested local loops??

innerVals: (ValRef * (BranchCallItem * Mark)) list

/// Full list of enclosing bound values. First non-compiler-generated element is used to help give nice names for closures and other expressions.

letBoundVars: ValRef list

/// The set of IL local variable indexes currently in use by lexically scoped variables, to allow reuse on different branches.

/// Really an integer set.

liveLocals: IntMap<unit>

/// Are we under the scope of a try, catch or finally? If so we can't tailcall. SEH = structured exception handling

withinSEH: bool }

let ReplaceTyenv tyenv (eenv: IlxGenEnv) = {eenv with tyenv = tyenv }

let EnvForTypars tps eenv = {eenv with tyenv = TypeReprEnv.ForTypars tps }

let AddTyparsToEnv typars (eenv: IlxGenEnv) = {eenv with tyenv = eenv.tyenv.Add typars}

let AddSignatureRemapInfo _msg (rpi, mhi) eenv =

{ eenv with sigToImplRemapInfo = (mkRepackageRemapping rpi,mhi) :: eenv.sigToImplRemapInfo }

let OutputStorage (pps: TextWriter) s =

match s with

| StaticField _ -> pps.Write "(top)"

| StaticProperty _ -> pps.Write "(top)"

| Method _ -> pps.Write "(top)"

| Local _ -> pps.Write "(local)"

| Arg _ -> pps.Write "(arg)"

| Env _ -> pps.Write "(env)"

| Null -> pps.Write "(null)"

let AddStorageForVal (g: TcGlobals) (v,s) eenv =

let eenv = { eenv with valsInScope = eenv.valsInScope.Add v s }

// If we're compiling fslib then also bind the value as a non-local path to

// allow us to resolve the compiler-non-local-references that arise from env.fs

//

// Do this by generating a fake "looking from the outside in" non-local value reference for

// v, dereferencing it to find the corresponding signature Val, and adding an entry for the signature val.

//

// A similar code path exists in ilxgen.fs for the tables of "optimization data" for values

if g.compilingFslib then

// Passing an empty remap is sufficient for FSharp.Core.dll because it turns out the remapped type signature can

// still be resolved.

match tryRescopeVal g.fslibCcu Remap.Empty v with

| None -> eenv

| Some vref ->

match vref.TryDeref with

| ValueNone ->

//let msg = sprintf "could not dereference external value reference to something in FSharp.Core.dll during code generation, v.MangledName = '%s', v.Range = %s" v.MangledName (stringOfRange v.Range)

//System.Diagnostics.Debug.Assert(false, msg)

eenv

| ValueSome gv ->

{ eenv with valsInScope = eenv.valsInScope.Add gv s }

else

eenv

let AddStorageForLocalVals g vals eenv = List.foldBack (fun (v,s) acc -> AddStorageForVal g (v,notlazy s) acc) vals eenv

open Microsoft.FSharp.Compiler.AbstractIL

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library

let StorageForVal m v eenv =

let v =

try eenv.valsInScope.[v]

with :? KeyNotFoundException ->

assert false

errorR(Error(FSComp.SR.ilUndefinedValue(showL(vspecAtBindL v)),m))

notlazy (Arg 668(* random value for post-hoc diagnostic analysis on generated tree *) )

v.Force()

let StorageForValRef m (v: ValRef) eenv = StorageForVal m v.Deref eenv

let IsValRefIsDllImport g (vref:ValRef) =

vref.Attribs |> HasFSharpAttributeOpt g g.attrib_DllImportAttribute

let GetMethodSpecForMemberVal amap g (memberInfo:ValMemberInfo) (vref:ValRef) =

let m = vref.Range

let tps,curriedArgInfos,returnTy,retInfo =

assert(vref.ValReprInfo.IsSome)

GetTopValTypeInCompiledForm g (Option.get vref.ValReprInfo) vref.Type m

let tyenvUnderTypars = TypeReprEnv.ForTypars tps

let flatArgInfos = List.concat curriedArgInfos

let isCtor = (memberInfo.MemberFlags.MemberKind = MemberKind.Constructor)

let cctor = (memberInfo.MemberFlags.MemberKind = MemberKind.ClassConstructor)

let parentTcref = vref.TopValDeclaringEntity

let parentTypars = parentTcref.TyparsNoRange

let numParentTypars = parentTypars.Length

if tps.Length < numParentTypars then error(InternalError("CodeGen check: type checking did not ensure that this method is sufficiently generic", m))

let ctps,mtps = List.splitAt numParentTypars tps

let isCompiledAsInstance = ValRefIsCompiledAsInstanceMember g vref

let ilActualRetTy =

let ilRetTy = GenReturnType amap m tyenvUnderTypars returnTy

if isCtor || cctor then ILType.Void else ilRetTy

let ilTy = GenType amap m tyenvUnderTypars (mkAppTy parentTcref (List.map mkTyparTy ctps))

if isCompiledAsInstance || isCtor then

// Find the 'this' argument type if any

let thisTy,flatArgInfos =

if isCtor then (GetFSharpViewOfReturnType g returnTy),flatArgInfos

else

match flatArgInfos with

| [] -> error(InternalError("This instance method '" + vref.LogicalName + "' has no arguments", m))

| (h,_):: t -> h,t

let thisTy = if isByrefTy g thisTy then destByrefTy g thisTy else thisTy

let thisArgTys = argsOfAppTy g thisTy

if numParentTypars <> thisArgTys.Length then

warning(InternalError(sprintf "CodeGen check: type checking did not quantify the correct number of type variables for this method, #parentTypars = %d, #mtps = %d, #thisArgTys = %d" numParentTypars mtps.Length thisArgTys.Length,m))

else

List.iter2

(fun gtp ty2 ->

if not (typeEquiv g (mkTyparTy gtp) ty2) then

warning(InternalError("CodeGen check: type checking did not quantify the correct type variables for this method: generalization list contained " + gtp.Name + "#" + string gtp.Stamp + " and list from 'this' pointer contained " + (showL(typeL ty2)), m)))

ctps

thisArgTys

let methodArgTys,paramInfos = List.unzip flatArgInfos

let isSlotSig = memberInfo.MemberFlags.IsDispatchSlot || memberInfo.MemberFlags.IsOverrideOrExplicitImpl

let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars isSlotSig methodArgTys

let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy mtps)

let mspec = mkILInstanceMethSpecInTy (ilTy,vref.CompiledName,ilMethodArgTys,ilActualRetTy,ilMethodInst)

mspec,ctps,mtps,paramInfos,retInfo,methodArgTys

else

let methodArgTys,paramInfos = List.unzip flatArgInfos

let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars false methodArgTys

let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy mtps)

let mspec = mkILStaticMethSpecInTy (ilTy,vref.CompiledName,ilMethodArgTys,ilActualRetTy,ilMethodInst)

mspec,ctps,mtps,paramInfos,retInfo,methodArgTys

let ComputeFieldSpecForVal(optIntraAssemblyInfo:IlxGenIntraAssemblyInfo option, isInteractive, g, ilTyForProperty, vspec:Val, nm, m, cloc, ilTy, ilGetterMethRef) =

assert vspec.IsCompiledAsTopLevel

let generate() = GenFieldSpecForStaticField (isInteractive, g, ilTyForProperty, vspec, nm, m, cloc, ilTy)

match optIntraAssemblyInfo with

| None -> generate()

| Some intraAssemblyInfo ->

if vspec.IsMutable && vspec.IsCompiledAsTopLevel && isStructTy g vspec.Type then

let ok, res = intraAssemblyInfo.StaticFieldInfo.TryGetValue ilGetterMethRef

if ok then

res

else

let res = generate()

intraAssemblyInfo.StaticFieldInfo.[ilGetterMethRef] <- res

res

else

generate()

let IsValCompiledAsMethod g (v:Val) =

match v.ValReprInfo with

| None -> false

| Some topValInfo ->

not (isUnitTy g v.Type && not v.IsMemberOrModuleBinding && not v.IsMutable) &&

not v.IsCompiledAsStaticPropertyWithoutField &&

match GetTopValTypeInFSharpForm g topValInfo v.Type v.Range with

| [],[],_,_ when not v.IsMember -> false

| _ -> true

let ComputeStorageForTopVal (amap, g, optIntraAssemblyInfo:IlxGenIntraAssemblyInfo option, isInteractive, optShadowLocal, vref:ValRef, cloc) =

if isUnitTy g vref.Type && not vref.IsMemberOrModuleBinding && not vref.IsMutable then

Null

else

let topValInfo =

match vref.ValReprInfo with

| None -> error(InternalError("ComputeStorageForTopVal: no arity found for " + showL(valRefL vref),vref.Range))

| Some a -> a

let m = vref.Range

let nm = vref.CompiledName

if vref.Deref.IsCompiledAsStaticPropertyWithoutField then

let nm = "get_"+nm

let tyenvUnderTypars = TypeReprEnv.ForTypars []

let ilRetTy = GenType amap m tyenvUnderTypars vref.Type

let ty = mkILTyForCompLoc cloc

let mspec = mkILStaticMethSpecInTy (ty, nm, [], ilRetTy, [])

StaticProperty (mspec, optShadowLocal)

else

// Determine when a static field is required.

//

// REVIEW: This call to GetTopValTypeInFSharpForm is only needed to determine if this is a (type) function or a value

// We should just look at the arity

match GetTopValTypeInFSharpForm g topValInfo vref.Type vref.Range with

| [],[], returnTy,_ when not vref.IsMember ->

// Mutable and literal static fields must have stable names and live in the "public" location

// See notes on GenFieldSpecForStaticField above.

let vspec = vref.Deref

let ilTy = GenType amap m TypeReprEnv.Empty returnTy (* TypeReprEnv.Empty ok: not a field in a generic class *)

let ilTyForProperty = mkILTyForCompLoc cloc

let attribs = vspec.Attribs

let hasLiteralAttr = HasFSharpAttribute g g.attrib_LiteralAttribute attribs

let ilTypeRefForProperty = ilTyForProperty.TypeRef

let ilGetterMethRef = mkILMethRef (ilTypeRefForProperty, ILCallingConv.Static, "get_"+nm, 0, [], ilTy)

let ilSetterMethRef = mkILMethRef (ilTypeRefForProperty, ILCallingConv.Static, "set_"+nm, 0, [ilTy], ILType.Void)

let fspec = ComputeFieldSpecForVal(optIntraAssemblyInfo, isInteractive, g, ilTyForProperty, vspec, nm, m, cloc, ilTy, ilGetterMethRef)

StaticField (fspec, vref, hasLiteralAttr, ilTyForProperty, nm, ilTy, ilGetterMethRef, ilSetterMethRef, optShadowLocal)

| _ ->

match vref.MemberInfo with

| Some memberInfo when not vref.IsExtensionMember ->

let mspec,_,_,paramInfos,retInfo,methodArgTys = GetMethodSpecForMemberVal amap g memberInfo vref

Method (topValInfo, vref, mspec, m, paramInfos, methodArgTys, retInfo)

| _ ->

let (tps, curriedArgInfos, returnTy, retInfo) = GetTopValTypeInCompiledForm g topValInfo vref.Type m

let tyenvUnderTypars = TypeReprEnv.ForTypars tps

let (methodArgTys,paramInfos) = curriedArgInfos |> List.concat |> List.unzip

let ilMethodArgTys = GenParamTypes amap m tyenvUnderTypars false methodArgTys

let ilRetTy = GenReturnType amap m tyenvUnderTypars returnTy

let ilLocTy = mkILTyForCompLoc cloc

let ilMethodInst = GenTypeArgs amap m tyenvUnderTypars (List.map mkTyparTy tps)

let mspec = mkILStaticMethSpecInTy (ilLocTy, nm, ilMethodArgTys, ilRetTy, ilMethodInst)

Method (topValInfo, vref, mspec, m, paramInfos, methodArgTys, retInfo)

let ComputeAndAddStorageForLocalTopVal (amap, g, intraAssemblyFieldTable, isInteractive, optShadowLocal) cloc (v:Val) eenv =

let storage = ComputeStorageForTopVal (amap, g, Some intraAssemblyFieldTable, isInteractive, optShadowLocal, mkLocalValRef v, cloc)

AddStorageForVal g (v,notlazy storage) eenv

let ComputeStorageForNonLocalTopVal amap g cloc modref (v:Val) =

match v.ValReprInfo with

| None -> error(InternalError("ComputeStorageForNonLocalTopVal, expected an arity for " + v.LogicalName,v.Range))

| Some _ -> ComputeStorageForTopVal (amap, g, None, false, NoShadowLocal, mkNestedValRef modref v, cloc)

let rec ComputeStorageForNonLocalModuleOrNamespaceRef amap g cloc acc (modref:ModuleOrNamespaceRef) (modul:ModuleOrNamespace) =

let acc =

(acc, modul.ModuleOrNamespaceType.ModuleAndNamespaceDefinitions) ||> List.fold (fun acc smodul ->

ComputeStorageForNonLocalModuleOrNamespaceRef amap g (CompLocForSubModuleOrNamespace cloc smodul) acc (modref.NestedTyconRef smodul) smodul)

let acc =

(acc, modul.ModuleOrNamespaceType.AllValsAndMembers) ||> Seq.fold (fun acc v ->

AddStorageForVal g (v, lazy (ComputeStorageForNonLocalTopVal amap g cloc modref v)) acc)

acc

let ComputeStorageForExternalCcu amap g eenv (ccu:CcuThunk) =

if not ccu.IsFSharp then eenv else

let cloc = CompLocForCcu ccu

let eenv =

List.foldBack

(fun smodul acc ->

let cloc = CompLocForSubModuleOrNamespace cloc smodul

let modref = mkNonLocalCcuRootEntityRef ccu smodul

ComputeStorageForNonLocalModuleOrNamespaceRef amap g cloc acc modref smodul)

ccu.RootModulesAndNamespaces

eenv

let eenv =

let eref = ERefNonLocalPreResolved ccu.Contents (mkNonLocalEntityRef ccu [| |])

(eenv, ccu.Contents.ModuleOrNamespaceType.AllValsAndMembers) ||> Seq.fold (fun acc v ->

AddStorageForVal g (v, lazy (ComputeStorageForNonLocalTopVal amap g cloc eref v)) acc)

eenv

let rec AddBindingsForLocalModuleType allocVal cloc eenv (mty:ModuleOrNamespaceType) =

let eenv = List.fold (fun eenv submodul -> AddBindingsForLocalModuleType allocVal (CompLocForSubModuleOrNamespace cloc submodul) eenv submodul.ModuleOrNamespaceType) eenv mty.ModuleAndNamespaceDefinitions

let eenv = Seq.fold (fun eenv v -> allocVal cloc v eenv) eenv mty.AllValsAndMembers

eenv

let AddExternalCcusToIlxGenEnv amap g eenv ccus = List.fold (ComputeStorageForExternalCcu amap g) eenv ccus

let AddBindingsForTycon allocVal (cloc:CompileLocation) (tycon:Tycon) eenv =

let unrealizedSlots =

if tycon.IsFSharpObjectModelTycon

then tycon.FSharpObjectModelTypeInfo.fsobjmodel_vslots

else []

(eenv,unrealizedSlots) ||> List.fold (fun eenv vref -> allocVal cloc vref.Deref eenv)

let rec AddBindingsForModuleDefs allocVal (cloc:CompileLocation) eenv mdefs =

List.fold (AddBindingsForModuleDef allocVal cloc) eenv mdefs

and AddBindingsForModuleDef allocVal cloc eenv x =

match x with

| TMDefRec(_isRec,tycons,mbinds,_) ->

(* Virtual don't have 'let' bindings and must be added to the environment *)

let eenv = List.foldBack (AddBindingsForTycon allocVal cloc) tycons eenv

let eenv = List.foldBack (AddBindingsForModule allocVal cloc) mbinds eenv

eenv