Permalink
Switch branches/tags
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
7154 lines (6034 sloc) 369 KB
// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information.
//--------------------------------------------------------------------------
// The ILX generator.
//--------------------------------------------------------------------------
module internal Microsoft.FSharp.Compiler.IlxGen
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
//--------------------------------------------------------------------------
// misc
//--------------------------------------------------------------------------
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)
/// Make a method that simply loads a field
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
// Approximation for purposes of optimization and giving a warning when compiling definition-only files as EXEs
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 ()
// We can't tailcall to methods taking byrefs. This helper helps search for them
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
//--------------------------------------------------------------------------
// Statistics
//--------------------------------------------------------------------------
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)"
/// Non-local information related to internals of code generation within an assembly
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> }
//--------------------------------------------------------------------------
/// Indicates how the generated IL code is ultimately emitted
type IlxGenBackend =
| IlWriteBackend
| IlReflectBackend
[<NoEquality; NoComparison>]
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 }
/// Compilation environment for compiling a fragment of an assembly
[<NoEquality; NoComparison>]
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
//--------------------------------------------------------------------------
// CompileLocation
//--------------------------------------------------------------------------
/// compilation location = path to a ccu, namespace or class
/// Referencing other stuff, and descriptions of where items are to be placed
/// within the generated IL namespace/typespace. This should be cleaned up.
type CompileLocation =
{ clocScope: IL.ILScopeRef
clocTopImplQualifiedName: string
clocNamespace: string option
clocEncl: string list
clocQualifiedNameOfFile : string }
//--------------------------------------------------------------------------
// Access this and other assemblies
//--------------------------------------------------------------------------
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
// Under --publicasinternal change types from Public to Private (internal for types)
let ComputePublicTypeAccess() = ILTypeDefAccess.Public
let ComputeTypeAccess (tref:ILTypeRef) hidden =
match tref.Enclosing with
| [] -> if hidden then ILTypeDefAccess.Private else ComputePublicTypeAccess()
| _ -> ILTypeDefAccess.Nested (ComputeMemberAccess hidden)
//--------------------------------------------------------------------------
// TypeReprEnv
//--------------------------------------------------------------------------
/// Indicates how type parameters are mapped to IL type variables
[<NoEquality; NoComparison>]
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
//--------------------------------------------------------------------------
// Generate type references
//--------------------------------------------------------------------------
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))
#endif
/// When generating parameter and return types generate precise .NET IL pointer types.
/// These can't be generated for generic instantiations, since .NET generics doesn't
/// permit this. But for 'naked' values (locals, parameters, return values etc.) machine
/// integer values and native pointer values are compatible (though the code is unverifiable).
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
/// Generate "modreq([mscorlib]System.Runtime.InteropServices.InAttribute)" on inref types.
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))
| _ ->
#endif
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
#else
ignore voidOK
#endif
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
//--------------------------------------------------------------------------
// Generate ILX references to closures, classunions etc. given a tyenv
//--------------------------------------------------------------------------
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
/// IL void types are only generated for return types
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
// Static fields generally go in a private InitializationCodeAndBackingFields section. This is to ensure all static
// fields are initialized only in their class constructors (we generate one primary
// cctor for each file to ensure initialization coherence across the file, regardless
// of how many modules are in the file). This means F# passes an extra check applied by SQL Server when it
// verifies stored procedures: SQL Server checks that all 'initionly' static fields are only initialized from
// their own class constructor.
//
// However, mutable static fields must be accessible across compilation units. This means we place them in their "natural" location
// which may be in a nested module etc. This means mutable static fields can't be used in code to be loaded by SQL Server.
//
// Computes the location where the static field for a value lives.
// - Literals go in their type/module.
// - For interactive code, we always place fields in their type/module with an accurate name
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 []
//--------------------------------------------------------------------------
// Closure summaries
//--------------------------------------------------------------------------
type ArityInfo = int list
[<NoEquality; NoComparison>]
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}
//--------------------------------------------------------------------------
// Representation of term declarations = Environments for compiling expressions.
//--------------------------------------------------------------------------
[<NoEquality; NoComparison>]
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
/// The representation of a NamedLocalClosure is based on a cloinfo. However we can't generate a cloinfo until we've
/// decided the representations of other items in the recursive set. Hence we use two phases to decide representations in
/// a recursive set. Yuck.
and NamedLocalIlxClosureInfo =
| NamedLocalIlxClosureInfoGenerator of (IlxGenEnv -> IlxClosureInfo)
| NamedLocalIlxClosureInfoGenerated of IlxClosureInfo
and ModuleStorage =
{ Vals: Lazy<NameMap<ValStorage>>
SubModules: Lazy<NameMap<ModuleStorage>> }
/// BranchCallItems are those where a call to the value can be implemented as
/// a branch. At the moment these are only used for generating branch calls back to
/// the entry label of the method currently being generated.
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 }
//--------------------------------------------------------------------------
// Print eenv
//--------------------------------------------------------------------------
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)"
//--------------------------------------------------------------------------
// Augment eenv with values
//--------------------------------------------------------------------------
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
//--------------------------------------------------------------------------
// Lookup 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
//--------------------------------------------------------------------------
// Imported modules and the environment
//
// How a top level value is represented depends on its type. If it's a
// function or is polymorphic, then it gets represented as a
// method (possibly and instance method). Otherwise it gets represented as a
// static field.
//--------------------------------------------------------------------------
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
// Generate the ILFieldSpec for a top-level value
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
// This called via 2 routes.
// (a) ComputeAndAddStorageForLocalTopVal
// (b) ComputeStorageForNonLocalTopVal
//
/// This function decides the storage for the val.
/// The decision is based on arityInfo.
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
| TMDefLet(bind,_) ->
allocVal cloc bind.Var eenv
| TMDefDo _ ->
eenv
| TMAbstract(ModuleOrNamespaceExprWithSig(mtyp, _, _)) ->
AddBindingsForLocalModuleType allocVal cloc eenv mtyp
| TMDefs(mdefs) ->
AddBindingsForModuleDefs allocVal cloc eenv mdefs
and AddBindingsForModule allocVal cloc x eenv =
match x with
| ModuleOrNamespaceBinding.Binding bind ->
allocVal cloc bind.Var eenv
| ModuleOrNamespaceBinding.Module (mspec, mdef) ->
let cloc =
if mspec.IsNamespace then cloc
else CompLocForFixedModule cloc.clocQualifiedNameOfFile cloc.clocTopImplQualifiedName mspec
AddBindingsForModuleDef allocVal cloc eenv mdef
and AddBindingsForModuleTopVals _g allocVal _cloc eenv vs =
List.foldBack allocVal vs eenv
// Put the partial results for a generated fragment (i.e. a part of a CCU generated by FSI)
// into the stored results for the whole CCU.
// isIncrementalFragment = true --> "typed input"
// isIncrementalFragment = false --> "#load"
let AddIncrementalLocalAssemblyFragmentToIlxGenEnv (amap:ImportMap, isIncrementalFragment, g, ccu, fragName, intraAssemblyInfo, eenv, typedImplFiles) =
let cloc = CompLocForFragment fragName ccu
let allocVal = ComputeAndAddStorageForLocalTopVal (amap, g, intraAssemblyInfo, true, NoShadowLocal)
(eenv, typedImplFiles) ||> List.fold (fun eenv (TImplFile(qname,_,mexpr,_,_)) ->
let cloc = { cloc with clocTopImplQualifiedName = qname.Text }
if isIncrementalFragment then
match mexpr with
| ModuleOrNamespaceExprWithSig(_, mdef, _) -> AddBindingsForModuleDef allocVal cloc eenv mdef
else
AddBindingsForLocalModuleType allocVal cloc eenv mexpr.Type)
//--------------------------------------------------------------------------
// Generate debugging marks
//--------------------------------------------------------------------------
let GenILSourceMarker (g: TcGlobals) (m:range) =
ILSourceMarker.Create(document=g.memoize_file m.FileIndex,
line=m.StartLine,
/// NOTE: .NET && VS measure first column as column 1
column= m.StartColumn+1,
endLine= m.EndLine,
endColumn=m.EndColumn+1)
let GenPossibleILSourceMarker cenv m =
if cenv.opts.generateDebugSymbols then
Some (GenILSourceMarker cenv.g m )
else
None
//--------------------------------------------------------------------------
// Helpers for merging property definitions
//--------------------------------------------------------------------------
let HashRangeSorted (ht: IDictionary<_, (int * _)>) =
[ for KeyValue(_k,v) in ht -> v ] |> List.sortBy fst |> List.map snd
let MergeOptions m o1 o2 =
match o1,o2 with
| Some x, None | None, Some x -> Some x
| None, None -> None
| Some x, Some _ ->
#if DEBUG
// This warning fires on some code that also triggers this warning:
// warning(Error("The implementation of a specified generic interface required a method implementation not fully supported by F# Interactive. In the unlikely event that the resulting class fails to load then compile the interface type into a statically-compiled DLL and reference it using '#r'",m))
// The code is OK so we don't print this.
errorR(InternalError("MergeOptions: two values given",m))
#else
ignore m
#endif
Some x
let MergePropertyPair m (pd: ILPropertyDef) (pdef: ILPropertyDef) =
pd.With(getMethod=MergeOptions m pd.GetMethod pdef.GetMethod,
setMethod=MergeOptions m pd.SetMethod pdef.SetMethod)
type PropKey = PropKey of string * ILTypes * ILThisConvention
let AddPropertyDefToHash (m:range) (ht:Dictionary<PropKey,(int * ILPropertyDef)>) (pdef: ILPropertyDef) =
let nm = PropKey(pdef.Name, pdef.Args, pdef.CallingConv)
match ht.TryGetValue(nm) with
| true, (idx, pd) ->
ht.[nm] <- (idx, MergePropertyPair m pd pdef)
| _ ->
ht.[nm] <- (ht.Count, pdef)
/// Merge a whole group of properties all at once
let MergePropertyDefs m ilPropertyDefs =
let ht = new Dictionary<_,_>(3,HashIdentity.Structural)
ilPropertyDefs |> List.iter (AddPropertyDefToHash m ht)
HashRangeSorted ht
//--------------------------------------------------------------------------
// Buffers for compiling modules. The entire assembly gets compiled via an AssemblyBuilder
//--------------------------------------------------------------------------
/// Information collected imperatively for each type definition
type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) =
let gmethods = new ResizeArray<ILMethodDef>(0)
let gfields = new ResizeArray<ILFieldDef>(0)
let gproperties : Dictionary<PropKey,(int * ILPropertyDef)> = new Dictionary<_,_>(3,HashIdentity.Structural)
let gevents = new ResizeArray<ILEventDef>(0)
let gnested = new TypeDefsBuilder()
member b.Close() =
tdef.With(methods = mkILMethods (tdef.Methods.AsList @ ResizeArray.toList gmethods),
fields = mkILFields (tdef.Fields.AsList @ ResizeArray.toList gfields),
properties = mkILProperties (tdef.Properties.AsList @ HashRangeSorted gproperties ),
events = mkILEvents (tdef.Events.AsList @ ResizeArray.toList gevents),
nestedTypes = mkILTypeDefs (tdef.NestedTypes.AsList @ gnested.Close()))
member b.AddEventDef(edef) = gevents.Add edef
member b.AddFieldDef(ilFieldDef) = gfields.Add ilFieldDef
member b.AddMethodDef(ilMethodDef) =
let discard =
match tdefDiscards with
| Some (mdefDiscard, _) -> mdefDiscard ilMethodDef
| None -> false
if not discard then
gmethods.Add ilMethodDef
member b.NestedTypeDefs = gnested
member b.GetCurrentFields() = gfields |> Seq.readonly
/// Merge Get and Set property nodes, which we generate independently for F# code
/// when we come across their corresponding methods.
member b.AddOrMergePropertyDef(pdef,m) =
let discard =
match tdefDiscards with
| Some (_, pdefDiscard) -> pdefDiscard pdef
| None -> false
if not discard then
AddPropertyDefToHash m gproperties pdef
member b.PrependInstructionsToSpecificMethodDef(cond,instrs,tag) =
match ResizeArray.tryFindIndex cond gmethods with
| Some idx -> gmethods.[idx] <- prependInstrsToMethod instrs gmethods.[idx]
| None -> gmethods.Add(mkILClassCtor (mkMethodBody (false,[],1,nonBranchingInstrsToCode instrs,tag)))
and TypeDefsBuilder() =
let tdefs : Internal.Utilities.Collections.HashMultiMap<string, (int * (TypeDefBuilder * bool))> = HashMultiMap(0, HashIdentity.Structural)
let mutable countDown = System.Int32.MaxValue
member b.Close() =
//The order we emit type definitions is not deterministic since it is using the reverse of a range from a hash table. We should use an approximation of source order.
// Ideally it shouldn't matter which order we use.
// However, for some tests FSI generated code appears sensitive to the order, especially for nested types.
[ for (b, eliminateIfEmpty) in HashRangeSorted tdefs do
let tdef = b.Close()
// Skip the <PrivateImplementationDetails$> type if it is empty
if not eliminateIfEmpty
|| not tdef.NestedTypes.AsList.IsEmpty
|| not tdef.Fields.AsList.IsEmpty
|| not tdef.Events.AsList.IsEmpty
|| not tdef.Properties.AsList.IsEmpty
|| not tdef.Methods.AsList.IsEmpty then
yield tdef ]
member b.FindTypeDefBuilder(nm) =
try tdefs.[nm] |> snd |> fst
with :? KeyNotFoundException -> failwith ("FindTypeDefBuilder: " + nm + " not found")
member b.FindNestedTypeDefsBuilder(path) =
List.fold (fun (acc:TypeDefsBuilder) x -> acc.FindTypeDefBuilder(x).NestedTypeDefs) b path
member b.FindNestedTypeDefBuilder(tref:ILTypeRef) =
b.FindNestedTypeDefsBuilder(tref.Enclosing).FindTypeDefBuilder(tref.Name)
member b.AddTypeDef(tdef:ILTypeDef, eliminateIfEmpty, addAtEnd, tdefDiscards) =
let idx = if addAtEnd then (countDown <- countDown - 1; countDown) else tdefs.Count
tdefs.Add (tdef.Name, (idx, (new TypeDefBuilder(tdef, tdefDiscards), eliminateIfEmpty)))
/// Assembly generation buffers
type AssemblyBuilder(cenv:cenv) as mgbuf =
// The Abstract IL table of types
let gtdefs= new TypeDefsBuilder()
// The definitions of top level values, as quotations.
let mutable reflectedDefinitions : System.Collections.Generic.Dictionary<Tast.Val,(string * int * Expr)> = System.Collections.Generic.Dictionary(HashIdentity.Reference)
// A memoization table for generating value types for big constant arrays
let vtgenerator=
new MemoizationTable<(CompileLocation * int) , ILTypeSpec>
((fun (cloc,size) ->
let name = CompilerGeneratedName ("T" + string(newUnique()) + "_" + string size + "Bytes") // Type names ending ...$T<unique>_37Bytes
let vtdef = mkRawDataValueTypeDef cenv.g.iltyp_ValueType (name,size,0us)
let vtref = NestedTypeRefForCompLoc cloc vtdef.Name
let vtspec = mkILTySpec(vtref,[])
let vtdef = vtdef.WithAccess(ComputeTypeAccess vtref true)
mgbuf.AddTypeDef(vtref, vtdef, false, true, None)
vtspec),
keyComparer=HashIdentity.Structural)
let mutable explicitEntryPointInfo : ILTypeRef option = None
/// static init fields on script modules.
let mutable scriptInitFspecs : (ILFieldSpec * range) list = []
member mgbuf.AddScriptInitFieldSpec(fieldSpec,range) =
scriptInitFspecs <- (fieldSpec,range) :: scriptInitFspecs
/// This initializes the script in #load and fsc command-line order causing their
/// sideeffects to be executed.
member mgbuf.AddInitializeScriptsInOrderToEntryPoint() =
// Get the entry point and initialized any scripts in order.
match explicitEntryPointInfo with
| Some tref ->
let IntializeCompiledScript(fspec,m) =
mgbuf.AddExplicitInitToSpecificMethodDef((fun (md:ILMethodDef) -> md.IsEntryPoint), tref, fspec, GenPossibleILSourceMarker cenv m, [], [])
scriptInitFspecs |> List.iter IntializeCompiledScript
| None -> ()
member mgbuf.GenerateRawDataValueType(cloc,size) =
// Byte array literals require a ValueType of size the required number of bytes.
// With fsi.exe, S.R.Emit TypeBuilder CreateType has restrictions when a ValueType VT is nested inside a type T, and T has a field of type VT.
// To avoid this situation, these ValueTypes are generated under the private implementation rather than in the current cloc. [was bug 1532].
let cloc = CompLocForPrivateImplementationDetails cloc
vtgenerator.Apply((cloc,size))
member mgbuf.AddTypeDef(tref:ILTypeRef, tdef, eliminateIfEmpty, addAtEnd, tdefDiscards) =
gtdefs.FindNestedTypeDefsBuilder(tref.Enclosing).AddTypeDef(tdef, eliminateIfEmpty, addAtEnd, tdefDiscards)
member mgbuf.GetCurrentFields(tref:ILTypeRef) =
gtdefs.FindNestedTypeDefBuilder(tref).GetCurrentFields()
member mgbuf.AddReflectedDefinition(vspec : Tast.Val,expr) =
// preserve order by storing index of item
let n = reflectedDefinitions.Count
reflectedDefinitions.Add(vspec, (vspec.CompiledName, n, expr))
member mgbuf.ReplaceNameOfReflectedDefinition(vspec, newName) =
match reflectedDefinitions.TryGetValue vspec with
| true, (name, n, expr) when name <> newName -> reflectedDefinitions.[vspec] <- (newName, n, expr)
| _ -> ()
member mgbuf.AddMethodDef(tref:ILTypeRef,ilMethodDef) =
gtdefs.FindNestedTypeDefBuilder(tref).AddMethodDef(ilMethodDef)
if ilMethodDef.IsEntryPoint then
explicitEntryPointInfo <- Some(tref)
member mgbuf.AddExplicitInitToSpecificMethodDef(cond,tref,fspec,sourceOpt,feefee,seqpt) =
// Authoring a .cctor with effects forces the cctor for the 'initialization' module by doing a dummy store & load of a field
// Doing both a store and load keeps FxCop happier because it thinks the field is useful
let instrs =
[ yield! (if condition "NO_ADD_FEEFEE_TO_CCTORS" then [] elif condition "ADD_SEQPT_TO_CCTORS" then seqpt else feefee) // mark start of hidden code
yield mkLdcInt32 0
yield mkNormalStsfld fspec
yield mkNormalLdsfld fspec
yield AI_pop]
gtdefs.FindNestedTypeDefBuilder(tref).PrependInstructionsToSpecificMethodDef(cond,instrs,sourceOpt)
member mgbuf.AddEventDef(tref,edef) =
gtdefs.FindNestedTypeDefBuilder(tref).AddEventDef(edef)
member mgbuf.AddFieldDef(tref,ilFieldDef) =
gtdefs.FindNestedTypeDefBuilder(tref).AddFieldDef(ilFieldDef)
member mgbuf.AddOrMergePropertyDef(tref,pdef,m) =
gtdefs.FindNestedTypeDefBuilder(tref).AddOrMergePropertyDef(pdef,m)
member mgbuf.Close() =
// old implementation adds new element to the head of list so result was accumulated in reversed order
let orderedReflectedDefinitions =
[for (KeyValue(vspec, (name, n, expr))) in reflectedDefinitions -> n, ((name,vspec), expr)]
|> List.sortBy (fst >> (~-)) // invert the result to get 'order-by-descending' behavior (items in list are 0..* so we don't need to worry about int.MinValue)
|> List.map snd
gtdefs.Close(), orderedReflectedDefinitions
member mgbuf.cenv = cenv
member mgbuf.GetExplicitEntryPointInfo() = explicitEntryPointInfo
/// Record the types of the things on the evaluation stack.
/// Used for the few times we have to flush the IL evaluation stack and to compute maxStack.
type Pushes = ILType list
type Pops = int
let pop (i:int) : Pops = i
let Push tys : Pushes = tys
let Push0 = Push []
let FeeFee (cenv:cenv) = (if cenv.opts.testFlagEmitFeeFeeAs100001 then 100001 else 0x00feefee)
let FeeFeeInstr (cenv:cenv) doc =
I_seqpoint (ILSourceMarker.Create(document = doc,
line = FeeFee cenv,
column = 0,
endLine = FeeFee cenv,
endColumn = 0))
/// Buffers for IL code generation
type CodeGenBuffer(m:range,
mgbuf: AssemblyBuilder,
methodName,
alreadyUsedArgs:int,
alreadyUsedLocals:int) =
let locals = new ResizeArray<((string * (Mark * Mark)) list * ILType * bool)>(10)
let codebuf = new ResizeArray<ILInstr>(200)
let exnSpecs = new ResizeArray<ILExceptionSpec>(10)
// Keep track of the current stack so we can spill stuff when we hit a "try" when some stuff
// is on the stack.
let mutable stack: ILType list = []
let mutable nstack = 0
let mutable maxStack = 0
let mutable hasSequencePoints = false
let mutable anyDocument = None // we collect an arbitrary document in order to emit the header FeeFee if needed
let codeLabelToPC : Dictionary<ILCodeLabel,int> = new Dictionary<_,_>(10)
let codeLabelToCodeLabel : Dictionary<ILCodeLabel,ILCodeLabel> = new Dictionary<_,_>(10)
let rec lab2pc n lbl =
if n = System.Int32.MaxValue then error(InternalError("recursive label graph",m))
match codeLabelToCodeLabel.TryGetValue(lbl) with
| true, l -> lab2pc (n + 1) l
| _ -> codeLabelToPC.[lbl]
let mutable lastSeqPoint = None
// Add a nop to make way for the first sequence point.
do if mgbuf.cenv.opts.generateDebugSymbols then
let doc = mgbuf.cenv.g.memoize_file m.FileIndex
let i = FeeFeeInstr mgbuf.cenv doc
codebuf.Add(i) // for the FeeFee or a better sequence point
member cgbuf.DoPushes (pushes: Pushes) =
for ty in pushes do
stack <- ty :: stack
nstack <- nstack + 1
maxStack <- Operators.max maxStack nstack
member cgbuf.DoPops (n:Pops) =
for i = 0 to n - 1 do
match stack with
| [] ->
let msg = sprintf "pop on empty stack during code generation, methodName = %s, m = %s" methodName (stringOfRange m)
System.Diagnostics.Debug.Assert(false, msg)
warning(InternalError(msg,m))
| _ :: t ->
stack <- t
nstack <- nstack - 1
member cgbuf.GetCurrentStack() = stack
member cgbuf.AssertEmptyStack() =
if not (isNil stack) then
let msg = sprintf "stack flush didn't work, or extraneous expressions left on stack before stack restore, methodName = %s, stack = %+A, m = %s" methodName stack (stringOfRange m)
System.Diagnostics.Debug.Assert(false, msg)
warning(InternalError(msg,m))
()
member cgbuf.EmitInstr(pops,pushes,i) =
cgbuf.DoPops pops
cgbuf.DoPushes pushes
codebuf.Add i
member cgbuf.EmitInstrs (pops,pushes,is) =
cgbuf.DoPops pops
cgbuf.DoPushes pushes
is |> List.iter codebuf.Add
member cgbuf.GetLastSequencePoint() =
lastSeqPoint
member private cgbuf.EnsureNopBetweenDebugPoints() =
// Always add a nop between sequence points to help .NET get the stepping right
// Don't do this after a FeeFee marker for hidden code
if (codebuf.Count > 0 &&
(match codebuf.[codebuf.Count-1] with
| I_seqpoint sm when sm.Line <> FeeFee mgbuf.cenv -> true
| _ -> false)) then
codebuf.Add(AI_nop)
member cgbuf.EmitSeqPoint(src) =
if mgbuf.cenv.opts.generateDebugSymbols then
let attr = GenILSourceMarker mgbuf.cenv.g src
let i = I_seqpoint attr
hasSequencePoints <- true
// Replace the FeeFee seqpoint at the entry with a better sequence point
if codebuf.Count = 1 then
assert (match codebuf.[0] with I_seqpoint _ -> true | _ -> false)
codebuf.[0] <- i
else
cgbuf.EnsureNopBetweenDebugPoints()
codebuf.Add(i)
// Save the last sequence point away so we can make a decision graph look consistent (i.e. reassert the sequence point at each target)
lastSeqPoint <- Some src
anyDocument <- Some attr.Document
// Emit FeeFee breakpoints for hidden code, see https://blogs.msdn.microsoft.com/jmstall/2005/06/19/line-hidden-and-0xfeefee-sequence-points/
member cgbuf.EmitStartOfHiddenCode() =
if mgbuf.cenv.opts.generateDebugSymbols then
let doc = mgbuf.cenv.g.memoize_file m.FileIndex
let i = FeeFeeInstr mgbuf.cenv doc
hasSequencePoints <- true
// don't emit just after another FeeFee
match codebuf.[codebuf.Count-1] with
| I_seqpoint sm when sm.Line = FeeFee mgbuf.cenv -> ()
| _ ->
cgbuf.EnsureNopBetweenDebugPoints()
codebuf.Add(i)
member cgbuf.EmitExceptionClause(clause) =
exnSpecs.Add clause
member cgbuf.GenerateDelayMark(_nm) =
let lab = IL.generateCodeLabel()
Mark lab
member cgbuf.SetCodeLabelToCodeLabel(lab1,lab2) =
#if DEBUG
if codeLabelToCodeLabel.ContainsKey(lab1) then
let msg = sprintf "two values given for label %s, methodName = %s, m = %s" (formatCodeLabel lab1) methodName (stringOfRange m)
System.Diagnostics.Debug.Assert(false, msg)
warning(InternalError(msg,m))
#endif
codeLabelToCodeLabel.[lab1] <- lab2
member cgbuf.SetCodeLabelToPC(lab,pc) =
#if DEBUG
if codeLabelToPC.ContainsKey(lab) then
let msg = sprintf "two values given for label %s, methodName = %s, m = %s" (formatCodeLabel lab) methodName (stringOfRange m)
System.Diagnostics.Debug.Assert(false, msg)
warning(InternalError(msg,m))
#endif
codeLabelToPC.[lab] <- pc
member cgbuf.SetMark (mark1: Mark, mark2: Mark) =
cgbuf.SetCodeLabelToCodeLabel(mark1.CodeLabel, mark2.CodeLabel)
member cgbuf.SetMarkToHere (Mark lab) =
cgbuf.SetCodeLabelToPC(lab,codebuf.Count)
member cgbuf.SetStack(s) =
stack <- s
nstack <- s.Length
member cgbuf.Mark(s) =
let res = cgbuf.GenerateDelayMark(s)
cgbuf.SetMarkToHere(res)
res
member cgbuf.mgbuf = mgbuf
member cgbuf.MethodName = methodName
member cgbuf.PreallocatedArgCount = alreadyUsedArgs
member cgbuf.AllocLocal(ranges,ty,isFixed) =
let j = locals.Count
locals.Add((ranges,ty,isFixed))
j
member cgbuf.ReallocLocal(cond,ranges,ty,isFixed) =
let j =
match ResizeArray.tryFindIndexi cond locals with
| Some j ->
let (prevRanges,_,isFixed) = locals.[j]
locals.[j] <- ((ranges@prevRanges),ty,isFixed)
j
| None ->
cgbuf.AllocLocal(ranges,ty,isFixed)
let j = j + alreadyUsedLocals
j
member cgbuf.Close() =
let instrs = codebuf.ToArray()
// Fixup the first instruction to be a FeeFee sequence point if needed
let instrs =
instrs |> Array.mapi (fun idx i2 ->
if idx = 0 && (match i2 with AI_nop -> true | _ -> false) && anyDocument.IsSome then
// This special dummy sequence point says skip the start of the method
hasSequencePoints <- true
FeeFeeInstr mgbuf.cenv anyDocument.Value
else
i2)
let codeLabels =
let dict = Dictionary.newWithSize (codeLabelToPC.Count + codeLabelToCodeLabel.Count)
for kvp in codeLabelToPC do dict.Add(kvp.Key, lab2pc 0 kvp.Key)
for kvp in codeLabelToCodeLabel do dict.Add(kvp.Key, lab2pc 0 kvp.Key)
dict
(ResizeArray.toList locals, maxStack, codeLabels, instrs, ResizeArray.toList exnSpecs, hasSequencePoints)
module CG =
let EmitInstr (cgbuf:CodeGenBuffer) pops pushes i = cgbuf.EmitInstr(pops,pushes,i)
let EmitInstrs (cgbuf:CodeGenBuffer) pops pushes is = cgbuf.EmitInstrs(pops,pushes,is)
let EmitSeqPoint (cgbuf:CodeGenBuffer) src = cgbuf.EmitSeqPoint(src)
let GenerateDelayMark (cgbuf:CodeGenBuffer) nm = cgbuf.GenerateDelayMark(nm)
let SetMark (cgbuf:CodeGenBuffer) m1 m2 = cgbuf.SetMark(m1,m2)
let SetMarkToHere (cgbuf:CodeGenBuffer) m1 = cgbuf.SetMarkToHere(m1)
let SetStack (cgbuf:CodeGenBuffer) s = cgbuf.SetStack(s)
let GenerateMark (cgbuf:CodeGenBuffer) s = cgbuf.Mark(s)
open CG
//--------------------------------------------------------------------------
// Compile constants
//--------------------------------------------------------------------------
let GenString cenv cgbuf s =
CG.EmitInstrs cgbuf (pop 0) (Push [cenv.g.ilg.typ_String]) [ I_ldstr s ]
let GenConstArray cenv (cgbuf:CodeGenBuffer) eenv ilElementType (data:'a[]) (write : ByteBuffer -> 'a -> unit) =
let buf = ByteBuffer.Create data.Length
data |> Array.iter (write buf)
let bytes = buf.Close()
let ilArrayType = mkILArr1DTy ilElementType
if data.Length = 0 then
CG.EmitInstrs cgbuf (pop 0) (Push [ilArrayType]) [ mkLdcInt32 (0); I_newarr (ILArrayShape.SingleDimensional,ilElementType); ]
else
let vtspec = cgbuf.mgbuf.GenerateRawDataValueType(eenv.cloc,bytes.Length)
let ilFieldName = CompilerGeneratedName ("field" + string(newUnique()))
let fty = ILType.Value vtspec
let ilFieldDef = mkILStaticField (ilFieldName,fty, None, Some bytes, ILMemberAccess.Assembly)
let ilFieldDef = ilFieldDef.With(customAttrs = mkILCustomAttrs [ cenv.g.DebuggerBrowsableNeverAttribute ])
let fspec = mkILFieldSpecInTy (mkILTyForCompLoc eenv.cloc,ilFieldName, fty)
CountStaticFieldDef()
cgbuf.mgbuf.AddFieldDef(fspec.DeclaringTypeRef,ilFieldDef)
CG.EmitInstrs cgbuf
(pop 0)
(Push [ ilArrayType; ilArrayType; cenv.g.iltyp_RuntimeFieldHandle ])
[ mkLdcInt32 data.Length
I_newarr (ILArrayShape.SingleDimensional,ilElementType)
AI_dup
I_ldtoken (ILToken.ILField fspec) ]
CG.EmitInstrs cgbuf
(pop 2)
Push0
[ mkNormalCall (mkInitializeArrayMethSpec cenv.g) ]
//--------------------------------------------------------------------------
// We normally generate in the context of a "what to do next" continuation
//--------------------------------------------------------------------------
type sequel =
| EndFilter
/// Exit a 'handler' block
/// The integer says which local to save result in
| LeaveHandler of (bool (* finally? *) * int * Mark)
/// Branch to the given mark
| Br of Mark
| CmpThenBrOrContinue of Pops * ILInstr list
/// Continue and leave the value on the IL computation stack
| Continue
/// The value then do something else
| DiscardThen of sequel
/// Return from the method
| Return
/// End a scope of local variables. Used at end of 'let' and 'let rec' blocks to get tail recursive setting
/// of end-of-scope marks
| EndLocalScope of sequel * Mark
/// Return from a method whose return type is void
| ReturnVoid
let discard = DiscardThen Continue
let discardAndReturnVoid = DiscardThen ReturnVoid
//-------------------------------------------------------------------------
// This is the main code generation routine. It is used to generate
// the bodies of methods in a couple of places
//-------------------------------------------------------------------------
let CodeGenThen cenv mgbuf (entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,codeGenFunction,m) =
let cgbuf = new CodeGenBuffer(m,mgbuf,methodName,alreadyUsedArgs,alreadyUsedLocals)
let start = CG.GenerateMark cgbuf "mstart"
let innerVals = entryPointInfo |> List.map (fun (v,kind) -> (v,(kind,start)))
(* Call the given code generator *)
codeGenFunction cgbuf {eenv with withinSEH=false
liveLocals=IntMap.empty()
innerVals = innerVals}
let locals,maxStack,lab2pc,code,exnSpecs,hasSequencePoints = cgbuf.Close()
let localDebugSpecs : ILLocalDebugInfo list =
locals
|> List.mapi (fun i (nms,_,_isFixed) -> List.map (fun nm -> (i,nm)) nms)
|> List.concat
|> List.map (fun (i,(nm,(start,finish))) ->
{ Range=(start.CodeLabel, finish.CodeLabel)
DebugMappings= [{ LocalIndex=i; LocalName=nm }] })
let ilLocals =
locals
|> List.map (fun (infos, ty, isFixed) ->
let loc =
// in interactive environment, attach name and range info to locals to improve debug experience
if cenv.opts.isInteractive && cenv.opts.generateDebugSymbols then
match infos with
| [(nm, (start, finish))] -> mkILLocal ty (Some(nm, start.CodeLabel, finish.CodeLabel))
// REVIEW: what do these cases represent?
| _ :: _
| [] -> mkILLocal ty None
// if not interactive, don't bother adding this info
else
mkILLocal ty None
if isFixed then { loc with IsPinned=true } else loc)
(ilLocals,
maxStack,
lab2pc,
code,
exnSpecs,
localDebugSpecs,
hasSequencePoints)
let CodeGenMethod cenv mgbuf (entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,codeGenFunction,m) =
let locals,maxStack,lab2pc,instrs,exns,localDebugSpecs,hasSequencePoints =
CodeGenThen cenv mgbuf (entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,codeGenFunction,m)
let code = IL.buildILCode methodName lab2pc instrs exns localDebugSpecs
// Attach a source range to the method. Only do this is it has some sequence points, because .NET 2.0/3.5
// ILDASM has issues if you emit symbols with a source range but without any sequence points
let sourceRange = if hasSequencePoints then GenPossibleILSourceMarker cenv m else None
// The old union erasure phase increased maxstack by 2 since the code pushes some items, we do the same here
let maxStack = maxStack + 2
// Build an Abstract IL method
instrs, mkILMethodBody (true,locals,maxStack,code, sourceRange)
let StartDelayedLocalScope nm cgbuf =
let startScope = CG.GenerateDelayMark cgbuf ("start_" + nm)
let endScope = CG.GenerateDelayMark cgbuf ("end_" + nm)
startScope,endScope
let StartLocalScope nm cgbuf =
let startScope = CG.GenerateMark cgbuf ("start_" + nm)
let endScope = CG.GenerateDelayMark cgbuf ("end_" + nm)
startScope,endScope
let LocalScope nm cgbuf (f : (Mark * Mark) -> 'a) : 'a =
let _,endScope as scopeMarks = StartLocalScope nm cgbuf
let res = f scopeMarks
CG.SetMarkToHere cgbuf endScope
res
let compileSequenceExpressions = true // try (System.Environment.GetEnvironmentVariable("COMPILED_SEQ") <> null) with _ -> false
//-------------------------------------------------------------------------
// Sequence Point Logic
//-------------------------------------------------------------------------
type EmitSequencePointState =
/// Indicates that we need a sequence point at first opportunity. Used on entrance to a method
/// and whenever we drop into an expression within the stepping control structure.
| SPAlways
| SPSuppress
/// Determines if any code at all will be emitted for a binding
let BindingEmitsNoCode g (TBind(vspec,_,_)) = IsValCompiledAsMethod g vspec
/// Determines what sequence point should be emitted when generating the r.h.s of a binding.
/// For example, if the r.h.s is a lambda then no sequence point is emitted.
///
/// Returns (isSticky, sequencePointForBind, sequencePointGenerationFlagForRhsOfBind)
let ComputeSequencePointInfoForBinding g (TBind(_,e,spBind) as bind) =
if BindingEmitsNoCode g bind then
false, None, SPSuppress
else
match spBind, stripExpr e with
| NoSequencePointAtInvisibleBinding, _ -> false, None, SPSuppress
| NoSequencePointAtStickyBinding, _ -> true, None, SPSuppress
| NoSequencePointAtDoBinding, _ -> false, None, SPAlways
| NoSequencePointAtLetBinding, _ -> false, None, SPSuppress
// Don't emit sequence points for lambdas.
// SEQUENCE POINT REVIEW: don't emit for lazy either, nor any builder expressions, nor interface-implementing object expressions
| _, (Expr.Lambda _ | Expr.TyLambda _) -> false, None, SPSuppress
| SequencePointAtBinding m,_ -> false, Some m, SPSuppress
/// Determines if a sequence will be emitted when we generate the code for a binding.
///
/// False for Lambdas, BindingEmitsNoCode, NoSequencePointAtStickyBinding, NoSequencePointAtInvisibleBinding, and NoSequencePointAtLetBinding.
/// True for SequencePointAtBinding, NoSequencePointAtDoBinding.
let BindingEmitsSequencePoint g bind =
match ComputeSequencePointInfoForBinding g bind with
| _, None, SPSuppress -> false
| _ -> true
let BindingIsInvisible (TBind(_,_,spBind)) =
match spBind with
| NoSequencePointAtInvisibleBinding _ -> true
| _ -> false
/// Determines if the code generated for a binding is to be marked as hidden, e.g. the 'newobj' for a local function definition.
let BindingEmitsHiddenCode (TBind(_,e,spBind)) =
match spBind, stripExpr e with
| _, (Expr.Lambda _ | Expr.TyLambda _) -> true
| _ -> false
/// Determines if generating the code for a compound expression will emit a sequence point as the first instruction
/// through the processing of the constituent parts. Used to prevent the generation of sequence points for
/// compound expressions.
let rec FirstEmittedCodeWillBeSequencePoint g sp expr =
match sp with
| SPAlways ->
match stripExpr expr with
| Expr.Let (bind,body,_,_) ->
BindingEmitsSequencePoint g bind ||
FirstEmittedCodeWillBeSequencePoint g sp bind.Expr ||
(BindingEmitsNoCode g bind && FirstEmittedCodeWillBeSequencePoint g sp body)
| Expr.LetRec(binds,body,_,_) ->
binds |> List.exists (BindingEmitsSequencePoint g) ||
(binds |> List.forall (BindingEmitsNoCode g) && FirstEmittedCodeWillBeSequencePoint g sp body)
| Expr.Sequential (_, _, NormalSeq,spSeq,_) ->
match spSeq with
| SequencePointsAtSeq -> true
| SuppressSequencePointOnExprOfSequential -> true
| SuppressSequencePointOnStmtOfSequential -> false
| Expr.Match (SequencePointAtBinding _,_,_,_,_,_) -> true
| Expr.Op(( TOp.TryCatch (SequencePointAtTry _,_)
| TOp.TryFinally (SequencePointAtTry _,_)
| TOp.For (SequencePointAtForLoop _,_)
| TOp.While (SequencePointAtWhileLoop _,_)),_,_,_) -> true
| _ -> false
| SPSuppress ->
false
/// Suppress sequence points for some compound expressions - though not all - even if "SPAlways" is set.
///
/// Note this is only used when FirstEmittedCodeWillBeSequencePoint is false.
let EmitSequencePointForWholeExpr g sp expr =
assert (not (FirstEmittedCodeWillBeSequencePoint g sp expr))
match sp with
| SPAlways ->
match stripExpr expr with
// In some cases, we emit sequence points for the 'whole' of a 'let' expression.
// Specifically, when
// + SPAlways (i.e. a sequence point is required as soon as meaningful)
// + binding is NoSequencePointAtStickyBinding, or NoSequencePointAtLetBinding.
// + not FirstEmittedCodeWillBeSequencePoint
// For example if we start with
// let someCode () = f x
// and by inlining 'f' the expression becomes
// let someCode () = (let sticky = x in y)
// then we place the sequence point for the whole TAST expression 'let sticky = x in y', i.e. textual range 'f x' in the source code, but
// _before_ the evaluation of 'x'. This will only happen for sticky 'let' introduced by inlining and other code generation
// steps. We do _not_ do this for 'invisible' let which can be skipped.
| Expr.Let (bind,_,_,_) when BindingIsInvisible bind -> false
| Expr.LetRec(binds,_,_,_) when binds |> List.forall BindingIsInvisible -> false
// If the binding is a lambda then we don't emit a sequence point.
| Expr.Let (bind,_,_,_) when BindingEmitsHiddenCode bind -> false
| Expr.LetRec(binds,_,_,_) when binds |> List.forall BindingEmitsHiddenCode -> false
// If the binding is represented by a top-level generated constant value then we don't emit a sequence point.
| Expr.Let (bind,_,_,_) when BindingEmitsNoCode g bind -> false
| Expr.LetRec(binds,_,_,_) when binds |> List.forall (BindingEmitsNoCode g) -> false
// Suppress sequence points for the whole 'a;b' and do it at 'a' instead.
| Expr.Sequential _ -> false
// Suppress sequence points at labels and gotos, it makes no sense to emit sequence points at these. We emit FeeFee instead
| Expr.Op(TOp.Label _,_,_,_) -> false
| Expr.Op(TOp.Goto _,_,_,_) -> false
// We always suppress at the whole 'match'/'try'/... expression because we do it at the individual parts.
//
// These cases need documenting. For example, a typical 'match' gets compiled to
// let tmp = expr // generates a sequence point, BEFORE tmp is evaluated
// match tmp with // a match marked with NoSequencePointAtInvisibleLetBinding
// So since the 'let tmp = expr' has a sequence point, then no sequence point is needed for the 'match'. But the processing
// of the 'let' requests SPAlways for the body.
| Expr.Match _ -> false
| Expr.Op(TOp.TryCatch _,_,_,_) -> false
| Expr.Op(TOp.TryFinally _,_,_,_) -> false
| Expr.Op(TOp.For _,_,_,_) -> false
| Expr.Op(TOp.While _,_,_,_) -> false
| _ -> true
| SPSuppress ->
false
/// Emit hidden code markers for some compound expressions. Specifically, emit a hidden code marker for 'let f() = a in body'
/// because the binding for 'f' will emit some code which we don't want to be visible.
/// let someCode x =
/// let f () = a
/// body
let EmitHiddenCodeMarkerForWholeExpr g sp expr =
assert (not (FirstEmittedCodeWillBeSequencePoint g sp expr))
assert (not (EmitSequencePointForWholeExpr g sp expr))
match sp with
| SPAlways ->
match stripExpr expr with
| Expr.Let (bind,_,_,_) when BindingEmitsHiddenCode bind -> true
| Expr.LetRec(binds,_,_,_) when binds |> List.exists BindingEmitsHiddenCode -> true
| _ -> false
| SPSuppress ->
false
/// Some expressions must emit some preparation code, then emit the actual code.
let rec RangeOfSequencePointForWholeExpr g expr =
match stripExpr expr with
| Expr.Let (bind,body,_,_) ->
match ComputeSequencePointInfoForBinding g bind with
// For sticky bindings, prefer the range of the overall expression.
| true, _, _ -> expr.Range
| _, None, SPSuppress -> RangeOfSequencePointForWholeExpr g body
| _, Some m, _ -> m
| _, None, SPAlways -> RangeOfSequencePointForWholeExpr g bind.Expr
| Expr.LetRec(_,body,_,_) -> RangeOfSequencePointForWholeExpr g body
| Expr.Sequential (expr1, _, NormalSeq, _, _) -> RangeOfSequencePointForWholeExpr g expr1
| _ -> expr.Range
/// Used to avoid emitting multiple sequence points in decision tree generation
let DoesGenExprStartWithSequencePoint g sp expr =
FirstEmittedCodeWillBeSequencePoint g sp expr ||
EmitSequencePointForWholeExpr g sp expr
//-------------------------------------------------------------------------
// Generate expressions
//-------------------------------------------------------------------------
let rec GenExpr (cenv:cenv) (cgbuf:CodeGenBuffer) eenv sp expr sequel =
let expr = stripExpr expr
if not (FirstEmittedCodeWillBeSequencePoint cenv.g sp expr) then
if EmitSequencePointForWholeExpr cenv.g sp expr then
CG.EmitSeqPoint cgbuf (RangeOfSequencePointForWholeExpr cenv.g expr)
elif EmitHiddenCodeMarkerForWholeExpr cenv.g sp expr then
cgbuf.EmitStartOfHiddenCode()
match (if compileSequenceExpressions then LowerCallsAndSeqs.LowerSeqExpr cenv.g cenv.amap expr else None) with
| Some info ->
GenSequenceExpr cenv cgbuf eenv info sequel
| None ->
match expr with
| Expr.Const(c,m,ty) ->
GenConstant cenv cgbuf eenv (c,m,ty) sequel
| Expr.Match (spBind,exprm,tree,targets,m,ty) ->
GenMatch cenv cgbuf eenv (spBind,exprm,tree,targets,m,ty) sequel
| Expr.Sequential(e1,e2,dir,spSeq,m) ->
GenSequential cenv cgbuf eenv sp (e1,e2,dir,spSeq,m) sequel
| Expr.LetRec (binds,body,m,_) ->
GenLetRec cenv cgbuf eenv (binds,body,m) sequel
| Expr.Let (bind,body,_,_) ->
// This case implemented here to get a guaranteed tailcall
// Make sure we generate the sequence point outside the scope of the variable
let startScope,endScope as scopeMarks = StartDelayedLocalScope "let" cgbuf
let eenv = AllocStorageForBind cenv cgbuf scopeMarks eenv bind
let spBind = GenSequencePointForBind cenv cgbuf bind
GenBindingAfterSequencePoint cenv cgbuf eenv spBind bind (Some startScope)
// Work out if we need a sequence point for the body. For any "user" binding then the body gets SPAlways.
// For invisible compiler-generated bindings we just use "sp", unless its body is another invisible binding
// For sticky bindings arising from inlining we suppress any immediate sequence point in the body
let spBody =
match bind.SequencePointInfo with
| SequencePointAtBinding _
| NoSequencePointAtLetBinding
| NoSequencePointAtDoBinding -> SPAlways
| NoSequencePointAtInvisibleBinding -> sp
| NoSequencePointAtStickyBinding -> SPSuppress
// Generate the body
GenExpr cenv cgbuf eenv spBody body (EndLocalScope(sequel,endScope))
| Expr.Lambda _ | Expr.TyLambda _ ->
GenLambda cenv cgbuf eenv false None expr sequel
| Expr.App(Expr.Val(vref, _, m) as v, _, tyargs, [], _) when
List.forall (isMeasureTy cenv.g) tyargs &&
(
// inline only values that are stored in local variables
match StorageForValRef m vref eenv with
| ValStorage.Local _ -> true
| _ -> false
) ->
// application of local type functions with type parameters = measure types and body = local value - inine the body
GenExpr cenv cgbuf eenv sp v sequel
| Expr.App(f,fty,tyargs,args,m) ->
GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel
| Expr.Val(v,_,m) ->
GenGetVal cenv cgbuf eenv (v,m) sequel
| Expr.Op(op,tyargs,args,m) ->
begin match op,args,tyargs with
| TOp.ExnConstr(c),_,_ ->
GenAllocExn cenv cgbuf eenv (c,args,m) sequel
| TOp.UnionCase(c),_,_ ->
GenAllocUnionCase cenv cgbuf eenv (c,tyargs,args,m) sequel
| TOp.Recd(isCtor,tycon),_,_ ->
GenAllocRecd cenv cgbuf eenv isCtor (tycon,tyargs,args,m) sequel
| TOp.TupleFieldGet (tupInfo,n),[e],_ ->
GenGetTupleField cenv cgbuf eenv (tupInfo,e,tyargs,n,m) sequel
| TOp.ExnFieldGet(ecref,n),[e],_ ->
GenGetExnField cenv cgbuf eenv (e,ecref,n,m) sequel
| TOp.UnionCaseFieldGet(ucref,n),[e],_ ->
GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel
| TOp.UnionCaseFieldGetAddr(ucref,n,_readonly),[e],_ ->
GenGetUnionCaseFieldAddr cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel
| TOp.UnionCaseTagGet ucref,[e],_ ->
GenGetUnionCaseTag cenv cgbuf eenv (e,ucref,tyargs,m) sequel
| TOp.UnionCaseProof ucref,[e],_ ->
GenUnionCaseProof cenv cgbuf eenv (e,ucref,tyargs,m) sequel
| TOp.ExnFieldSet(ecref,n),[e;e2],_ ->
GenSetExnField cenv cgbuf eenv (e,ecref,n,e2,m) sequel
| TOp.UnionCaseFieldSet(ucref,n),[e;e2],_ ->
GenSetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,e2,m) sequel
| TOp.ValFieldGet f,[e],_ ->
GenGetRecdField cenv cgbuf eenv (e,f,tyargs,m) sequel
| TOp.ValFieldGet f,[],_ ->
GenGetStaticField cenv cgbuf eenv (f,tyargs,m) sequel
| TOp.ValFieldGetAddr (f, _readonly),[e],_ ->
GenGetRecdFieldAddr cenv cgbuf eenv (e,f,tyargs,m) sequel
| TOp.ValFieldGetAddr (f, _readonly),[],_ ->
GenGetStaticFieldAddr cenv cgbuf eenv (f,tyargs,m) sequel
| TOp.ValFieldSet f,[e1;e2],_ ->
GenSetRecdField cenv cgbuf eenv (e1,f,tyargs,e2,m) sequel
| TOp.ValFieldSet f,[e2],_ ->
GenSetStaticField cenv cgbuf eenv (f,tyargs,e2,m) sequel
| TOp.Tuple tupInfo,_,_ ->
GenAllocTuple cenv cgbuf eenv (tupInfo,args,tyargs,m) sequel
| TOp.ILAsm(code,returnTys),_,_ ->
GenAsmCode cenv cgbuf eenv (code,tyargs,args,returnTys,m) sequel
| TOp.While (sp,_),[Expr.Lambda(_,_,_,[_],e1,_,_);Expr.Lambda(_,_,_,[_],e2,_,_)],[] ->
GenWhileLoop cenv cgbuf eenv (sp,e1,e2,m) sequel
| TOp.For(spStart,dir),[Expr.Lambda(_,_,_,[_],e1,_,_);Expr.Lambda(_,_,_,[_],e2,_,_);Expr.Lambda(_,_,_,[v],e3,_,_)],[] ->
GenForLoop cenv cgbuf eenv (spStart,v,e1,dir,e2,e3,m) sequel
| TOp.TryFinally(spTry,spFinally),[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[_],e2,_,_)],[resty] ->
GenTryFinally cenv cgbuf eenv (e1,e2,m,resty,spTry,spFinally) sequel
| TOp.TryCatch(spTry,spWith),[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[vf],ef,_,_);Expr.Lambda(_,_,_,[vh],eh,_,_)],[resty] ->
GenTryCatch cenv cgbuf eenv (e1,vf,ef,vh,eh,m,resty,spTry,spWith) sequel
| TOp.ILCall(virt,_,valu,newobj,valUseFlags,_,isDllImport,ilMethRef,enclArgTys,methArgTys,returnTys),args,[] ->
GenILCall cenv cgbuf eenv (virt,valu,newobj,valUseFlags,isDllImport,ilMethRef,enclArgTys,methArgTys,args,returnTys,m) sequel
| TOp.RefAddrGet _readonly,[e],[ty] -> GenGetAddrOfRefCellField cenv cgbuf eenv (e,ty,m) sequel
| TOp.Coerce,[e],[tgty;srcty] -> GenCoerce cenv cgbuf eenv (e,tgty,m,srcty) sequel
| TOp.Reraise,[],[rtnty] -> GenReraise cenv cgbuf eenv (rtnty,m) sequel
| TOp.TraitCall(ss),args,[] -> GenTraitCall cenv cgbuf eenv (ss,args, m) expr sequel
| TOp.LValueOp(LSet,v),[e],[] -> GenSetVal cenv cgbuf eenv (v,e,m) sequel
| TOp.LValueOp(LByrefGet,v),[],[] -> GenGetByref cenv cgbuf eenv (v,m) sequel
| TOp.LValueOp(LByrefSet,v),[e],[] -> GenSetByref cenv cgbuf eenv (v,e,m) sequel
| TOp.LValueOp(LAddrOf _,v),[],[] -> GenGetValAddr cenv cgbuf eenv (v,m) sequel
| TOp.Array,elems,[elemTy] -> GenNewArray cenv cgbuf eenv (elems,elemTy,m) sequel
| TOp.Bytes bytes,[],[] ->
if cenv.opts.emitConstantArraysUsingStaticDataBlobs then
GenConstArray cenv cgbuf eenv cenv.g.ilg.typ_Byte bytes (fun buf b -> buf.EmitByte b)
GenSequel cenv eenv.cloc cgbuf sequel
else
GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkByte cenv.g m) bytes),cenv.g.byte_ty,m) sequel
| TOp.UInt16s arr,[],[] ->
if cenv.opts.emitConstantArraysUsingStaticDataBlobs then
GenConstArray cenv cgbuf eenv cenv.g.ilg.typ_UInt16 arr (fun buf b -> buf.EmitUInt16 b)
GenSequel cenv eenv.cloc cgbuf sequel
else
GenNewArraySimple cenv cgbuf eenv (List.ofArray (Array.map (mkUInt16 cenv.g m) arr),cenv.g.uint16_ty,m) sequel
| TOp.Goto(label),_,_ ->
if cgbuf.mgbuf.cenv.opts.generateDebugSymbols then
cgbuf.EmitStartOfHiddenCode()
CG.EmitInstr cgbuf (pop 0) Push0 AI_nop
CG.EmitInstr cgbuf (pop 0) Push0 (I_br label)
// NOTE: discard sequel
| TOp.Return,[e],_ ->
GenExpr cenv cgbuf eenv SPSuppress e Return
// NOTE: discard sequel
| TOp.Return,[],_ ->
GenSequel cenv eenv.cloc cgbuf ReturnVoid
// NOTE: discard sequel
| TOp.Label(label),_,_ ->
cgbuf.SetMarkToHere (Mark label)
GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel
| _ -> error(InternalError("Unexpected operator node expression",expr.Range))
end
| Expr.StaticOptimization(constraints,e2,e3,m) ->
GenStaticOptimization cenv cgbuf eenv (constraints,e2,e3,m) sequel
| Expr.Obj(_,ty,_,_,[meth],[],m) when isDelegateTy cenv.g ty ->
GenDelegateExpr cenv cgbuf eenv expr (meth,m) sequel
| Expr.Obj(_,ty,basev,basecall,overrides,interfaceImpls,m) ->
GenObjectExpr cenv cgbuf eenv expr (ty,basev,basecall,overrides,interfaceImpls,m) sequel
| Expr.Quote(ast,conv,_,m,ty) -> GenQuotation cenv cgbuf eenv (ast,conv,m,ty) sequel
| Expr.Link _ -> failwith "Unexpected reclink"
| Expr.TyChoose (_,_,m) -> error(InternalError("Unexpected Expr.TyChoose",m))
and GenExprs cenv cgbuf eenv es =
List.iter (fun e -> GenExpr cenv cgbuf eenv SPSuppress e Continue) es
and CodeGenMethodForExpr cenv mgbuf (spReq,entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,expr0,sequel0) =
let _,code =
CodeGenMethod cenv mgbuf (entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,
(fun cgbuf eenv -> GenExpr cenv cgbuf eenv spReq expr0 sequel0),
expr0.Range)
code
//--------------------------------------------------------------------------
// Generate sequels
//--------------------------------------------------------------------------
(* does the sequel discard its result, and if so what does it do next? *)
and sequelAfterDiscard sequel =
match sequel with
| DiscardThen sequel -> Some(sequel)
| EndLocalScope(sq,mark) -> sequelAfterDiscard sq |> Option.map (fun sq -> EndLocalScope(sq,mark))
| _ -> None
and sequelIgnoringEndScopesAndDiscard sequel =
let sequel = sequelIgnoreEndScopes sequel
match sequelAfterDiscard sequel with
| Some sq -> sq
| None -> sequel
and sequelIgnoreEndScopes sequel =
match sequel with
| EndLocalScope(sq,_) -> sequelIgnoreEndScopes sq
| sq -> sq
(* commit any 'EndLocalScope' nodes in the sequel and return the residue *)
and GenSequelEndScopes cgbuf sequel =
match sequel with
| EndLocalScope(sq,m) -> CG.SetMarkToHere cgbuf m; GenSequelEndScopes cgbuf sq
| _ -> ()
and StringOfSequel sequel =
match sequel with
| Continue -> "continue"
| DiscardThen sequel -> "discard; " + StringOfSequel sequel
| ReturnVoid -> "ReturnVoid"
| CmpThenBrOrContinue _ -> "CmpThenBrOrContinue"
| Return -> "Return"
| EndLocalScope (sq,Mark k) -> "EndLocalScope(" + StringOfSequel sq + "," + formatCodeLabel k + ")"
| Br (Mark x) -> sprintf "Br L%s" (formatCodeLabel x)
| LeaveHandler _ -> "LeaveHandler"
| EndFilter -> "EndFilter"
and GenSequel cenv cloc cgbuf sequel =
let sq = sequelIgnoreEndScopes sequel
(match sq with
| Continue -> ()
| DiscardThen sq ->
CG.EmitInstr cgbuf (pop 1) Push0 AI_pop
GenSequel cenv cloc cgbuf sq
| ReturnVoid ->
CG.EmitInstr cgbuf (pop 0) Push0 I_ret
| CmpThenBrOrContinue(pops,bri) ->
CG.EmitInstrs cgbuf pops Push0 bri
| Return ->
CG.EmitInstr cgbuf (pop 1) Push0 I_ret
| EndLocalScope _ -> failwith "EndLocalScope unexpected"
| Br x ->
// Emit a NOP in debug code in case the branch instruction gets eliminated
// because it is a "branch to next instruction". This prevents two unrelated sequence points
// (the one before the branch and the one after) being coalesced together
if cgbuf.mgbuf.cenv.opts.generateDebugSymbols then
cgbuf.EmitStartOfHiddenCode()
CG.EmitInstr cgbuf (pop 0) Push0 AI_nop
CG.EmitInstr cgbuf (pop 0) Push0 (I_br x.CodeLabel)
| LeaveHandler (isFinally, whereToSaveResult,x) ->
if isFinally then
CG.EmitInstr cgbuf (pop 1) Push0 AI_pop
else
EmitSetLocal cgbuf whereToSaveResult
CG.EmitInstr cgbuf (pop 0) Push0 (if isFinally then I_endfinally else I_leave(x.CodeLabel))
| EndFilter ->
CG.EmitInstr cgbuf (pop 1) Push0 I_endfilter
)
GenSequelEndScopes cgbuf sequel
//--------------------------------------------------------------------------
// Generate constants
//--------------------------------------------------------------------------
and GenConstant cenv cgbuf eenv (c,m,ty) sequel =
let ilTy = GenType cenv.amap m eenv.tyenv ty
// Check if we need to generate the value at all
match sequelAfterDiscard sequel with
| None ->
match TryEliminateDesugaredConstants cenv.g m c with
| Some e ->
GenExpr cenv cgbuf eenv SPSuppress e Continue
| None ->
match c with
| Const.Bool b -> CG.EmitInstr cgbuf (pop 0) (Push [cenv.g.ilg.typ_Bool]) (mkLdcInt32 (if b then 1 else 0))
| Const.SByte i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (mkLdcInt32 (int32 i))
| Const.Int16 i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (mkLdcInt32 (int32 i))
| Const.Int32 i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (mkLdcInt32 i)
| Const.Int64 i ->
// see https://github.com/Microsoft/visualfsharp/pull/3620
if i >= int64 System.Int32.MinValue && i <= int64 System.Int32.MaxValue then
CG.EmitInstrs cgbuf (pop 0) (Push [ilTy]) [ mkLdcInt32 (int32 i); AI_conv DT_I8 ]
elif i >= int64 System.UInt32.MinValue && i <= int64 System.UInt32.MaxValue then
CG.EmitInstrs cgbuf (pop 0) (Push [ilTy]) [ mkLdcInt32 (int32 i); AI_conv DT_U8 ]
else
CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (iLdcInt64 i)
| Const.IntPtr i -> CG.EmitInstrs cgbuf (pop 0) (Push [ilTy]) [iLdcInt64 i; AI_conv DT_I ]
| Const.Byte i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (mkLdcInt32 (int32 i))
| Const.UInt16 i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (mkLdcInt32 (int32 i))
| Const.UInt32 i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (mkLdcInt32 (int32 i))
| Const.UInt64 i -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (iLdcInt64 (int64 i))
| Const.UIntPtr i -> CG.EmitInstrs cgbuf (pop 0) (Push [ilTy]) [iLdcInt64 (int64 i); AI_conv DT_U ]
| Const.Double f -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (AI_ldc (DT_R8,ILConst.R8 f))
| Const.Single f -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) (AI_ldc (DT_R4,ILConst.R4 f))
| Const.Char(c) -> CG.EmitInstr cgbuf (pop 0) (Push [ilTy]) ( mkLdcInt32 (int c))
| Const.String(s) -> GenString cenv cgbuf s
| Const.Unit -> GenUnit cenv eenv m cgbuf
| Const.Zero -> GenDefaultValue cenv cgbuf eenv (ty,m)
| Const.Decimal _ -> failwith "unreachable"
GenSequel cenv eenv.cloc cgbuf sequel
| Some sq ->
// Even if we didn't need to generate the value then maybe we still have to branch or return
GenSequel cenv eenv.cloc cgbuf sq
and GenUnitTy cenv eenv m =
match cenv.ilUnitTy with
| None ->
let res = GenType cenv.amap m eenv.tyenv cenv.g.unit_ty
cenv.ilUnitTy <- Some res
res
| Some res -> res
and GenUnit cenv eenv m cgbuf =
CG.EmitInstr cgbuf (pop 0) (Push [GenUnitTy cenv eenv m]) AI_ldnull
and GenUnitThenSequel cenv eenv m cloc cgbuf sequel =
match sequelAfterDiscard sequel with
| Some(sq) -> GenSequel cenv cloc cgbuf sq
| None -> GenUnit cenv eenv m cgbuf; GenSequel cenv cloc cgbuf sequel
//--------------------------------------------------------------------------
// Generate simple data-related constructs
//--------------------------------------------------------------------------
and GenAllocTuple cenv cgbuf eenv (tupInfo, args,argtys,m) sequel =
let tupInfo = evalTupInfoIsStruct tupInfo
let tcref, tys, args, newm = mkCompiledTuple cenv.g tupInfo (argtys,args,m)
let ty = GenNamedTyApp cenv.amap newm eenv.tyenv tcref tys
let ntyvars = if (tys.Length - 1) < goodTupleFields then (tys.Length - 1) else goodTupleFields
let formalTyvars = [ for n in 0 .. ntyvars do yield mkILTyvarTy (uint16 n) ]
GenExprs cenv cgbuf eenv args
// Generate a reference to the constructor
CG.EmitInstr cgbuf (pop args.Length) (Push [ty])
(mkNormalNewobj
(mkILCtorMethSpecForTy (ty,formalTyvars)))
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetTupleField cenv cgbuf eenv (tupInfo,e,tys,n,m) sequel =
let tupInfo = evalTupInfoIsStruct tupInfo
let rec getCompiledTupleItem g (e,tys:TTypes,n,m) =
let ar = tys.Length
if ar <= 0 then failwith "getCompiledTupleItem"
elif ar < maxTuple then
let tcr' = mkCompiledTupleTyconRef g tupInfo ar
let ty = GenNamedTyApp cenv.amap m eenv.tyenv tcr' tys
mkGetTupleItemN g m n ty tupInfo e tys.[n]
else
let tysA,tysB = List.splitAfter (goodTupleFields) tys
let tyB = mkCompiledTupleTy g tupInfo tysB
let tys' = tysA@[tyB]
let tcr' = mkCompiledTupleTyconRef g tupInfo (List.length tys')
let ty' = GenNamedTyApp cenv.amap m eenv.tyenv tcr' tys'
let n' = (min n goodTupleFields)
let elast = mkGetTupleItemN g m n' ty' tupInfo e tys'.[n']
if n < goodTupleFields then
elast
else
getCompiledTupleItem g (elast,tysB,n-goodTupleFields,m)
GenExpr cenv cgbuf eenv SPSuppress (getCompiledTupleItem cenv.g (e,tys,n,m)) sequel
and GenAllocExn cenv cgbuf eenv (c,args,m) sequel =
GenExprs cenv cgbuf eenv args
let ty = GenExnType cenv.amap m eenv.tyenv c
let flds = recdFieldsOfExnDefRef c
let argtys = flds |> List.map (fun rfld -> GenType cenv.amap m eenv.tyenv rfld.FormalType)
let mspec = mkILCtorMethSpecForTy (ty, argtys)
CG.EmitInstr cgbuf
(pop args.Length) (Push [ty])
(mkNormalNewobj mspec)
GenSequel cenv eenv.cloc cgbuf sequel
and GenAllocUnionCase cenv cgbuf eenv (c,tyargs,args,m) sequel =
GenExprs cenv cgbuf eenv args
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv c tyargs
CG.EmitInstrs cgbuf (pop args.Length) (Push [cuspec.DeclaringType]) (EraseUnions.mkNewData cenv.g.ilg (cuspec, idx))
GenSequel cenv eenv.cloc cgbuf sequel
and GenAllocRecd cenv cgbuf eenv ctorInfo (tcref,argtys,args,m) sequel =
let ty = GenNamedTyApp cenv.amap m eenv.tyenv tcref argtys
// Filter out fields with default initialization
let relevantFields =
tcref.AllInstanceFieldsAsList
|> List.filter (fun f -> not f.IsZeroInit)
|> List.filter (fun f -> not f.IsCompilerGenerated)
match ctorInfo with
| RecdExprIsObjInit ->
(args,relevantFields) ||> List.iter2 (fun e f ->
CG.EmitInstr cgbuf (pop 0) (Push (if tcref.IsStructOrEnumTycon then [ILType.Byref ty] else [ty])) mkLdarg0
GenExpr cenv cgbuf eenv SPSuppress e Continue
GenFieldStore false cenv cgbuf eenv (tcref.MakeNestedRecdFieldRef f,argtys,m) discard)
// Object construction doesn't generate a true value.
// Object constructions will always just get thrown away so this is safe
GenSequel cenv eenv.cloc cgbuf sequel
| RecdExpr ->
GenExprs cenv cgbuf eenv args
// generate a reference to the record constructor
let tyenvinner = TypeReprEnv.ForTyconRef tcref
CG.EmitInstr cgbuf (pop args.Length) (Push [ty])
(mkNormalNewobj
(mkILCtorMethSpecForTy (ty,relevantFields |> List.map (fun f -> GenType cenv.amap m tyenvinner f.FormalType) )))
GenSequel cenv eenv.cloc cgbuf sequel
and GenNewArraySimple cenv cgbuf eenv (elems,elemTy,m) sequel =
let ilElemTy = GenType cenv.amap m eenv.tyenv elemTy
let ilArrTy = mkILArr1DTy ilElemTy
CG.EmitInstrs cgbuf (pop 0) (Push [ilArrTy]) [ (AI_ldc (DT_I4,ILConst.I4 (elems.Length))); I_newarr (ILArrayShape.SingleDimensional,ilElemTy) ]
elems |> List.iteri (fun i e ->
CG.EmitInstrs cgbuf (pop 0) (Push [ilArrTy; cenv.g.ilg.typ_Int32]) [ AI_dup; (AI_ldc (DT_I4,ILConst.I4 i)) ]
GenExpr cenv cgbuf eenv SPSuppress e Continue
CG.EmitInstr cgbuf (pop 3) Push0 (I_stelem_any (ILArrayShape.SingleDimensional,ilElemTy)))
GenSequel cenv eenv.cloc cgbuf sequel
and GenNewArray cenv cgbuf eenv (elems: Expr list,elemTy,m) sequel =
// REVIEW: The restriction against enum types here has to do with Dev10/Dev11 bug 872799
// GenConstArray generates a call to RuntimeHelpers.InitializeArray. On CLR 2.0/x64 and CLR 4.0/x64/x86,
// InitializeArray is a JIT intrinsic that will result in invalid runtime CodeGen when initializing an array
// of enum types. Until bug 872799 is fixed, we'll need to generate arrays the "simple" way for enum types
// Also note - C# never uses InitializeArray for enum types, so this change puts us on equal footing with them.
if elems.Length <= 5 || not cenv.opts.emitConstantArraysUsingStaticDataBlobs || (isEnumTy cenv.g elemTy) then
GenNewArraySimple cenv cgbuf eenv (elems,elemTy,m) sequel
else
// Try to emit a constant byte-blob array
let elems' = Array.ofList elems
let test,write =
match elems'.[0] with
| Expr.Const(Const.Bool _,_,_) -> (function Const.Bool _ -> true | _ -> false), (fun (buf: ByteBuffer) -> function Const.Bool b -> buf.EmitBoolAsByte b | _ -> failwith "unreachable")
| Expr.Const(Const.Char _,_,_) -> (function Const.Char _ -> true | _ -> false), (fun buf -> function Const.Char b -> buf.EmitInt32AsUInt16 (int b) | _ -> failwith "unreachable")
| Expr.Const(Const.Byte _,_,_) -> (function Const.Byte _ -> true | _ -> false), (fun buf -> function Const.Byte b -> buf.EmitByte b | _ -> failwith "unreachable")
| Expr.Const(Const.UInt16 _,_,_) -> (function Const.UInt16 _ -> true | _ -> false), (fun buf -> function Const.UInt16 b -> buf.EmitUInt16 b | _ -> failwith "unreachable")
| Expr.Const(Const.UInt32 _,_,_) -> (function Const.UInt32 _ -> true | _ -> false), (fun buf -> function Const.UInt32 b -> buf.EmitInt32 (int32 b) | _ -> failwith "unreachable")
| Expr.Const(Const.UInt64 _,_,_) -> (function Const.UInt64 _ -> true | _ -> false), (fun buf -> function Const.UInt64 b -> buf.EmitInt64 (int64 b) | _ -> failwith "unreachable")
| Expr.Const(Const.SByte _,_,_) -> (function Const.SByte _ -> true | _ -> false), (fun buf -> function Const.SByte b -> buf.EmitByte (byte b) | _ -> failwith "unreachable")
| Expr.Const(Const.Int16 _,_,_) -> (function Const.Int16 _ -> true | _ -> false), (fun buf -> function Const.Int16 b -> buf.EmitUInt16 (uint16 b) | _ -> failwith "unreachable")
| Expr.Const(Const.Int32 _,_,_) -> (function Const.Int32 _ -> true | _ -> false), (fun buf -> function Const.Int32 b -> buf.EmitInt32 b | _ -> failwith "unreachable")
| Expr.Const(Const.Int64 _,_,_) -> (function Const.Int64 _ -> true | _ -> false), (fun buf -> function Const.Int64 b -> buf.EmitInt64 b | _ -> failwith "unreachable")
| _ -> (function _ -> false), (fun _ _ -> failwith "unreachable")
if elems' |> Array.forall (function Expr.Const(c,_,_) -> test c | _ -> false) then
let ilElemTy = GenType cenv.amap m eenv.tyenv elemTy
GenConstArray cenv cgbuf eenv ilElemTy elems' (fun buf -> function Expr.Const(c,_,_) -> write buf c | _ -> failwith "unreachable")
GenSequel cenv eenv.cloc cgbuf sequel
else
GenNewArraySimple cenv cgbuf eenv (elems,elemTy,m) sequel
and GenCoerce cenv cgbuf eenv (e,tgty,m,srcty) sequel =
// Is this an upcast?
if TypeRelations.TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcty &&
// Do an extra check - should not be needed
TypeRelations.TypeFeasiblySubsumesType 0 cenv.g cenv.amap m tgty TypeRelations.NoCoerce srcty then
begin
if (isInterfaceTy cenv.g tgty) then (
GenExpr cenv cgbuf eenv SPSuppress e Continue
let ilToTy = GenType cenv.amap m eenv.tyenv tgty
// Section "III.1.8.1.3 Merging stack states" of ECMA-335 implies that no unboxing
// is required, but we still push the coerce'd type on to the code gen buffer.
CG.EmitInstrs cgbuf (pop 1) (Push [ilToTy]) []
GenSequel cenv eenv.cloc cgbuf sequel
) else (
GenExpr cenv cgbuf eenv SPSuppress e sequel
)
end
else
GenExpr cenv cgbuf eenv SPSuppress e Continue
if not (isObjTy cenv.g srcty) then
let ilFromTy = GenType cenv.amap m eenv.tyenv srcty
CG.EmitInstrs cgbuf (pop 1) (Push [cenv.g.ilg.typ_Object]) [ I_box ilFromTy ]
if not (isObjTy cenv.g tgty) then
let ilToTy = GenType cenv.amap m eenv.tyenv tgty
CG.EmitInstrs cgbuf (pop 1) (Push [ilToTy]) [ I_unbox_any ilToTy ]
GenSequel cenv eenv.cloc cgbuf sequel
and GenReraise cenv cgbuf eenv (rtnty,m) sequel =
let ilReturnTy = GenType cenv.amap m eenv.tyenv rtnty
CG.EmitInstrs cgbuf (pop 0) Push0 [I_rethrow]
// [See comment related to I_throw].
// Rethrow does not return. Required to push dummy value on the stack.
// This follows prior behaviour by prim-types reraise<_>.
CG.EmitInstrs cgbuf (pop 0) (Push [ilReturnTy]) [AI_ldnull; I_unbox_any ilReturnTy ]
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetExnField cenv cgbuf eenv (e,ecref,fieldNum,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
let exnc = stripExnEqns ecref
let ty = GenExnType cenv.amap m eenv.tyenv ecref
CG.EmitInstrs cgbuf (pop 0) Push0 [ I_castclass ty]
let fld = List.item fieldNum exnc.TrueInstanceFieldsAsList
let ftyp = GenType cenv.amap m eenv.tyenv fld.FormalType
let mspec = mkILNonGenericInstanceMethSpecInTy (ty,"get_" + fld.Name, [], ftyp)
CG.EmitInstr cgbuf (pop 1) (Push [ftyp]) (mkNormalCall mspec)
GenSequel cenv eenv.cloc cgbuf sequel
and GenSetExnField cenv cgbuf eenv (e,ecref,fieldNum,e2,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
let exnc = stripExnEqns ecref
let ty = GenExnType cenv.amap m eenv.tyenv ecref
CG.EmitInstrs cgbuf (pop 0) Push0 [ I_castclass ty ]
let fld = List.item fieldNum exnc.TrueInstanceFieldsAsList
let ftyp = GenType cenv.amap m eenv.tyenv fld.FormalType
let ilFieldName = ComputeFieldName exnc fld
GenExpr cenv cgbuf eenv SPSuppress e2 Continue
CG.EmitInstr cgbuf (pop 2) Push0 (mkNormalStfld(mkILFieldSpecInTy (ty,ilFieldName,ftyp)))
GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel
and UnionCodeGen (cgbuf: CodeGenBuffer) =
{ new EraseUnions.ICodeGen<Mark> with
member __.CodeLabel(m) = m.CodeLabel
member __.GenerateDelayMark() = CG.GenerateDelayMark cgbuf "unionCodeGenMark"
member __.GenLocal(ilty) = cgbuf.AllocLocal([],ilty,false) |> uint16
member __.SetMarkToHere(m) = CG.SetMarkToHere cgbuf m
member __.MkInvalidCastExnNewobj () = mkInvalidCastExnNewobj cgbuf.mgbuf.cenv.g
member __.EmitInstr x = CG.EmitInstr cgbuf (pop 0) (Push []) x
member __.EmitInstrs xs = CG.EmitInstrs cgbuf (pop 0) (Push []) xs }
and GenUnionCaseProof cenv cgbuf eenv (e,ucref,tyargs,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs
let fty = EraseUnions.GetILTypeForAlternative cuspec idx
let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef
EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,avoidHelpers,cuspec,idx)
CG.EmitInstrs cgbuf (pop 1) (Push [fty]) [ ] // push/pop to match the line above
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel =
assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr cenv.g e))
GenExpr cenv cgbuf eenv SPSuppress e Continue
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs
let fty = actualTypOfIlxUnionField cuspec idx n
let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef
CG.EmitInstrs cgbuf (pop 1) (Push [fty]) (EraseUnions.mkLdData (avoidHelpers, cuspec, idx, n))
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel =
assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr cenv.g e))
GenExpr cenv cgbuf eenv SPSuppress e Continue
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs
let fty = actualTypOfIlxUnionField cuspec idx n
let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef
CG.EmitInstrs cgbuf (pop 1) (Push [ILType.Byref fty]) (EraseUnions.mkLdDataAddr (avoidHelpers, cuspec, idx, n))
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetUnionCaseTag cenv cgbuf eenv (e,tcref,tyargs,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
let cuspec = GenUnionSpec cenv.amap m eenv.tyenv tcref tyargs
let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib tcref
EraseUnions.emitLdDataTag cenv.g.ilg (UnionCodeGen cgbuf) (avoidHelpers, cuspec)
CG.EmitInstrs cgbuf (pop 1) (Push [cenv.g.ilg.typ_Int32]) [ ] // push/pop to match the line above
GenSequel cenv eenv.cloc cgbuf sequel
and GenSetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,e2,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv ucref tyargs
let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef
EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,avoidHelpers,cuspec,idx)
CG.EmitInstrs cgbuf (pop 1) (Push [cuspec.DeclaringType]) [ ] // push/pop to match the line above
GenExpr cenv cgbuf eenv SPSuppress e2 Continue
CG.EmitInstrs cgbuf (pop 2) Push0 (EraseUnions.mkStData (cuspec, idx, n))
GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel
and GenGetRecdFieldAddr cenv cgbuf eenv (e,f,tyargs,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
let fref = GenRecdFieldRef m cenv eenv.tyenv f tyargs
CG.EmitInstrs cgbuf (pop 1) (Push [ILType.Byref fref.ActualType]) [ I_ldflda fref ]
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetStaticFieldAddr cenv cgbuf eenv (f,tyargs,m) sequel =
let fspec = GenRecdFieldRef m cenv eenv.tyenv f tyargs
CG.EmitInstrs cgbuf (pop 0) (Push [ILType.Byref fspec.ActualType]) [ I_ldsflda fspec ]
GenSequel cenv eenv.cloc cgbuf sequel
and GenGetRecdField cenv cgbuf eenv (e,f,tyargs,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e Continue
GenFieldGet false cenv cgbuf eenv (f,tyargs,m)
GenSequel cenv eenv.cloc cgbuf sequel
and GenSetRecdField cenv cgbuf eenv (e1,f,tyargs,e2,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e1 Continue
GenExpr cenv cgbuf eenv SPSuppress e2 Continue
GenFieldStore false cenv cgbuf eenv (f,tyargs,m) sequel
and GenGetStaticField cenv cgbuf eenv (f,tyargs,m) sequel =
GenFieldGet true cenv cgbuf eenv (f,tyargs,m)
GenSequel cenv eenv.cloc cgbuf sequel
and GenSetStaticField cenv cgbuf eenv (f,tyargs,e2,m) sequel =
GenExpr cenv cgbuf eenv SPSuppress e2 Continue
GenFieldStore true cenv cgbuf eenv (f,tyargs,m) sequel
and mk_field_pops isStatic n = if isStatic then pop n else pop (n+1)
and GenFieldGet isStatic cenv cgbuf eenv (rfref:RecdFieldRef,tyargs,m) =
let fspec = GenRecdFieldRef m cenv eenv.tyenv rfref tyargs
let vol = if rfref.RecdField.IsVolatile then Volatile else Nonvolatile
if useGenuineField rfref.Tycon rfref.RecdField || entityRefInThisAssembly cenv.g.compilingFslib rfref.TyconRef then
let instr = if isStatic then I_ldsfld(vol, fspec) else I_ldfld (ILAlignment.Aligned, vol, fspec)
CG.EmitInstrs cgbuf (mk_field_pops isStatic 0) (Push [fspec.ActualType]) [ instr ]
else
let cconv = if isStatic then ILCallingConv.Static else ILCallingConv.Instance
let mspec = mkILMethSpecInTy (fspec.DeclaringType,cconv, "get_" + rfref.RecdField.rfield_id.idText, [], fspec.FormalType, [])
CG.EmitInstr cgbuf (mk_field_pops isStatic 0) (Push [fspec.ActualType]) (mkNormalCall mspec)
and GenFieldStore isStatic cenv cgbuf eenv (rfref:RecdFieldRef,tyargs,m) sequel =
let fspec = GenRecdFieldRef m cenv eenv.tyenv rfref tyargs
let fld = rfref.RecdField
if fld.IsMutable && not (useGenuineField rfref.Tycon fld) then
let cconv = if isStatic then ILCallingConv.Static else ILCallingConv.Instance
let mspec = mkILMethSpecInTy (fspec.DeclaringType, cconv, "set_" + fld.rfield_id.idText, [fspec.FormalType],ILType.Void,[])
CG.EmitInstr cgbuf (mk_field_pops isStatic 1) Push0 (mkNormalCall mspec)
else
let vol = if rfref.RecdField.IsVolatile then Volatile else Nonvolatile
let instr = if isStatic then I_stsfld (vol, fspec) else I_stfld (ILAlignment.Aligned, vol, fspec)
CG.EmitInstr cgbuf (mk_field_pops isStatic 1) Push0 instr
GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel
//--------------------------------------------------------------------------
// Generate arguments to calls
//--------------------------------------------------------------------------
/// Generate arguments to a call, unless the argument is the single lone "unit" value
/// to a method or value compiled as a method taking no arguments
and GenUntupledArgsDiscardingLoneUnit cenv cgbuf eenv m numObjArgs curriedArgInfos args =
match curriedArgInfos ,args with
// Type.M()
// new C()
| [[]],[arg] when numObjArgs = 0 ->
assert isUnitTy cenv.g (tyOfExpr cenv.g arg)
GenExpr cenv cgbuf eenv SPSuppress arg discard
// obj.M()
| [[_];[]],[arg1;arg2] when numObjArgs = 1 ->
assert isUnitTy cenv.g (tyOfExpr cenv.g arg2)
GenExpr cenv cgbuf eenv SPSuppress arg1 Continue
GenExpr cenv cgbuf eenv SPSuppress arg2 discard
| _ ->
(curriedArgInfos,args) ||> List.iter2 (fun argInfos x ->
GenUntupledArgExpr cenv cgbuf eenv m argInfos x Continue)
/// Codegen arguments
and GenUntupledArgExpr cenv cgbuf eenv m argInfos expr sequel =
let numRequiredExprs = List.length argInfos
assert (numRequiredExprs >= 1)
if numRequiredExprs = 1 then
GenExpr cenv cgbuf eenv SPSuppress expr sequel
elif isRefTupleExpr expr then
let es = tryDestRefTupleExpr expr
if es.Length <> numRequiredExprs then error(InternalError("GenUntupledArgExpr (2)",m));
es |> List.iter (fun x -> GenExpr cenv cgbuf eenv SPSuppress x Continue);
GenSequel cenv eenv.cloc cgbuf sequel
else
let ty = tyOfExpr cenv.g expr
let locv,loce = mkCompGenLocal m "arg" ty
let bind = mkCompGenBind locv expr
LocalScope "untuple" cgbuf (fun scopeMarks ->
let eenvinner = AllocStorageForBind cenv cgbuf scopeMarks eenv bind
GenBinding cenv cgbuf eenvinner bind;
let tys = destRefTupleTy cenv.g ty
assert (tys.Length = numRequiredExprs)
// TODO - tupInfoRef
argInfos |> List.iteri (fun i _ -> GenGetTupleField cenv cgbuf eenvinner (tupInfoRef (* TODO *),loce,tys,i,m) Continue);
GenSequel cenv eenv.cloc cgbuf sequel
)
//--------------------------------------------------------------------------
// Generate calls (try to detect direct calls)
//--------------------------------------------------------------------------
and GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel =
match (f,tyargs,args) with
(* Look for tailcall to turn into branch *)
| (Expr.Val(v,_,_),_,_) when
match ListAssoc.tryFind cenv.g.valRefEq v eenv.innerVals with
| Some (kind,_) ->
(not v.IsConstructor &&
(* when branch-calling methods we must have the right type parameters *)
(match kind with
| BranchCallClosure _ -> true
| BranchCallMethod (_,_,tps,_,_) ->
(List.lengthsEqAndForall2 (fun ty tp -> typeEquiv cenv.g ty (mkTyparTy tp)) tyargs tps)) &&
(* must be exact #args, ignoring tupling - we untuple if needed below *)
(let arityInfo =
match kind with
| BranchCallClosure arityInfo
| BranchCallMethod (arityInfo,_,_,_,_) -> arityInfo
arityInfo.Length = args.Length
) &&
(* no tailcall out of exception handler, etc. *)
(match sequelIgnoringEndScopesAndDiscard sequel with Return | ReturnVoid -> true | _ -> false))
| None -> false
->
let (kind,mark) = ListAssoc.find cenv.g.valRefEq v eenv.innerVals // already checked above in when guard
let ntmargs =
match kind with
| BranchCallClosure arityInfo ->
let ntmargs = List.foldBack (+) arityInfo 0
GenExprs cenv cgbuf eenv args
ntmargs
| BranchCallMethod (arityInfo,curriedArgInfos,_,ntmargs,numObjArgs) ->
assert (curriedArgInfos.Length = arityInfo.Length )
assert (curriedArgInfos.Length = args.Length)
//assert (curriedArgInfos.Length = ntmargs )
GenUntupledArgsDiscardingLoneUnit cenv cgbuf eenv m numObjArgs curriedArgInfos args
if v.IsExtensionMember then
match curriedArgInfos, args with
| [[]],[_] when numObjArgs = 0 -> (ntmargs-1)
| [[_];[]],[_;_] when numObjArgs = 1 -> (ntmargs-1)
| _ -> ntmargs
else ntmargs
for i = ntmargs - 1 downto 0 do
CG.EmitInstrs cgbuf (pop 1) Push0 [ I_starg (uint16 (i+cgbuf.PreallocatedArgCount)) ]
CG.EmitInstrs cgbuf (pop 0) Push0 [ I_br mark.CodeLabel ]
GenSequelEndScopes cgbuf sequel
// PhysicalEquality becomes cheap reference equality once
// a nominal type is known. We can't replace it for variable types since
// a "ceq" instruction can't be applied to variable type values.
| (Expr.Val(v,_,_),[ty],[arg1;arg2]) when
(valRefEq cenv.g v cenv.g.reference_equality_inner_vref)
&& isAppTy cenv.g ty ->
GenExpr cenv cgbuf eenv SPSuppress arg1 Continue
GenExpr cenv cgbuf eenv SPSuppress arg2 Continue
CG.EmitInstr cgbuf (pop 2) (Push [cenv.g.ilg.typ_Bool]) AI_ceq
GenSequel cenv eenv.cloc cgbuf sequel
// Emit "methodhandleof" calls as ldtoken instructions
//
// The token for the "GenericMethodDefinition" is loaded
| Expr.Val(v,_,m),_,[arg] when valRefEq cenv.g v cenv.g.methodhandleof_vref ->
let (|OptionalCoerce|) = function Expr.Op(TOp.Coerce _,_,[arg],_) -> arg | x -> x
let (|OptionalTyapp|) = function Expr.App(f,_,[_],[],_) -> f | x -> x
match arg with
// Generate ldtoken instruction for "methodhandleof(fun (a,b,c) -> f(a,b,c))"
// where f is an F# function value or F# method
| Expr.Lambda(_,_,_,_,Expr.App(OptionalCoerce(OptionalTyapp(Expr.Val(vref,_,_))),_,_,_,_),_,_) ->
let storage = StorageForValRef m vref eenv
match storage with
| Method (_,_,mspec,_,_,_,_) ->
CG.EmitInstr cgbuf (pop 0) (Push [cenv.g.iltyp_RuntimeMethodHandle]) (I_ldtoken (ILToken.ILMethod mspec))
| _ ->
errorR(Error(FSComp.SR.ilxgenUnexpectedArgumentToMethodHandleOfDuringCodegen(), m))
// Generate ldtoken instruction for "methodhandleof(fun (a,b,c) -> obj.M(a,b,c))"
// where M is an IL method.
| Expr.Lambda(_,_,_,_,Expr.Op(TOp.ILCall(_,_,valu,_,_,_,_,ilMethRef,actualTypeInst,actualMethInst,_),_,_,_),_,_) ->
let boxity = (if valu then AsValue else AsObject)
let mkFormalParams gparams = gparams |> DropErasedTyargs |> List.mapi (fun n _gf -> mkILTyvarTy (uint16 n))
let ilGenericMethodSpec = IL.mkILMethSpec (ilMethRef, boxity, mkFormalParams actualTypeInst, mkFormalParams actualMethInst)
let i = I_ldtoken (ILToken.ILMethod ilGenericMethodSpec)
CG.EmitInstr cgbuf (pop 0) (Push [cenv.g.iltyp_RuntimeMethodHandle]) i
| _ ->
System.Diagnostics.Debug.Assert(false,sprintf "Break for invalid methodhandleof argument expression")
//System.Diagnostics.Debugger.Break()
errorR(Error(FSComp.SR.ilxgenUnexpectedArgumentToMethodHandleOfDuringCodegen(), m))
GenSequel cenv eenv.cloc cgbuf sequel
// Optimize calls to top methods when given "enough" arguments.
| Expr.Val(vref,valUseFlags,_),_,_
when
(let storage = StorageForValRef m vref eenv
match storage with
| Method (topValInfo,vref,_,_,_,_,_) ->
(let tps,argtys,_,_ = GetTopValTypeInFSharpForm cenv.g topValInfo vref.Type m
tps.Length = tyargs.Length &&
argtys.Length <= args.Length)
| _ -> false) ->
let storage = StorageForValRef m vref eenv
match storage with
| Method (topValInfo,vref,mspec,_,_,_,_) ->
let nowArgs,laterArgs =
let _,curriedArgInfos,_,_ = GetTopValTypeInFSharpForm cenv.g topValInfo vref.Type m
List.splitAt curriedArgInfos.Length args
let actualRetTy = applyTys cenv.g vref.Type (tyargs,nowArgs)
let _,curriedArgInfos,returnTy,_ = GetTopValTypeInCompiledForm cenv.g topValInfo vref.Type m
let ilTyArgs = GenTypeArgs cenv.amap m eenv.tyenv tyargs
// For instance method calls chop off some type arguments, which are already
// carried by the class. Also work out if it's a virtual call.
let _,virtualCall,newobj,isSuperInit,isSelfInit,_,_,_ = GetMemberCallInfo cenv.g (vref,valUseFlags) in
// numEnclILTypeArgs will include unit-of-measure args, unfortunately. For now, just cut-and-paste code from GetMemberCallInfo
// @REVIEW: refactor this
let numEnclILTypeArgs =
match vref.MemberInfo with
| Some _ when not (vref.IsExtensionMember) ->
List.length(vref.MemberApparentEntity.TyparsNoRange |> DropErasedTypars)
| _ -> 0
let (ilEnclArgTys,ilMethArgTys) =
if ilTyArgs.Length < numEnclILTypeArgs then error(InternalError("length mismatch",m))
List.splitAt numEnclILTypeArgs ilTyArgs
let boxity = mspec.DeclaringType.Boxity
let mspec = mkILMethSpec (mspec.MethodRef, boxity,ilEnclArgTys,ilMethArgTys)
// "Unit" return types on static methods become "void"
let mustGenerateUnitAfterCall = Option.isNone returnTy
let ccallInfo =
match valUseFlags with
| PossibleConstrainedCall ty -> Some ty
| _ -> None
let isBaseCall = match valUseFlags with VSlotDirectCall -> true | _ -> false
let isTailCall =
if isNil laterArgs && not isSelfInit then
let isDllImport = IsValRefIsDllImport cenv.g vref
let hasByrefArg = mspec.FormalArgTypes |> List.exists (function ILType.Byref _ -> true | _ -> false)
let makesNoCriticalTailcalls = vref.MakesNoCriticalTailcalls
CanTailcall((boxity=AsValue),ccallInfo,eenv.withinSEH,hasByrefArg,mustGenerateUnitAfterCall,isDllImport,isSelfInit,makesNoCriticalTailcalls,sequel)
else Normalcall
let useICallVirt = virtualCall || useCallVirt cenv boxity mspec isBaseCall
let callInstr =
match valUseFlags with
| PossibleConstrainedCall ty ->
let ilThisTy = GenType cenv.amap m eenv.tyenv ty
I_callconstraint ( isTailCall, ilThisTy,mspec,None)
| _ ->
if newobj then I_newobj (mspec, None)
elif useICallVirt then I_callvirt (isTailCall, mspec, None)
else I_call (isTailCall, mspec, None)
// ok, now we're ready to generate
if isSuperInit || isSelfInit then
CG.EmitInstrs cgbuf (pop 0) (Push [mspec.DeclaringType ]) [ mkLdarg0 ]
GenUntupledArgsDiscardingLoneUnit cenv cgbuf eenv m vref.NumObjArgs curriedArgInfos nowArgs
// Generate laterArgs (for effects) and save
LocalScope "callstack" cgbuf (fun scopeMarks ->
let whereSaved,eenv =
(eenv,laterArgs) ||> List.mapFold (fun eenv laterArg ->
// Only save arguments that have effects
if Optimizer.ExprHasEffect cenv.g laterArg then
let ilTy = laterArg |> tyOfExpr cenv.g |> GenType cenv.amap m eenv.tyenv
let loc,eenv = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("arg",m), ilTy, false) scopeMarks
GenExpr cenv cgbuf eenv SPSuppress laterArg Continue
EmitSetLocal cgbuf loc
Choice1Of2 (ilTy,loc),eenv
else
Choice2Of2 laterArg, eenv)
let nargs = mspec.FormalArgTypes.Length
CG.EmitInstr cgbuf (pop (nargs + (if mspec.CallingConv.IsStatic || newobj then 0 else 1)))
(if mustGenerateUnitAfterCall || isSuperInit || isSelfInit then Push0 else (Push [(GenType cenv.amap m eenv.tyenv actualRetTy)])) callInstr
// For isSuperInit, load the 'this' pointer as the pretend 'result' of the operation. It will be popped again in most cases
if isSuperInit then CG.EmitInstrs cgbuf (pop 0) (Push [mspec.DeclaringType]) [ mkLdarg0 ]
// When generating debug code, generate a 'nop' after a 'call' that returns 'void'
// This is what C# does, as it allows the call location to be maintained correctly in the stack frame
if cenv.opts.generateDebugSymbols && mustGenerateUnitAfterCall && (isTailCall = Normalcall) then
CG.EmitInstrs cgbuf (pop 0) Push0 [ AI_nop ]
if isNil laterArgs then
assert isNil whereSaved
// Generate the "unit" value if necessary
CommitCallSequel cenv eenv m eenv.cloc cgbuf mustGenerateUnitAfterCall sequel
else
//printfn "%d EXTRA ARGS IN TOP APP at %s" laterArgs.Length (stringOfRange m)
whereSaved |> List.iter (function
| Choice1Of2 (ilTy,loc) -> EmitGetLocal cgbuf ilTy loc
| Choice2Of2 expr -> GenExpr cenv cgbuf eenv SPSuppress expr Continue)
GenIndirectCall cenv cgbuf eenv (actualRetTy,[],laterArgs,m) sequel)
| _ -> failwith "??"
// This case is for getting/calling a value, when we can't call it directly.
// However, we know the type instantiation for the value.
// In this case we can often generate a type-specific local expression for the value.
// This reduces the number of dynamic type applications.
| (Expr.Val(vref,_,_),_,_) ->
GenGetValRefAndSequel cenv cgbuf eenv m vref (Some (tyargs,args,m,sequel))
| _ ->
(* worst case: generate a first-class function value and call *)
GenExpr cenv cgbuf eenv SPSuppress f Continue
GenArgsAndIndirectCall cenv cgbuf eenv (fty,tyargs,args,m) sequel
and CanTailcall (hasStructObjArg, ccallInfo, withinSEH, hasByrefArg, mustGenerateUnitAfterCall, isDllImport, isSelfInit, makesNoCriticalTailcalls, sequel) =
// Can't tailcall with a struct object arg since it involves a byref
// Can't tailcall with a .NET 2.0 generic constrained call since it involves a byref
if not hasStructObjArg && Option.isNone ccallInfo && not withinSEH && not hasByrefArg && not isDllImport && not isSelfInit && not makesNoCriticalTailcalls &&
// We can tailcall even if we need to generate "unit", as long as we're about to throw the value away anyway as par of the return.
// We can tailcall if we don't need to generate "unit", as long as we're about to return.
(match sequelIgnoreEndScopes sequel with
| ReturnVoid | Return -> not mustGenerateUnitAfterCall
| DiscardThen ReturnVoid -> mustGenerateUnitAfterCall
| _ -> false)
then Tailcall
else Normalcall
and GenNamedLocalTyFuncCall cenv (cgbuf: CodeGenBuffer) eenv ty cloinfo tyargs m =
let ilContractClassTyargs =
cloinfo.localTypeFuncContractFreeTypars
|> List.map mkTyparTy
|> GenTypeArgs cenv.amap m eenv.tyenv
let ilTyArgs = tyargs |> GenTypeArgs cenv.amap m eenv.tyenv
let _,(ilContractMethTyargs: ILGenericParameterDefs),(ilContractCloTySpec:ILTypeSpec),ilContractFormalRetTy =
GenNamedLocalTypeFuncContractInfo cenv eenv m cloinfo
let ilContractTy = mkILBoxedTy ilContractCloTySpec.TypeRef ilContractClassTyargs
if not (ilContractMethTyargs.Length = ilTyArgs.Length) then errorR(Error(FSComp.SR.ilIncorrectNumberOfTypeArguments(),m))
// Local TyFunc are represented as a $contract type. they currently get stored in a value of type object
// Recover result (value or reference types) via unbox_any.
CG.EmitInstrs cgbuf (pop 1) (Push [ilContractTy]) [I_unbox_any ilContractTy]
let actualRetTy = applyTys cenv.g ty (tyargs,[])
let ilDirectInvokeMethSpec = mkILInstanceMethSpecInTy(ilContractTy, "DirectInvoke", [], ilContractFormalRetTy, ilTyArgs)
let ilActualRetTy = GenType cenv.amap m eenv.tyenv actualRetTy
CountCallFuncInstructions()
CG.EmitInstr cgbuf (pop 1) (Push [ilActualRetTy]) (mkNormalCallvirt ilDirectInvokeMethSpec)
actualRetTy
/// Generate an indirect call, converting to an ILX callfunc instruction
and GenArgsAndIndirectCall cenv cgbuf eenv (functy,tyargs,args,m) sequel =
// Generate the arguments to the indirect call
GenExprs cenv cgbuf eenv args
GenIndirectCall cenv cgbuf eenv (functy,tyargs,args,m) sequel
/// Generate an indirect call, converting to an ILX callfunc instruction
and GenIndirectCall cenv cgbuf eenv (functy,tyargs,args,m) sequel =
// Fold in the new types into the environment as we generate the formal types.
let ilxClosureApps =
// keep only non-erased type arguments when computing indirect call
let tyargs = DropErasedTyargs tyargs
let typars, formalFuncTy = tryDestForallTy cenv.g functy
let feenv = eenv.tyenv.Add typars
// This does two phases: REVIEW: the code is too complex for what it's achieving and should be rewritten
let formalRetTy,appBuilder =
List.fold
(fun (formalFuncTy,sofar) _ ->
let dty,rty = destFunTy cenv.g formalFuncTy
(rty,(fun acc -> sofar (Apps_app(GenType cenv.amap m feenv dty,acc)))))
(formalFuncTy,id)
args
let ilxRetApps = Apps_done (GenType cenv.amap m feenv formalRetTy)
List.foldBack (fun tyarg acc -> Apps_tyapp(GenType cenv.amap m eenv.tyenv tyarg,acc)) tyargs (appBuilder ilxRetApps)
let actualRetTy = applyTys cenv.g functy (tyargs, args)
let ilActualRetTy = GenType cenv.amap m eenv.tyenv actualRetTy
// Check if any byrefs are involved to make sure we don't tailcall
let hasByrefArg =
let rec check x =
match x with
| Apps_tyapp(_,apps) -> check apps
| Apps_app(arg,apps) -> IsILTypeByref arg || check apps
| _ -> false
check ilxClosureApps
let isTailCall = CanTailcall(false,None,eenv.withinSEH,hasByrefArg,false,false,false,false,sequel)
CountCallFuncInstructions()
// Generate the code code an ILX callfunc operation
let instrs = EraseClosures.mkCallFunc cenv.g.ilxPubCloEnv (fun ty -> cgbuf.AllocLocal([], ty,false) |> uint16) eenv.tyenv.Count isTailCall ilxClosureApps
CG.EmitInstrs cgbuf (pop (1+args.Length)) (Push [ilActualRetTy]) instrs
// Done compiling indirect call...
GenSequel cenv eenv.cloc cgbuf sequel
//--------------------------------------------------------------------------
// Generate try expressions
//--------------------------------------------------------------------------
and GenTry cenv cgbuf eenv scopeMarks (e1,m,resty,spTry) =
let sp =
match spTry with
| SequencePointAtTry m -> CG.EmitSeqPoint cgbuf m; SPAlways
| SequencePointInBodyOfTry -> SPAlways
| NoSequencePointAtTry -> SPSuppress
let stack,eenvinner = EmitSaveStack cenv cgbuf eenv m scopeMarks
let startTryMark = CG.GenerateMark cgbuf "startTryMark"
let endTryMark = CG.GenerateDelayMark cgbuf "endTryMark"
let afterHandler = CG.GenerateDelayMark cgbuf "afterHandler"
let eenvinner = {eenvinner with withinSEH = true}
let ilResultTy = GenType cenv.amap m eenvinner.tyenv resty
let whereToSave,eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("tryres",m),ilResultTy, false) (startTryMark,endTryMark)
// Generate the body of the try. In the normal case (SequencePointAtTry) we generate a sequence point
// both on the 'try' keyword and on the start of the expression in the 'try'. For inlined code and
// compiler generated 'try' blocks (i.e. NoSequencePointAtTry, used for the try/finally implicit
// in a 'use' or 'foreach'), we suppress the sequence point
GenExpr cenv cgbuf eenvinner sp e1 (LeaveHandler (false, whereToSave,afterHandler))
CG.SetMarkToHere cgbuf endTryMark
let tryMarks = (startTryMark.CodeLabel, endTryMark.CodeLabel)
whereToSave,eenvinner,stack,tryMarks,afterHandler,ilResultTy
and GenTryCatch cenv cgbuf eenv (e1,vf:Val,ef,vh:Val,eh,m,resty,spTry,spWith) sequel =
// Save the stack - gross because IL flushes the stack at the exn. handler
// note: eenvinner notes spill vars are live
LocalScope "trystack" cgbuf (fun scopeMarks ->
let whereToSave,eenvinner,stack,tryMarks,afterHandler,ilResultTy = GenTry cenv cgbuf eenv scopeMarks (e1,m,resty,spTry)
// Now the filter and catch blocks
let seh =
if cenv.opts.generateFilterBlocks then
let startOfFilter = CG.GenerateMark cgbuf "startOfFilter"
let afterFilter = CG.GenerateDelayMark cgbuf "afterFilter"
let (sequelOnBranches,afterJoin,stackAfterJoin,sequelAfterJoin) = GenJoinPoint cenv cgbuf "filter" eenv cenv.g.int_ty m EndFilter
begin
// We emit the sequence point for the 'with' keyword span on the start of the filter
// block. However the targets of the filter block pattern matching should not get any
// sequence points (they will be 'true'/'false' values indicating if the exception has been
// caught or not).
//
// The targets of the handler block DO get sequence points. Thus the expected behaviour
// for a try/with with a complex pattern is that we hit the "with" before the filter is run
// and then jump to the handler for the successful catch (or continue with exception handling
// if the filter fails)
match spWith with
| SequencePointAtWith m -> CG.EmitSeqPoint cgbuf m
| NoSequencePointAtWith -> ()
CG.SetStack cgbuf [cenv.g.ilg.typ_Object]
let _,eenvinner = AllocLocalVal cenv cgbuf vf eenvinner None (startOfFilter,afterFilter)
CG.EmitInstr cgbuf (pop 1) (Push [cenv.g.iltyp_Exception]) (I_castclass cenv.g.iltyp_Exception)
GenStoreVal cgbuf eenvinner vf.Range vf
// Why SPSuppress? Because we do not emit a sequence point at the start of the List.filter - we've already put one on
// the 'with' keyword above
GenExpr cenv cgbuf eenvinner SPSuppress ef sequelOnBranches
CG.SetMarkToHere cgbuf afterJoin
CG.SetStack cgbuf stackAfterJoin
GenSequel cenv eenv.cloc cgbuf sequelAfterJoin
end
let endOfFilter = CG.GenerateMark cgbuf "endOfFilter"
let filterMarks = (startOfFilter.CodeLabel, endOfFilter.CodeLabel)
CG.SetMarkToHere cgbuf afterFilter
let startOfHandler = CG.GenerateMark cgbuf "startOfHandler"
begin
CG.SetStack cgbuf [cenv.g.ilg.typ_Object]
let _,eenvinner = AllocLocalVal cenv cgbuf vh eenvinner None (startOfHandler,afterHandler)
CG.EmitInstr cgbuf (pop 1) (Push [cenv.g.iltyp_Exception]) (I_castclass cenv.g.iltyp_Exception)
GenStoreVal cgbuf eenvinner vh.Range vh
GenExpr cenv cgbuf eenvinner SPAlways eh (LeaveHandler (false, whereToSave,afterHandler))
end
let endOfHandler = CG.GenerateMark cgbuf "endOfHandler"
let handlerMarks = (startOfHandler.CodeLabel, endOfHandler.CodeLabel)
ILExceptionClause.FilterCatch(filterMarks, handlerMarks)
else
let startOfHandler = CG.GenerateMark cgbuf "startOfHandler"
begin
match spWith with
| SequencePointAtWith m -> CG.EmitSeqPoint cgbuf m
| NoSequencePointAtWith -> ()
CG.SetStack cgbuf [cenv.g.ilg.typ_Object]
let _,eenvinner = AllocLocalVal cenv cgbuf vh eenvinner None (startOfHandler,afterHandler)
CG.EmitInstr cgbuf (pop 1) (Push [cenv.g.iltyp_Exception]) (I_castclass cenv.g.iltyp_Exception)
GenStoreVal cgbuf eenvinner m vh
GenExpr cenv cgbuf eenvinner SPAlways eh (LeaveHandler (false, whereToSave,afterHandler))
end
let endOfHandler = CG.GenerateMark cgbuf "endOfHandler"
let handlerMarks = (startOfHandler.CodeLabel, endOfHandler.CodeLabel)
ILExceptionClause.TypeCatch(cenv.g.ilg.typ_Object, handlerMarks)
cgbuf.EmitExceptionClause
{ Clause = seh
Range= tryMarks }
CG.SetMarkToHere cgbuf afterHandler
CG.SetStack cgbuf []
cgbuf.EmitStartOfHiddenCode()
(* Restore the stack and load the result *)
EmitRestoreStack cgbuf stack (* RESTORE *)
EmitGetLocal cgbuf ilResultTy whereToSave
GenSequel cenv eenv.cloc cgbuf sequel
)
and GenTryFinally cenv cgbuf eenv (bodyExpr,handlerExpr,m,resty,spTry,spFinally) sequel =
// Save the stack - needed because IL flushes the stack at the exn. handler
// note: eenvinner notes spill vars are live
LocalScope "trystack" cgbuf (fun scopeMarks ->
let whereToSave,eenvinner,stack,tryMarks,afterHandler,ilResultTy = GenTry cenv cgbuf eenv scopeMarks (bodyExpr,m,resty,spTry)
// Now the catch/finally block
let startOfHandler = CG.GenerateMark cgbuf "startOfHandler"
CG.SetStack cgbuf []
let sp =
match spFinally with
| SequencePointAtFinally m -> CG.EmitSeqPoint cgbuf m; SPAlways
| NoSequencePointAtFinally -> SPSuppress
GenExpr cenv cgbuf eenvinner sp handlerExpr (LeaveHandler (true, whereToSave,afterHandler))
let endOfHandler = CG.GenerateMark cgbuf "endOfHandler"
let handlerMarks = (startOfHandler.CodeLabel, endOfHandler.CodeLabel)
cgbuf.EmitExceptionClause
{ Clause = ILExceptionClause.Finally(handlerMarks)
Range = tryMarks }
CG.SetMarkToHere cgbuf afterHandler
CG.SetStack cgbuf []
// Restore the stack and load the result
cgbuf.EmitStartOfHiddenCode()
EmitRestoreStack cgbuf stack
EmitGetLocal cgbuf ilResultTy whereToSave
GenSequel cenv eenv.cloc cgbuf sequel
)
//--------------------------------------------------------------------------
// Generate for-loop
//--------------------------------------------------------------------------
and GenForLoop cenv cgbuf eenv (spFor,v,e1,dir,e2,loopBody,m) sequel =
// The JIT/NGen eliminate array-bounds checks for C# loops of form:
// for(int i=0; i < (#ldlen arr#); i++) { ... arr[i] ... }
// Here
// dir = BI_blt indicates an optimized for loop that fits C# form that evaluates its 'end' argument each time around
// dir = BI_ble indicates a normal F# for loop that evaluates its argument only once
//
// It is also important that we follow C# IL-layout exactly "prefix, jmp test, body, test, finish" for JIT/NGEN.
let start = CG.GenerateMark cgbuf "for_start"
let finish = CG.GenerateDelayMark cgbuf "for_finish"
let inner = CG.GenerateDelayMark cgbuf "for_inner"
let test = CG.GenerateDelayMark cgbuf "for_test"
let stack,eenvinner = EmitSaveStack cenv cgbuf eenv m (start,finish)
let isUp = (match dir with | FSharpForLoopUp | CSharpForLoopUp -> true | FSharpForLoopDown -> false)
let isFSharpStyle = (match dir with FSharpForLoopUp | FSharpForLoopDown -> true | CSharpForLoopUp -> false)
let finishIdx,eenvinner =
if isFSharpStyle then
let v,eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("endLoop",m), cenv.g.ilg.typ_Int32, false) (start,finish)
v, eenvinner
else
-1,eenvinner
let _, eenvinner = AllocLocalVal cenv cgbuf v eenvinner None (start,finish) (* note: eenvStack noted stack spill vars are live *)
match spFor with
| SequencePointAtForLoop(spStart) -> CG.EmitSeqPoint cgbuf spStart
| NoSequencePointAtForLoop -> ()
GenExpr cenv cgbuf eenv SPSuppress e1 Continue
GenStoreVal cgbuf eenvinner m v
if isFSharpStyle then
GenExpr cenv cgbuf eenvinner SPSuppress e2 Continue
EmitSetLocal cgbuf finishIdx
EmitGetLocal cgbuf cenv.g.ilg.typ_Int32 finishIdx
GenGetLocalVal cenv cgbuf eenvinner e2.Range v None
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp ((if isUp then BI_blt else BI_bgt),finish.CodeLabel))
else
CG.EmitInstr cgbuf (pop 0) Push0 (I_br test.CodeLabel)
// .inner
CG.SetMarkToHere cgbuf inner
// <loop body>
GenExpr cenv cgbuf eenvinner SPAlways loopBody discard
// v++ or v--
GenGetLocalVal cenv cgbuf eenvinner e2.Range v None
CG.EmitInstr cgbuf (pop 0) (Push [cenv.g.ilg.typ_Int32]) (mkLdcInt32 1)
CG.EmitInstr cgbuf (pop 1) Push0 (if isUp then AI_add else AI_sub)
GenStoreVal cgbuf eenvinner m v
// .text
CG.SetMarkToHere cgbuf test
// FSharpForLoopUp: if v <> e2 + 1 then goto .inner
// FSharpForLoopDown: if v <> e2 - 1 then goto .inner
// CSharpStyle: if v < e2 then goto .inner
match spFor with
| SequencePointAtForLoop(spStart) -> CG.EmitSeqPoint cgbuf spStart
| NoSequencePointAtForLoop -> () //CG.EmitSeqPoint cgbuf e2.Range
GenGetLocalVal cenv cgbuf eenvinner e2.Range v None
let cmp = match dir with FSharpForLoopUp | FSharpForLoopDown -> BI_bne_un | CSharpForLoopUp -> BI_blt
let e2Sequel = (CmpThenBrOrContinue (pop 2, [ I_brcmp(cmp,inner.CodeLabel) ]))
if isFSharpStyle then
EmitGetLocal cgbuf cenv.g.ilg.typ_Int32 finishIdx
CG.EmitInstr cgbuf (pop 0) (Push [cenv.g.ilg.typ_Int32]) (mkLdcInt32 1)
CG.EmitInstr cgbuf (pop 1) Push0 (if isUp then AI_add else AI_sub)
GenSequel cenv eenv.cloc cgbuf e2Sequel
else
GenExpr cenv cgbuf eenv SPSuppress e2 e2Sequel
// .finish - loop-exit here
CG.SetMarkToHere cgbuf finish
// Restore the stack and load the result
EmitRestoreStack cgbuf stack
GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel
//--------------------------------------------------------------------------
// Generate while-loop
//--------------------------------------------------------------------------
and GenWhileLoop cenv cgbuf eenv (spWhile,e1,e2,m) sequel =
let finish = CG.GenerateDelayMark cgbuf "while_finish"
let startTest = CG.GenerateMark cgbuf "startTest"
match spWhile with
| SequencePointAtWhileLoop(spStart) -> CG.EmitSeqPoint cgbuf spStart
| NoSequencePointAtWhileLoop -> ()
// SEQUENCE POINTS: Emit a sequence point to cover all of 'while e do'
GenExpr cenv cgbuf eenv SPSuppress e1 (CmpThenBrOrContinue (pop 1, [ I_brcmp(BI_brfalse,finish.CodeLabel) ]))
GenExpr cenv cgbuf eenv SPAlways e2 (DiscardThen (Br startTest))
CG.SetMarkToHere cgbuf finish
// SEQUENCE POINTS: Emit a sequence point to cover 'done' if present
GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel
//--------------------------------------------------------------------------
// Generate seq
//--------------------------------------------------------------------------
and GenSequential cenv cgbuf eenv spIn (e1,e2,specialSeqFlag,spSeq,_m) sequel =
// Compiler generated sequential executions result in suppressions of sequence points on both
// left and right of the sequence
let spAction,spExpr =
(match spSeq with
| SequencePointsAtSeq -> SPAlways,SPAlways
| SuppressSequencePointOnExprOfSequential -> SPSuppress,spIn
| SuppressSequencePointOnStmtOfSequential -> spIn,SPSuppress)
match specialSeqFlag with
| NormalSeq ->
GenExpr cenv cgbuf eenv spAction e1 discard
GenExpr cenv cgbuf eenv spExpr e2 sequel
| ThenDoSeq ->
GenExpr cenv cgbuf eenv spExpr e1 Continue
GenExpr cenv cgbuf eenv spAction e2 discard
GenSequel cenv eenv.cloc cgbuf sequel
//--------------------------------------------------------------------------
// Generate IL assembly code.
// Polymorphic IL/ILX instructions may be instantiated when polymorphic code is inlined.
// We must implement this for the few uses of polymorphic instructions
// in the standard libarary.
//--------------------------------------------------------------------------
and GenAsmCode cenv cgbuf eenv (il,tyargs,args,returnTys,m) sequel =
let ilTyArgs = GenTypesPermitVoid cenv.amap m eenv.tyenv tyargs
let ilReturnTys = GenTypesPermitVoid cenv.amap m eenv.tyenv returnTys
let ilAfterInst =
il |> List.filter (function AI_nop -> false | _ -> true)
|> List.map (fun i ->
let err s =
errorR(InternalError(sprintf "%s: bad instruction: %A" s i,m))
let modFieldSpec fspec =
if isNil ilTyArgs then
fspec
else
{fspec with DeclaringType=
let ty = fspec.DeclaringType
let tspec = ty.TypeSpec
mkILTy ty.Boxity (mkILTySpec(tspec.TypeRef, ilTyArgs)) }
match i,ilTyArgs with
| I_unbox_any (ILType.TypeVar _) ,[tyarg] -> I_unbox_any (tyarg)
| I_box (ILType.TypeVar _) ,[tyarg] -> I_box (tyarg)
| I_isinst (ILType.TypeVar _) ,[tyarg] -> I_isinst (tyarg)
| I_castclass (ILType.TypeVar _) ,[tyarg] -> I_castclass (tyarg)
| I_newarr (shape,ILType.TypeVar _) ,[tyarg] -> I_newarr (shape,tyarg)
| I_ldelem_any (shape,ILType.TypeVar _) ,[tyarg] -> I_ldelem_any (shape,tyarg)
| I_ldelema (ro,_,shape,ILType.TypeVar _) ,[tyarg] -> I_ldelema (ro,false,shape,tyarg)
| I_stelem_any (shape,ILType.TypeVar _) ,[tyarg] -> I_stelem_any (shape,tyarg)
| I_ldobj (a,b,ILType.TypeVar _) ,[tyarg] -> I_ldobj (a,b,tyarg)
| I_stobj (a,b,ILType.TypeVar _) ,[tyarg] -> I_stobj (a,b,tyarg)
| I_ldtoken (ILToken.ILType (ILType.TypeVar _)),[tyarg] -> I_ldtoken (ILToken.ILType (tyarg))
| I_sizeof (ILType.TypeVar _) ,[tyarg] -> I_sizeof (tyarg)
| I_cpobj (ILType.TypeVar _) ,[tyarg] -> I_cpobj (tyarg) // currently unused, added for forward compat, see https://visualfsharp.codeplex.com/SourceControl/network/forks/jackpappas/fsharpcontrib/contribution/7134
| I_initobj (ILType.TypeVar _) ,[tyarg] -> I_initobj (tyarg) // currently unused, added for forward compat, see https://visualfsharp.codeplex.com/SourceControl/network/forks/jackpappas/fsharpcontrib/contribution/7134
| I_ldfld (al,vol,fspec) ,_ -> I_ldfld (al,vol,modFieldSpec fspec)
| I_ldflda (fspec) ,_ -> I_ldflda (modFieldSpec fspec)
| I_stfld (al,vol,fspec) ,_ -> I_stfld (al,vol,modFieldSpec fspec)
| I_stsfld (vol,fspec) ,_ -> I_stsfld (vol,modFieldSpec fspec)
| I_ldsfld (vol,fspec) ,_ -> I_ldsfld (vol,modFieldSpec fspec)
| I_ldsflda (fspec) ,_ -> I_ldsflda (modFieldSpec fspec)
| EI_ilzero(ILType.TypeVar _) ,[tyarg] -> EI_ilzero(tyarg)
| AI_nop,_ -> i
// These are embedded in the IL for a an initonly ldfld, i.e.
// here's the relevant comment from tc.fs
// "Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr."
| _ ->
if not (isNil tyargs) then err "Bad polymorphic IL instruction"
i)
match ilAfterInst,args,sequel,ilReturnTys with
| [ EI_ilzero _ ], _, _, _ ->
match tyargs with
| [ty] ->
GenDefaultValue cenv cgbuf eenv (ty,m)
GenSequel cenv eenv.cloc cgbuf sequel
| _ -> failwith "Bad polymorphic IL instruction"
// Strip off any ("ceq" x false) when the sequel is a comparison branch and change the BI_brfalse to a BI_brtrue
// This is the instruction sequence for "not"
// For these we can just generate the argument and change the test (from a brfalse to a brtrue and vice versa)
| ([ AI_ceq ],
[arg1; Expr.Const((Const.Bool false | Const.SByte 0y| Const.Int16 0s | Const.Int32 0 | Const.Int64 0L | Const.Byte 0uy| Const.UInt16 0us | Const.UInt32 0u | Const.UInt64 0UL),_,_) ],
CmpThenBrOrContinue(1, [I_brcmp (((BI_brfalse | BI_brtrue) as bi),label1) ]),
_) ->
let bi = match bi with BI_brtrue -> BI_brfalse | _ -> BI_brtrue
GenExpr cenv cgbuf eenv SPSuppress arg1 (CmpThenBrOrContinue(pop 1, [ I_brcmp (bi,label1) ]))
// Query; when do we get a 'ret' in IL assembly code?
| [ I_ret ], [arg1],sequel,[_ilRetTy] ->
GenExpr cenv cgbuf eenv SPSuppress arg1 Continue
CG.EmitInstr cgbuf (pop 1) Push0 I_ret
GenSequelEndScopes cgbuf sequel
// Query; when do we get a 'ret' in IL assembly code?
| [ I_ret ], [],sequel,[_ilRetTy] ->
CG.EmitInstr cgbuf (pop 1) Push0 I_ret
GenSequelEndScopes cgbuf sequel
// 'throw' instructions are a bit of a problem - e.g. let x = (throw ...) in ... expects a value *)
// to be left on the stack. But dead-code checking by some versions of the .NET verifier *)
// mean that we can't just have fake code after the throw to generate the fake value *)
// (nb. a fake value can always be generated by a "ldnull unbox.any ty" sequence *)
// So in the worst case we generate a fake (never-taken) branch to a piece of code to generate *)
// the fake value *)
| [ I_throw ], [arg1],sequel,[ilRetTy] ->
match sequelIgnoreEndScopes sequel with
| s when IsSequelImmediate s ->
(* In most cases we can avoid doing this... *)
GenExpr cenv cgbuf eenv SPSuppress arg1 Continue
CG.EmitInstr cgbuf (pop 1) Push0 I_throw
GenSequelEndScopes cgbuf sequel
| _ ->
let after1 = CG.GenerateDelayMark cgbuf ("fake_join")
let after2 = CG.GenerateDelayMark cgbuf ("fake_join")
let after3 = CG.GenerateDelayMark cgbuf ("fake_join")
CG.EmitInstrs cgbuf (pop 0) Push0 [mkLdcInt32 0; I_brcmp (BI_brfalse,after2.CodeLabel) ]
CG.SetMarkToHere cgbuf after1
CG.EmitInstrs cgbuf (pop 0) (Push [ilRetTy]) [AI_ldnull; I_unbox_any ilRetTy; I_br after3.CodeLabel ]
CG.SetMarkToHere cgbuf after2
GenExpr cenv cgbuf eenv SPSuppress arg1 Continue
CG.EmitInstr cgbuf (pop 1) Push0 I_throw
CG.SetMarkToHere cgbuf after3
GenSequel cenv eenv.cloc cgbuf sequel
| _ ->
// float or float32 or float<_> or float32<_>
let g = cenv.g in
let anyfpType ty = typeEquivAux EraseMeasures g g.float_ty ty || typeEquivAux EraseMeasures g g.float32_ty ty
// Otherwise generate the arguments, and see if we can use a I_brcmp rather than a comparison followed by an I_brfalse/I_brtrue
GenExprs cenv cgbuf eenv args
match ilAfterInst,sequel with
// NOTE: THESE ARE NOT VALID ON FLOATING POINT DUE TO NaN. Hence INLINE ASM ON FP. MUST BE CAREFULLY WRITTEN
| [ AI_clt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bge,label1))
| [ AI_cgt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_ble,label1))
| [ AI_clt_un ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bge_un,label1))
| [ AI_cgt_un ], CmpThenBrOrContinue(1, [I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_ble_un,label1))
| [ AI_ceq ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bne_un,label1))
// THESE ARE VALID ON FP w.r.t. NaN
| [ AI_clt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_blt,label1))
| [ AI_cgt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) ->
CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bgt,label1))
| [ AI_clt_un ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) ->