csharpfftfsharpintegrationinterpolationlinear-algebramathdifferentiationmatrixnumericsrandomregressionstatisticsmathnet
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2814 lines
147 KiB
2814 lines
147 KiB
// (c) Microsoft Corporation. All rights reserved
|
|
//-------------------------------------------------------------------------
|
|
// A fairly simple optimizer. The main aim is to inline simple, known functions
|
|
// and constant values, and to eliminate non-side-affecting bindings that
|
|
// are never used.
|
|
//-------------------------------------------------------------------------
|
|
|
|
#light
|
|
|
|
module (* internal *) Microsoft.FSharp.Compiler.Opt
|
|
|
|
open Internal.Utilities
|
|
open Internal.Utilities.Pervasives
|
|
open Microsoft.FSharp.Compiler.AbstractIL
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Internal
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX
|
|
open Microsoft.FSharp.Compiler
|
|
|
|
open Microsoft.FSharp.Compiler.AbstractIL.IL
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
|
|
|
|
open Microsoft.FSharp.Compiler.Range
|
|
open Microsoft.FSharp.Compiler.Ast
|
|
open Microsoft.FSharp.Compiler.ErrorLogger
|
|
open Microsoft.FSharp.Compiler.PrettyNaming
|
|
open Microsoft.FSharp.Compiler.Tast
|
|
open Microsoft.FSharp.Compiler.Tastops
|
|
open Microsoft.FSharp.Compiler.Env
|
|
open Microsoft.FSharp.Compiler.Lib
|
|
open Microsoft.FSharp.Compiler.Layout
|
|
open Microsoft.FSharp.Compiler.Typrelns
|
|
|
|
let verboseOptimizationInfo = false
|
|
let verboseOptimizations = false
|
|
|
|
let i_ldlen = [ I_ldlen; I_arith (AI_conv DT_I4) ]
|
|
|
|
let callSize = 1 // size of a function call
|
|
let forAndWhileLoopSize = 5 // size of a for/while loop
|
|
let tryCatchSize = 5 // size of a try/catch
|
|
let tryFinallySize = 5 // size of a try/finally
|
|
let closureTotalSize = 10 // Total cost of a closure. Each closure adds a class definition
|
|
let methodDefnTotalSize = 1 // Total cost of a method definition
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Info returned up the tree by optimization.
|
|
// Partial information about an expression.
|
|
// Some ExprValueInfo can
|
|
//
|
|
// We store one of these for each value in the environment, including values
|
|
// which we know little or nothing about.
|
|
//-------------------------------------------------------------------------
|
|
|
|
type TypeValueInfo =
|
|
| UnknownTypeValue
|
|
|
|
type ExprValueInfo =
|
|
| UnknownValue
|
|
/// record size info (max_depth) for ExprValueInfo
|
|
| SizeValue of int * ExprValueInfo
|
|
(* RECURSIVE cases *)
|
|
/// "equal to another identifier about which we know some further detail"
|
|
| ValValue of ValRef * ExprValueInfo
|
|
/// used for when optimizing module expressions
|
|
| ModuleValue of ModuleInfo
|
|
| TupleValue of ExprValueInfo array
|
|
| RecdValue of TyconRef * ExprValueInfo array (* INVARIANT: in field definition order *)
|
|
| UnionCaseValue of UnionCaseRef * ExprValueInfo array
|
|
(* NON RECURSIVE cases *)
|
|
| ConstValue of Constant * Tast.typ
|
|
| CurriedLambdaValue of
|
|
( uniq (* id *)
|
|
* int (* arities, i.e. number of bunches of untupled args, and number of args in each bunch. INCLUDE TYPE ARGS. *)
|
|
* int (* size *)
|
|
* Tast.expr (* value, a lambda term *)
|
|
* Tast.typ (* type of lamba term *))
|
|
| ConstExprValue of
|
|
( int (* size *)
|
|
* Tast.expr (* value, a term *))
|
|
|
|
and ValInfo =
|
|
{ ValMakesNoCriticalTailcalls: bool;
|
|
ValExprInfo: ExprValueInfo }
|
|
and ModuleInfo =
|
|
{ ValInfos: (ValRef * ValInfo) NameMap;
|
|
ModuleOrNamespaceInfos: LazyModuleInfo NameMap }
|
|
and LazyModuleInfo = Lazy<ModuleInfo>
|
|
let braceL x = leftL "{" $$ x $$ rightL "}"
|
|
|
|
let namemapL xL xmap = NameMap.fold (fun nm x z -> z @@ xL nm x) xmap emptyL
|
|
let rec exprValueInfoL = function
|
|
| ConstValue (x,_) -> NicePrint.constL x
|
|
| UnknownValue -> wordL "?"
|
|
| SizeValue (_,vinfo) -> exprValueInfoL vinfo
|
|
| ValValue (vr,vinfo) -> bracketL ((ValRefL vr $$ wordL "alias") --- exprValueInfoL vinfo)
|
|
| ModuleValue minfo -> wordL "struct<...>"
|
|
| TupleValue vinfos -> bracketL (exprValueInfosL vinfos)
|
|
| RecdValue (_,vinfos) -> braceL (exprValueInfosL vinfos)
|
|
| UnionCaseValue (ucr,vinfos) -> UnionCaseRefL ucr $$ bracketL (exprValueInfosL vinfos)
|
|
| CurriedLambdaValue(lambdaId,arities,bsize,expr',ety) -> wordL "lam" ++ ExprL expr' (* (Printf.sprintf "lam(size=%d)" bsize) *)
|
|
| ConstExprValue (size,x) -> ExprL x
|
|
and exprValueInfosL vinfos = commaListL (List.map exprValueInfoL (Array.to_list vinfos))
|
|
and moduleInfoL (x:LazyModuleInfo) =
|
|
let x = x.Force()
|
|
braceL ((wordL "Modules: " @@ namemapL (fun nm x -> wordL nm $$ moduleInfoL x) x.ModuleOrNamespaceInfos)
|
|
@@ (wordL "Values:" @@ namemapL (fun nm (vref,x) -> ValRefL vref $$ valInfoL x) x.ValInfos))
|
|
|
|
and valInfoL (x:ValInfo) =
|
|
braceL ((wordL "ValExprInfo: " @@ exprValueInfoL x.ValExprInfo)
|
|
@@ (wordL "ValMakesNoCriticalTailcalls:" @@ wordL (if x.ValMakesNoCriticalTailcalls then "true" else "false")))
|
|
|
|
type summary<'a> =
|
|
{ Info: 'a;
|
|
/// What's the contribution to the size of this function?
|
|
FunctionSize: int;
|
|
/// What's the total contribution to the size of the assembly, including closure classes etc.?
|
|
TotalSize: int;
|
|
/// Meaning: could mutate, could non-terminate, could raise exception
|
|
/// One use: an effect expr can not be eliminated as dead code (e.g. sequencing)
|
|
/// One use: an effect=false expr can not throw an exception? so try-catch is removed.
|
|
HasEffect: bool
|
|
/// Indicates that a function may make a useful tailcall, hence when called should itself be tailcalled
|
|
MightMakeCriticalTailcall: bool
|
|
}
|
|
|
|
type expr_summary = ExprValueInfo summary
|
|
type modul_summary = ModuleInfo summary
|
|
|
|
//-------------------------------------------------------------------------
|
|
// BoundValueInfoBySize
|
|
// Note, this is a different notion of "size" to the one used for inlining heuristics
|
|
//-------------------------------------------------------------------------
|
|
|
|
let rec SizeOfValueInfos arr =
|
|
let n = Array.length arr
|
|
let rec go i acc = if i >= n then acc else max acc (SizeOfValueInfo arr.[i])
|
|
go 0 0
|
|
and SizeOfValueInfo x =
|
|
match x with
|
|
| SizeValue (vdepth,v) -> vdepth (* terminate recursion at CACHED size nodes *)
|
|
| ConstValue (x,_) -> 1
|
|
| UnknownValue -> 1
|
|
| ValValue (vr,vinfo) -> SizeOfValueInfo vinfo + 1
|
|
| ModuleValue minfo -> 1 (* do not care about size of these, they do not nest heavily... *)
|
|
| TupleValue vinfos
|
|
| RecdValue (_,vinfos)
|
|
| UnionCaseValue (_,vinfos) -> 1 + SizeOfValueInfos vinfos
|
|
| CurriedLambdaValue(lambdaId,arities,bsize,expr',ety) -> 1
|
|
| ConstExprValue (size,_) -> 1
|
|
|
|
let rec MakeValueInfoWithCachedSize vdepth v =
|
|
match v with
|
|
| SizeValue(_,v) -> MakeValueInfoWithCachedSize vdepth v
|
|
| _ -> let minDepthForASizeNode = 5 in (* for small vinfos do not record size info, save space *)
|
|
if vdepth > minDepthForASizeNode then SizeValue(vdepth,v) else v (* add nodes to stop recursion *)
|
|
|
|
let MakeSizedValueInfo v =
|
|
let vdepth = SizeOfValueInfo v
|
|
MakeValueInfoWithCachedSize vdepth v
|
|
|
|
let BoundValueInfoBySize vinfo =
|
|
let rec bound depth x =
|
|
if depth<0 then UnknownValue else
|
|
match x with
|
|
| SizeValue (vdepth,vinfo) -> if vdepth < depth then x else MakeSizedValueInfo (bound depth vinfo)
|
|
| ValValue (vr,vinfo) -> ValValue (vr,bound (depth-1) vinfo)
|
|
| TupleValue vinfos -> TupleValue (Array.map (bound (depth-1)) vinfos)
|
|
| RecdValue (tcref,vinfos) -> RecdValue (tcref,Array.map (bound (depth-1)) vinfos)
|
|
| UnionCaseValue (ucr,vinfos) -> UnionCaseValue (ucr,Array.map (bound (depth-1)) vinfos)
|
|
| ModuleValue minfo -> x
|
|
| ConstValue _ -> x
|
|
| UnknownValue -> x
|
|
| CurriedLambdaValue(lambdaId,arities,bsize,expr',ety) -> x
|
|
| ConstExprValue (size,_) -> x
|
|
let max_depth = 6 in (* beware huge constants! *)
|
|
let trim_depth = 3
|
|
let vdepth = SizeOfValueInfo vinfo
|
|
if vdepth > max_depth
|
|
then MakeSizedValueInfo (bound trim_depth vinfo)
|
|
else MakeValueInfoWithCachedSize vdepth vinfo
|
|
|
|
//-------------------------------------------------------------------------
|
|
// What we know about the world
|
|
//-------------------------------------------------------------------------
|
|
|
|
let jitOptDefault = true
|
|
let localOptDefault = true
|
|
let crossModuleOptDefault = true
|
|
|
|
type OptimizationSettings =
|
|
{ abstractBigTargets : bool;
|
|
jitOptUser : bool option;
|
|
localOptUser : bool option;
|
|
crossModuleOptUser : bool option;
|
|
/// size after which we start chopping methods in two, though only at match targets
|
|
bigTargetSize : int
|
|
/// size after which we start enforcing splitting sub-expressions to new methods, to avoid hitting .NET IL limitations
|
|
veryBigExprSize : int
|
|
/// The size after which we don't inline
|
|
lambdaInlineThreshold : int;
|
|
/// For unit testing
|
|
reportingPhase : bool
|
|
reportNoNeedToTailcall: bool;
|
|
reportFunctionSizes : bool
|
|
reportHasEffect : bool
|
|
reportTotalSizes : bool }
|
|
|
|
static member Defaults =
|
|
{ abstractBigTargets = false;
|
|
jitOptUser = None;
|
|
localOptUser = None
|
|
/// size after which we start chopping methods in two, though only at match targets
|
|
bigTargetSize = 100
|
|
/// size after which we start enforcing splitting sub-expressions to new methods, to avoid hitting .NET IL limitations
|
|
veryBigExprSize = 3000
|
|
crossModuleOptUser = None;
|
|
/// The size after which we don't inline
|
|
lambdaInlineThreshold = 6;
|
|
reportingPhase = false;
|
|
reportNoNeedToTailcall = false;
|
|
reportFunctionSizes = false
|
|
reportHasEffect = false
|
|
reportTotalSizes = false
|
|
}
|
|
|
|
member x.jitOpt() = (match x.jitOptUser with Some f -> f | None -> jitOptDefault)
|
|
member x.localOpt () = (match x.localOptUser with Some f -> f | None -> localOptDefault)
|
|
member x.crossModuleOpt () = x.localOpt () && (match x.crossModuleOptUser with Some f -> f | None -> crossModuleOptDefault)
|
|
|
|
member x.KeepOptimizationValues() = x.crossModuleOpt ()
|
|
/// inline calls *
|
|
member x.InlineLambdas () = x.localOpt ()
|
|
/// eliminate unused bindings with no effect
|
|
member x.EliminateUnusedBindings () = x.localOpt ()
|
|
/// eliminate try around expr with no effect
|
|
member x.EliminateTryCatchAndTryFinally () = x.localOpt ()
|
|
/// eliminate first part of seq if no effect
|
|
member x.EliminateSequential () = x.localOpt ()
|
|
/// determine branches in pattern matching
|
|
member x.EliminateSwitch () = x.localOpt ()
|
|
member x.EliminateRecdFieldGet () = x.localOpt ()
|
|
member x.EliminateTupleFieldGet () = x.localOpt ()
|
|
member x.EliminatUnionCaseFieldGet () = x.localOpt ()
|
|
/// eliminate non-copiler generated immediate bindings
|
|
member x.EliminateImmediatelyConsumedLocals() = x.localOpt ()
|
|
/// expand "let x = (exp1,exp2,...)" bind fields as prior tmps
|
|
member x.ExpandStructrualValues() = x.localOpt ()
|
|
|
|
type cenv =
|
|
{ g: Env.TcGlobals;
|
|
amap: Import.ImportMap;
|
|
optimizing: bool;
|
|
scope: ccu;
|
|
localInternalVals: System.Collections.Generic.Dictionary<stamp,ValInfo>
|
|
settings: OptimizationSettings }
|
|
|
|
|
|
|
|
type IncrementalOptimizationEnv =
|
|
{ // An identifier to help with name generation
|
|
latestBoundId: ident option;
|
|
// The set of lambda IDs we've inlined to reach this point. Helps to prevent recursive inlining
|
|
dontInline: Zset.t<uniq>;
|
|
// Recursively bound vars. If an sub-expression that is a candidate for method splitting
|
|
// contains any of these variables then don't split it, for fear of mucking up tailcalls.
|
|
// See FSharp 1.0 bug 2892
|
|
dontSplitVars: ValMap<unit>;
|
|
/// The Val for the function binding being generated, if any.
|
|
functionVal: (Val * Tast.ValTopReprInfo) option;
|
|
typarInfos: (Typar * TypeValueInfo) list;
|
|
localExternalVals: ValInfo ValMap;
|
|
globalModuleInfos: LazyModuleInfo NameMap; }
|
|
|
|
let empty_env =
|
|
{ latestBoundId = None;
|
|
dontInline = Zset.empty Int64.order;
|
|
typarInfos = [];
|
|
functionVal = None;
|
|
dontSplitVars = vspec_map_empty();
|
|
localExternalVals = vspec_map_empty();
|
|
globalModuleInfos = NameMap.empty }
|
|
|
|
//-------------------------------------------------------------------------
|
|
// IsPartialExprVal - is the expr fully known?
|
|
//-------------------------------------------------------------------------
|
|
|
|
let rec IsPartialExprVal x = (* IsPartialExprVal can not rebuild to an expr *)
|
|
match x with
|
|
| UnknownValue -> true
|
|
| ModuleValue ss -> IsPartialStructVal ss
|
|
| TupleValue args | RecdValue (_,args) | UnionCaseValue (_,args) -> Array.exists IsPartialExprVal args
|
|
| ConstValue _ | CurriedLambdaValue _ | ConstExprValue _ -> false
|
|
| ValValue (_,a)
|
|
| SizeValue(_,a) -> IsPartialExprVal a
|
|
|
|
and IsPartialStructVal (ss:ModuleInfo) =
|
|
(ss.ModuleOrNamespaceInfos |> Map.exists (fun _ x -> IsPartialStructVal (x.Force()))) ||
|
|
(ss.ValInfos |> Map.exists (fun _ (_,x) -> IsPartialExprVal x.ValExprInfo))
|
|
|
|
let CheckInlineValueIsComplete (v:Val) res =
|
|
if v.MustInline && IsPartialExprVal res then
|
|
errorR(Error("The value '"^v.MangledName^"' was marked inline but its value was incomplete", v.Range))
|
|
//System.Diagnostics.Debug.Assert(false,sprintf "Break for incomplete inline value %s" v.MangledName)
|
|
|
|
let check msg m vref (res:ValInfo) =
|
|
CheckInlineValueIsComplete (deref_val vref) res.ValExprInfo;
|
|
(vref,res)
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Bind information about values
|
|
//-------------------------------------------------------------------------
|
|
|
|
let EmptyModuleInfo = notlazy { ValInfos = Map.empty; ModuleOrNamespaceInfos = Map.empty }
|
|
let rec UnionModuleInfo (m1:LazyModuleInfo) (m2:LazyModuleInfo) =
|
|
let m1 = m1.Force()
|
|
let m2 = m2.Force()
|
|
notlazy
|
|
{ ValInfos = NameMap.layer m1.ValInfos m2.ValInfos;
|
|
ModuleOrNamespaceInfos = NameMap.union UnionModuleInfo m1.ModuleOrNamespaceInfos m2.ModuleOrNamespaceInfos }
|
|
|
|
let UnionModuleInfos (minfos : LazyModuleInfo list) = List.foldBack UnionModuleInfo minfos EmptyModuleInfo
|
|
|
|
let FindOrCreateModuleInfo n ss =
|
|
match Map.tryfind n ss with
|
|
| Some res -> res
|
|
| None -> EmptyModuleInfo
|
|
|
|
let rec BindValueInSubModule mp i (v:Val) vval ss =
|
|
if i >= Array.length mp
|
|
then {ss with ValInfos = Map.add v.MangledName (mk_local_vref v,vval) ss.ValInfos }
|
|
else {ss with ModuleOrNamespaceInfos = BindValueInModule mp.[i] mp (i+1) v vval ss.ModuleOrNamespaceInfos }
|
|
|
|
and BindValueInModule n mp i v vval ss =
|
|
let old = FindOrCreateModuleInfo n ss
|
|
Map.add n (notlazy (BindValueInSubModule mp i v vval (old.Force()))) ss
|
|
|
|
let bind_val_in_env_for_fslib (NLPath(ccu,mp)) v vval env =
|
|
// We eventually need to allow multiple CCUs with the same 'name' but different assemblies.
|
|
// So at some point we should remove this use of ccu.AssemblyName
|
|
{env with globalModuleInfos = BindValueInModule ccu.AssemblyName mp 0 v vval env.globalModuleInfos }
|
|
|
|
let rec bind_top_module_in_modul n mp i mval ss =
|
|
if i >= Array.length mp
|
|
then
|
|
match Map.tryfind n ss with
|
|
| Some res -> Map.add n (UnionModuleInfo mval res) ss
|
|
| None -> Map.add n mval ss
|
|
else
|
|
let old = (FindOrCreateModuleInfo n ss).Force()
|
|
Map.add n (notlazy {old with ModuleOrNamespaceInfos = bind_top_module_in_modul mp.[i] mp (i+1) mval old.ModuleOrNamespaceInfos}) ss
|
|
|
|
let UnknownValInfo = { ValExprInfo=UnknownValue; ValMakesNoCriticalTailcalls=false }
|
|
|
|
let MkValInfo info (v:Val) = { ValExprInfo=info.Info; ValMakesNoCriticalTailcalls= v.MakesNoCriticalTailcalls }
|
|
|
|
(* Bind a value *)
|
|
let bind_internal_local_vspec cenv (v:Val) vval env =
|
|
let vval = if v.IsMutable then UnknownValInfo else vval
|
|
#if CHECKED
|
|
#else
|
|
match vval.ValExprInfo with
|
|
| UnknownValue -> env
|
|
| _ ->
|
|
#endif
|
|
cenv.localInternalVals.[v.Stamp] <- vval;
|
|
env
|
|
|
|
let bind_escaping_local_vspec cenv (v:Val) vval env =
|
|
#if CHECKED
|
|
CheckInlineValueIsComplete v vval;
|
|
#endif
|
|
|
|
if verboseOptimizationInfo then dprintn ("*** Binding "^v.MangledName);
|
|
let vval = if v.IsMutable then {vval with ValExprInfo=UnknownValue } else vval
|
|
let env =
|
|
#if CHECKED
|
|
#else
|
|
match vval.ValExprInfo with
|
|
| UnknownValue -> env
|
|
| _ ->
|
|
#endif
|
|
{ env with localExternalVals=vspec_map_add v vval env.localExternalVals }
|
|
(* If we're compiling fslib then also bind the value as a non-local path to allow us to resolve the compiler-non-local-refereneces *)
|
|
let env =
|
|
if cenv.g.compilingFslib && isSome (v.PublicPath)
|
|
then bind_val_in_env_for_fslib (enclosing_nlpath_of_pubpath cenv.g.fslibCcu (the (v.PublicPath))) v vval env
|
|
else env
|
|
env
|
|
|
|
let rec bind_module_vspecs cenv (mval:LazyModuleInfo) env =
|
|
let mval = mval.Force()
|
|
NameMap.foldRange (fun (v,vval) env -> bind_escaping_local_vspec cenv (deref_val v) vval env) mval.ValInfos
|
|
(NameMap.foldRange (bind_module_vspecs cenv) mval.ModuleOrNamespaceInfos env)
|
|
|
|
|
|
let bind_internal_vspec_to_unknown cenv v env =
|
|
#if CHECKED
|
|
bind_internal_local_vspec cenv v UnknownValue env
|
|
#else
|
|
env
|
|
#endif
|
|
let bind_internal_vspecs_to_unknown cenv vs env =
|
|
#if CHECKED
|
|
List.foldBack (bind_internal_vspec_to_unknown cenv) vs env
|
|
#else
|
|
env
|
|
#endif
|
|
|
|
let BindTypeVar tyv typeinfo env = { env with typarInfos= (tyv,typeinfo)::env.typarInfos }
|
|
|
|
let BindTypeVarsToUnknown (tps:Typar list) env =
|
|
if isNil tps then env else
|
|
// The optimizer doesn't use the type values it could track.
|
|
// However here we mutate to provide better names for generalized type parameters
|
|
let nms = PrettyTypes.PrettyTyparNames (fun _ -> true) (env.typarInfos |> List.map (fun (tp,_) -> tp.Name) ) tps
|
|
(tps,nms) ||> List.iter2 (fun tp nm ->
|
|
if PrettyTypes.NeedsPrettyTyparName tp then
|
|
tp.Data.typar_id <- ident (nm,tp.Range));
|
|
List.fold (fun sofar arg -> BindTypeVar arg UnknownTypeValue sofar) env tps
|
|
|
|
let BindCcu (ccu:Tast.ccu) mval env =
|
|
if verboseOptimizationInfo then
|
|
dprintf "*** Reloading optimization data for assembly %s, info = \n%s\n" ccu.AssemblyName (showL (Layout.squashTo 192 (moduleInfoL mval)));
|
|
|
|
{ env with globalModuleInfos=Map.add ccu.AssemblyName mval env.globalModuleInfos }
|
|
|
|
let mk_cenv settings scope g amap =
|
|
{ settings=settings;
|
|
scope=scope;
|
|
g=g;
|
|
amap=amap;
|
|
optimizing=true;
|
|
localInternalVals=new System.Collections.Generic.Dictionary<_,_>(10000) }
|
|
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Lookup information about values
|
|
//-------------------------------------------------------------------------
|
|
|
|
|
|
let GetInfoForLocalValue cenv env (v:Val) m =
|
|
(* Abstract slots do not have values *)
|
|
match v.MemberInfo with
|
|
| Some(vspr) when vspr.MemberFlags.MemberIsDispatchSlot -> UnknownValInfo
|
|
| _ ->
|
|
let mutable res = Unchecked.defaultof<_>
|
|
let ok = cenv.localInternalVals.TryGetValue(v.Stamp, &res)
|
|
if ok then res else
|
|
match vspec_map_tryfind v env.localExternalVals with
|
|
| Some vval -> vval
|
|
| None ->
|
|
if v.MustInline then
|
|
errorR(Error("The value '"^full_display_text_of_vref (mk_local_vref v) ^"' was marked inline but was not bound in the optimization environment", m));
|
|
#if CHECKED
|
|
warning(Error ("*** Local value "^v.MangledName^" not found during optimization. Please report this problem",m));
|
|
#endif
|
|
UnknownValInfo
|
|
|
|
let TryGetInfoForCcu env (ccu:ccu) = env.globalModuleInfos.TryFind(ccu.AssemblyName)
|
|
|
|
let rec TryGetInfoForPath sv p i =
|
|
if i >= Array.length p then Some sv else
|
|
match Map.tryfind p.[i] sv.ModuleOrNamespaceInfos with
|
|
| Some info ->
|
|
TryGetInfoForPath (info.Force()) p (i+1)
|
|
| None ->
|
|
if verboseOptimizationInfo then
|
|
dprintn ("\n\n*** Optimization info for submodule "^p.[i]^" not found in parent module which contains submodules: "^String.concat "," (NameMap.domainL sv.ModuleOrNamespaceInfos));
|
|
None
|
|
|
|
let TryGetInfoForNonLocalPath env (NLPath(ccu,p)) =
|
|
match TryGetInfoForCcu env ccu with
|
|
| Some ccuinfo -> TryGetInfoForPath (ccuinfo.Force()) p 0
|
|
| None -> None
|
|
|
|
let GetInfoForNonLocalVal cenv env (v:ValRef) =
|
|
match v.MemberInfo with
|
|
| Some(vspr) when vspr.MemberFlags.MemberIsDispatchSlot -> UnknownValInfo
|
|
| _ ->
|
|
if (* in_this: REVIEW: optionally turn x-module on/off on per-module basis or *)
|
|
cenv.settings.crossModuleOpt () ||
|
|
v.MustInline then
|
|
let smv = nlpath_of_nlref v.nlr
|
|
let n = item_of_nlref v.nlr
|
|
match TryGetInfoForNonLocalPath env smv with
|
|
| Some(structInfo) ->
|
|
match structInfo.ValInfos.TryFind(n) with
|
|
| Some ninfo -> snd ninfo
|
|
| None ->
|
|
//dprintn ("\n\n*** Optimization info for value "^n^" from module "^(full_name_of_nlpath smv)^" not found, module contains values: "^String.concat "," (NameMap.domainL structInfo.ValInfos));
|
|
//System.Diagnostics.Debug.Assert(false,sprintf "Break for module %s, value %s" (full_name_of_nlpath smv) n)
|
|
UnknownValInfo
|
|
| None ->
|
|
//dprintf "\n\n*** Optimization info for module %s from ccu %s not found." (full_name_of_nlpath smv) (ccu_of_nlpath smv).AssemblyName;
|
|
//System.Diagnostics.Debug.Assert(false,sprintf "Break for module %s, ccu %s" (full_name_of_nlpath smv) (ccu_of_nlpath smv).AssemblyName)
|
|
UnknownValInfo
|
|
else UnknownValInfo
|
|
|
|
let GetInfoForVal cenv env m (v:ValRef) =
|
|
let res =
|
|
match v.IsLocalRef with
|
|
| true -> GetInfoForLocalValue cenv env v.binding m
|
|
| false -> GetInfoForNonLocalVal cenv env v
|
|
check "its stored value was incomplete" m v res |> ignore;
|
|
res
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Try to get information about values of particular types
|
|
//-------------------------------------------------------------------------
|
|
|
|
let rec strip_value = function
|
|
| ValValue(_,details) -> strip_value details (* step through ValValue "aliases" *)
|
|
| SizeValue(_,details) -> strip_value details (* step through SizeValue "aliases" *)
|
|
| vinfo -> vinfo
|
|
|
|
let (|StripConstValue|_|) ev =
|
|
match strip_value ev with
|
|
| ConstValue(c,_) -> Some c
|
|
| _ -> None
|
|
|
|
let (|StripLambdaValue|_|) ev =
|
|
match strip_value ev with
|
|
| CurriedLambdaValue info -> Some info
|
|
| _ -> None
|
|
|
|
let dest_tuple_value ev =
|
|
match strip_value ev with
|
|
| TupleValue info -> Some info
|
|
| _ -> None
|
|
|
|
let dest_recd_value ev =
|
|
match strip_value ev with
|
|
| RecdValue (tcref,info) -> Some info
|
|
| _ -> None
|
|
|
|
let (|StripUnionCaseValue|_|) ev =
|
|
match strip_value ev with
|
|
| UnionCaseValue (c,info) -> Some (c,info)
|
|
| _ -> None
|
|
|
|
let mk_bool_value g n = ConstValue(TConst_bool n, g.bool_ty)
|
|
let mk_int8_value g n = ConstValue(TConst_sbyte n, g.sbyte_ty)
|
|
let mk_int16_value g n = ConstValue(TConst_int16 n, g.int16_ty)
|
|
let mk_int32_value g n = ConstValue(TConst_int32 n, g.int32_ty)
|
|
let mk_int64_value g n = ConstValue(TConst_int64 n, g.int64_ty)
|
|
let mk_uint8_value g n = ConstValue(TConst_byte n, g.byte_ty)
|
|
let mk_uint16_value g n = ConstValue(TConst_uint16 n, g.uint16_ty)
|
|
let mk_uint32_value g n = ConstValue(TConst_uint32 n, g.uint32_ty)
|
|
let mk_uint64_value g n = ConstValue(TConst_uint64 n, g.uint64_ty)
|
|
|
|
let (|StripInt32Value|_|) = function StripConstValue(TConst_int32 n) -> Some n | _ -> None
|
|
|
|
//-------------------------------------------------------------------------
|
|
// mk value_infos
|
|
//-------------------------------------------------------------------------
|
|
|
|
let MakeValueInfoForValue g m vref vinfo =
|
|
let rec check x =
|
|
match x with
|
|
| ValValue (vref2,detail) -> if g.vref_eq vref vref2 then error(Error("recursive ValValue "^showL(exprValueInfoL vinfo),m)) else check detail
|
|
| SizeValue (n,detail) -> check detail
|
|
| _ -> ()
|
|
check vinfo;
|
|
ValValue (vref,vinfo) |> BoundValueInfoBySize
|
|
|
|
let MakeValueInfoForRecord tcref tyargs argvals = RecdValue (tcref,argvals) |> BoundValueInfoBySize
|
|
let MakeValueInfoForTuple argvals = TupleValue argvals |> BoundValueInfoBySize
|
|
let MakeValueInfoForUnionCase cspec argvals = UnionCaseValue (cspec,argvals) |> BoundValueInfoBySize
|
|
let MakeValueInfoForConst c ty = ConstValue(c,ty)
|
|
|
|
// Helper to evaluate a unary integer operation over known values
|
|
let inline IntegerUnaryOp g f8 f16 f32 f64 fu8 fu16 fu32 fu64 a =
|
|
match a with
|
|
| StripConstValue(c) ->
|
|
match c with
|
|
| TConst_bool a -> Some(mk_bool_value g (f32 (if a then 1 else 0) <> 0))
|
|
| TConst_int32 a -> Some(mk_int32_value g (f32 a))
|
|
| TConst_int64 a -> Some(mk_int64_value g (f64 a))
|
|
| TConst_int16 a -> Some(mk_int16_value g (f16 a))
|
|
| TConst_sbyte a -> Some(mk_int8_value g (f8 a))
|
|
| TConst_byte a -> Some(mk_uint8_value g (fu8 a))
|
|
| TConst_uint32 a -> Some(mk_uint32_value g (fu32 a))
|
|
| TConst_uint64 a -> Some(mk_uint64_value g (fu64 a))
|
|
| TConst_uint16 a -> Some(mk_uint16_value g (fu16 a))
|
|
| _ -> None
|
|
| _ -> None
|
|
|
|
// Helper to evaluate a unary signed integer operation over known values
|
|
let inline SignedIntegerUnaryOp g f8 f16 f32 f64 a =
|
|
match a with
|
|
| StripConstValue(c) ->
|
|
match c with
|
|
| TConst_int32 a -> Some(mk_int32_value g (f32 a))
|
|
| TConst_int64 a -> Some(mk_int64_value g (f64 a))
|
|
| TConst_int16 a -> Some(mk_int16_value g (f16 a))
|
|
| TConst_sbyte a -> Some(mk_int8_value g (f8 a))
|
|
| _ -> None
|
|
| _ -> None
|
|
|
|
// Helper to evaluate a binary integer operation over known values
|
|
let inline IntegerBinaryOp g f8 f16 f32 f64 fu8 fu16 fu32 fu64 a b =
|
|
match a,b with
|
|
| StripConstValue(c1),StripConstValue(c2) ->
|
|
match c1,c2 with
|
|
| (TConst_bool a),(TConst_bool b) -> Some(mk_bool_value g (f32 (if a then 1 else 0) (if b then 1 else 0) <> 0))
|
|
| (TConst_int32 a),(TConst_int32 b) -> Some(mk_int32_value g (f32 a b))
|
|
| (TConst_int64 a),(TConst_int64 b) -> Some(mk_int64_value g (f64 a b))
|
|
| (TConst_int16 a),(TConst_int16 b) -> Some(mk_int16_value g (f16 a b))
|
|
| (TConst_sbyte a),(TConst_sbyte b) -> Some(mk_int8_value g (f8 a b))
|
|
| (TConst_byte a),(TConst_byte b) -> Some(mk_uint8_value g (fu8 a b))
|
|
| (TConst_uint16 a),(TConst_uint16 b) -> Some(mk_uint16_value g (fu16 a b))
|
|
| (TConst_uint32 a),(TConst_uint32 b) -> Some(mk_uint32_value g (fu32 a b))
|
|
| (TConst_uint64 a),(TConst_uint64 b) -> Some(mk_uint64_value g (fu64 a b))
|
|
| _ -> None
|
|
| _ -> None
|
|
|
|
module Unchecked = Microsoft.FSharp.Core.Operators
|
|
|
|
/// Evaluate primitives based on interpretation of IL instructions.
|
|
//
|
|
// The implementation
|
|
// utilizes F# arithmetic extensively, so a mistake in the implementation of F# arithmetic
|
|
// in the core library used by the F# compiler will propagate to be a mistake in optimization.
|
|
// The IL instructions appear in the tree through inlining.
|
|
let MakeAssemblyCodeValueInfo g instrs argvals tys =
|
|
match instrs,argvals,tys with
|
|
| [ I_arith AI_add ],[t1;t2],_ ->
|
|
// Note: each use of Unchecked.(+) gets instantiated at a different type and inlined
|
|
match IntegerBinaryOp g Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) Unchecked.(+) t1 t2 with
|
|
| Some res -> res
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_sub ],[t1;t2],_ ->
|
|
// Note: each use of Unchecked.(+) gets instantiated at a different type and inlined
|
|
match IntegerBinaryOp g Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) Unchecked.(-) t1 t2 with
|
|
| Some res -> res
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_mul ],[a;b],_ -> (match IntegerBinaryOp g Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) Unchecked.( * ) a b with Some res -> res | None -> UnknownValue)
|
|
| [ I_arith AI_and ],[a;b],_ -> (match IntegerBinaryOp g (&&&) (&&&) (&&&) (&&&) (&&&) (&&&) (&&&) (&&&) a b with Some res -> res | None -> UnknownValue)
|
|
| [ I_arith AI_or ],[a;b],_ -> (match IntegerBinaryOp g (|||) (|||) (|||) (|||) (|||) (|||) (|||) (|||) a b with Some res -> res | None -> UnknownValue)
|
|
| [ I_arith AI_xor ],[a;b],_ -> (match IntegerBinaryOp g (^^^) (^^^) (^^^) (^^^) (^^^) (^^^) (^^^) (^^^) a b with Some res -> res | None -> UnknownValue)
|
|
| [ I_arith AI_not ],[a],_ -> (match IntegerUnaryOp g (~~~) (~~~) (~~~) (~~~) (~~~) (~~~) (~~~) (~~~) a with Some res -> res | None -> UnknownValue)
|
|
| [ I_arith AI_neg ],[a],_ -> (match SignedIntegerUnaryOp g (~-) (~-) (~-) (~-) a with Some res -> res | None -> UnknownValue)
|
|
|
|
| [ I_arith AI_ceq ],[a;b],_ ->
|
|
match strip_value a, strip_value b with
|
|
| ConstValue(TConst_bool a1,_),ConstValue(TConst_bool a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_sbyte a1,_),ConstValue(TConst_sbyte a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_int16 a1,_),ConstValue(TConst_int16 a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_int32 a1,_),ConstValue(TConst_int32 a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_int64 a1,_),ConstValue(TConst_int64 a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_char a1,_),ConstValue(TConst_char a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_byte a1,_),ConstValue(TConst_byte a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_uint16 a1,_),ConstValue(TConst_uint16 a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_uint32 a1,_),ConstValue(TConst_uint32 a2,_) -> mk_bool_value g (a1 = a2)
|
|
| ConstValue(TConst_uint64 a1,_),ConstValue(TConst_uint64 a2,_) -> mk_bool_value g (a1 = a2)
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_clt ],[a;b],_ ->
|
|
match strip_value a,strip_value b with
|
|
| ConstValue(TConst_bool a1,_),ConstValue(TConst_bool a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_int32 a1,_),ConstValue(TConst_int32 a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_int64 a1,_),ConstValue(TConst_int64 a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_sbyte a1,_),ConstValue(TConst_sbyte a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_int16 a1,_),ConstValue(TConst_int16 a2,_) -> mk_bool_value g (a1 < a2)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_U1))],[a],[ty] when type_equiv g ty g.byte_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_sbyte a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_int32 a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_byte a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_uint8_value g (Unchecked.byte a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_U2))],[a],[ty] when type_equiv g ty g.uint16_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_sbyte a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_int32 a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_byte a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_uint16_value g (Unchecked.uint16 a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_U4))],[a],[ty] when type_equiv g ty g.uint32_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_sbyte a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_int32 a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_byte a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_uint32_value g (Unchecked.uint32 a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_U8))],[a],[ty] when type_equiv g ty g.uint64_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_sbyte a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_int32 a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_byte a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_uint64_value g (Unchecked.uint64 a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_I1))],[a],[ty] when type_equiv g ty g.sbyte_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_sbyte a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_int32 a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_byte a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_int8_value g (Unchecked.sbyte a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_I2))],[a],[ty] when type_equiv g ty g.int16_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_int32 a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_sbyte a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_byte a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_int16_value g (Unchecked.int16 a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_I4))],[a],[ty] when type_equiv g ty g.int32_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_int32 a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_sbyte a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_byte a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_int32_value g (Unchecked.int32 a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith (AI_conv(DT_I8))],[a],[ty] when type_equiv g ty g.int64_ty ->
|
|
match strip_value a with
|
|
| ConstValue(TConst_int32 a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_int16 a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_sbyte a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_int64 a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_uint32 a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_uint16 a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_byte a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| ConstValue(TConst_uint64 a,_) -> mk_int64_value g (Unchecked.int64 a)
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_clt_un ],[a;b],[ty] when type_equiv g ty g.bool_ty ->
|
|
match strip_value a,strip_value b with
|
|
| ConstValue(TConst_char a1,_),ConstValue(TConst_char a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_byte a1,_),ConstValue(TConst_byte a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_uint16 a1,_),ConstValue(TConst_uint16 a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_uint32 a1,_),ConstValue(TConst_uint32 a2,_) -> mk_bool_value g (a1 < a2)
|
|
| ConstValue(TConst_uint64 a1,_),ConstValue(TConst_uint64 a2,_) -> mk_bool_value g (a1 < a2)
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_cgt ],[a;b],[ty] when type_equiv g ty g.bool_ty ->
|
|
match strip_value a,strip_value b with
|
|
| ConstValue(TConst_sbyte a1,_),ConstValue(TConst_sbyte a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_int16 a1,_),ConstValue(TConst_int16 a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_int32 a1,_),ConstValue(TConst_int32 a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_int64 a1,_),ConstValue(TConst_int64 a2,_) -> mk_bool_value g (a1 > a2)
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_cgt_un ],[a;b],[ty] when type_equiv g ty g.bool_ty ->
|
|
match strip_value a,strip_value b with
|
|
| ConstValue(TConst_char a1,_),ConstValue(TConst_char a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_byte a1,_),ConstValue(TConst_byte a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_uint16 a1,_),ConstValue(TConst_uint16 a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_uint32 a1,_),ConstValue(TConst_uint32 a2,_) -> mk_bool_value g (a1 > a2)
|
|
| ConstValue(TConst_uint64 a1,_),ConstValue(TConst_uint64 a2,_) -> mk_bool_value g (a1 > a2)
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_shl ],[a;n],_ ->
|
|
match strip_value a,strip_value n with
|
|
| ConstValue(TConst_int64 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 63 -> (mk_int64_value g (a <<< n))
|
|
| ConstValue(TConst_int32 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 31 -> (mk_int32_value g (a <<< n))
|
|
| ConstValue(TConst_int16 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 15 -> (mk_int16_value g (a <<< n))
|
|
| ConstValue(TConst_sbyte a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 7 -> (mk_int8_value g (a <<< n))
|
|
| ConstValue(TConst_uint64 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 63 -> (mk_uint64_value g (a <<< n))
|
|
| ConstValue(TConst_uint32 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 31 -> (mk_uint32_value g (a <<< n))
|
|
| ConstValue(TConst_uint16 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 15 -> (mk_uint16_value g (a <<< n))
|
|
| ConstValue(TConst_byte a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 7 -> (mk_uint8_value g (a <<< n))
|
|
| _ -> UnknownValue
|
|
|
|
| [ I_arith AI_shr ],[a;n],_ ->
|
|
match strip_value a,strip_value n with
|
|
| ConstValue(TConst_sbyte a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 7 -> (mk_int8_value g (a >>> n))
|
|
| ConstValue(TConst_int16 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 15 -> (mk_int16_value g (a >>> n))
|
|
| ConstValue(TConst_int32 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 31 -> (mk_int32_value g (a >>> n))
|
|
| ConstValue(TConst_int64 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 63 -> (mk_int64_value g (a >>> n))
|
|
| _ -> UnknownValue
|
|
| [ I_arith AI_shr_un ],[a;n],_ ->
|
|
match strip_value a,strip_value n with
|
|
| ConstValue(TConst_byte a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 7 -> (mk_uint8_value g (a >>> n))
|
|
| ConstValue(TConst_uint16 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 15 -> (mk_uint16_value g (a >>> n))
|
|
| ConstValue(TConst_uint32 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 31 -> (mk_uint32_value g (a >>> n))
|
|
| ConstValue(TConst_uint64 a,_),ConstValue(TConst_int32 n,_) when n >= 0 && n <= 63 -> (mk_uint64_value g (a >>> n))
|
|
| _ -> UnknownValue
|
|
|
|
// Retypings using IL asm "" are quite common in prim-types.fs
|
|
// Sometimes these are only to get the primitives to pass the type checker.
|
|
// Here we check for retypings from know values to known types.
|
|
// We're conservative not to apply any actual data-changing conversions here.
|
|
| [ ],[v],[ty] ->
|
|
match strip_value v with
|
|
| ConstValue(TConst_bool a,_) ->
|
|
if type_equiv g ty g.bool_ty then v
|
|
elif type_equiv g ty g.sbyte_ty then mk_int8_value g (if a then 1y else 0y)
|
|
elif type_equiv g ty g.int16_ty then mk_int16_value g (if a then 1s else 0s)
|
|
elif type_equiv g ty g.int32_ty then mk_int32_value g (if a then 1 else 0)
|
|
elif type_equiv g ty g.byte_ty then mk_uint8_value g (if a then 1uy else 0uy)
|
|
elif type_equiv g ty g.uint16_ty then mk_uint16_value g (if a then 1us else 0us)
|
|
elif type_equiv g ty g.uint32_ty then mk_uint32_value g (if a then 1u else 0u)
|
|
else UnknownValue
|
|
| ConstValue(TConst_sbyte a,_) ->
|
|
if type_equiv g ty g.sbyte_ty then v
|
|
elif type_equiv g ty g.int16_ty then mk_int16_value g (Unchecked.int16 a)
|
|
elif type_equiv g ty g.int32_ty then mk_int32_value g (Unchecked.int32 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_byte a,_) ->
|
|
if type_equiv g ty g.byte_ty then v
|
|
elif type_equiv g ty g.uint16_ty then mk_uint16_value g (Unchecked.uint16 a)
|
|
elif type_equiv g ty g.uint32_ty then mk_uint32_value g (Unchecked.uint32 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_int16 a,_) ->
|
|
if type_equiv g ty g.int16_ty then v
|
|
elif type_equiv g ty g.int32_ty then mk_int32_value g (Unchecked.int32 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_uint16 a,_) ->
|
|
if type_equiv g ty g.uint16_ty then v
|
|
elif type_equiv g ty g.uint32_ty then mk_uint32_value g (Unchecked.uint32 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_int32 a,_) ->
|
|
if type_equiv g ty g.int32_ty then v
|
|
elif type_equiv g ty g.uint32_ty then mk_uint32_value g (Unchecked.uint32 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_uint32 a,_) ->
|
|
if type_equiv g ty g.uint32_ty then v
|
|
elif type_equiv g ty g.int32_ty then mk_int32_value g (Unchecked.int32 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_int64 a,_) ->
|
|
if type_equiv g ty g.int64_ty then v
|
|
elif type_equiv g ty g.uint64_ty then mk_uint64_value g (Unchecked.uint64 a)
|
|
else UnknownValue
|
|
| ConstValue(TConst_uint64 a,_) ->
|
|
if type_equiv g ty g.uint64_ty then v
|
|
elif type_equiv g ty g.int64_ty then mk_int64_value g (Unchecked.int64 a)
|
|
else UnknownValue
|
|
| _ -> UnknownValue
|
|
| _ -> UnknownValue
|
|
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Size constants and combinators
|
|
//-------------------------------------------------------------------------
|
|
|
|
let local_var_size = 1
|
|
|
|
let rec AddTotalSizesAux acc l = match l with [] -> acc | h::t -> AddTotalSizesAux (h.TotalSize + acc) t
|
|
let AddTotalSizes l = AddTotalSizesAux 0 l
|
|
|
|
let rec AddFunctionSizesAux acc l = match l with [] -> acc | h::t -> AddFunctionSizesAux (h.FunctionSize + acc) t
|
|
let AddFunctionSizes l = AddFunctionSizesAux 0 l
|
|
|
|
let AddTotalSizesFlat l = l |> FlatList.sum_by (fun x -> x.TotalSize)
|
|
let AddFunctionSizesFlat l = l |> FlatList.sum_by (fun x -> x.FunctionSize)
|
|
|
|
//-------------------------------------------------------------------------
|
|
// opt list/array combinators - zipping (_,_) return type
|
|
//-------------------------------------------------------------------------
|
|
let rec or_effects l = match l with [] -> false | h::t -> h.HasEffect || or_effects t
|
|
let or_effects_Flat l = FlatList.exists (fun x -> x.HasEffect) l
|
|
|
|
let rec or_tailcalls l = match l with [] -> false | h::t -> h.MightMakeCriticalTailcall || or_tailcalls t
|
|
let or_tailcalls_Flat l = FlatList.exists (fun x -> x.MightMakeCriticalTailcall) l
|
|
|
|
let rec OptimizeListAux f l acc1 acc2 =
|
|
match l with
|
|
| [] -> List.rev acc1, List.rev acc2
|
|
| (h ::t) ->
|
|
let (x1,x2) = f h
|
|
OptimizeListAux f t (x1::acc1) (x2::acc2)
|
|
|
|
let OptimizeList f l = OptimizeListAux f l [] []
|
|
|
|
let OptimizeFlatList f l = l |> FlatList.map f |> FlatList.unzip
|
|
|
|
(* let opt_array f l = let l1,l2 = OptimizeList f (Array.to_list l) in Array.of_list l1, l2 *)
|
|
|
|
let no_exprs : (expr list * list<summary<ExprValueInfo>>)= [],[]
|
|
let no_FlatExprs : (FlatExprs * FlatList<summary<ExprValueInfo>>) = FlatList.empty, FlatList.empty
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Common ways of building new value_infos
|
|
//-------------------------------------------------------------------------
|
|
|
|
let CombineValueInfos einfos res =
|
|
{ TotalSize = AddTotalSizes einfos;
|
|
FunctionSize = AddFunctionSizes einfos;
|
|
HasEffect = or_effects einfos;
|
|
MightMakeCriticalTailcall = or_tailcalls einfos;
|
|
Info = res }
|
|
|
|
let CombineFlatValueInfos einfos res =
|
|
{ TotalSize = AddTotalSizesFlat einfos;
|
|
FunctionSize = AddFunctionSizesFlat einfos;
|
|
HasEffect = or_effects_Flat einfos;
|
|
MightMakeCriticalTailcall = or_tailcalls_Flat einfos;
|
|
Info = res }
|
|
|
|
let CombineValueInfosUnknown einfos = CombineValueInfos einfos UnknownValue
|
|
let CombineFlatValueInfosUnknown einfos = CombineFlatValueInfos einfos UnknownValue
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Hide information because of a signature
|
|
//-------------------------------------------------------------------------
|
|
|
|
let AbstractLazyModulInfoByHiding isAssemblyBoundary m mhi =
|
|
|
|
(* Previously: "This code is not sound when abstracting at the assembly boundary.
|
|
1. The MHI is not looking at 'internal' access attributes".
|
|
Now, the freevars and FreeTyvars can indicate if the non-public (hidden) items have been used.
|
|
Under those checks, the further hidden* checks may be subsumed (meaning, not required anymore).
|
|
*)
|
|
let hiddenTycon,hiddenTyconRepr,hiddenVal, hiddenRfield, hiddenUconstr =
|
|
Zset.mem_of mhi.mhiTycons,
|
|
Zset.mem_of mhi.mhiTyconReprs,
|
|
Zset.mem_of mhi.mhiVals,
|
|
Zset.mem_of mhi.mhiRecdFields,
|
|
Zset.mem_of mhi.mhiUnionCases
|
|
|
|
let rec abstractExprInfo ivalue =
|
|
if verboseOptimizationInfo then dprintf "abstractExprInfo\n";
|
|
match ivalue with
|
|
(* Check for escaping value. Revert to old info if possible *)
|
|
| ValValue (vref2,detail) ->
|
|
let detail' = abstractExprInfo detail
|
|
let v2 = (deref_val vref2)
|
|
let tyvars = free_in_val CollectAll v2
|
|
if
|
|
(isAssemblyBoundary && not (free_tyvars_all_public tyvars)) ||
|
|
Zset.exists hiddenTycon tyvars.FreeTycons ||
|
|
hiddenVal v2
|
|
then detail'
|
|
else ValValue (vref2,detail')
|
|
(* Check for escape in lambda *)
|
|
| CurriedLambdaValue (_,_,_,expr,_) | ConstExprValue(_,expr) when
|
|
(let fvs = free_in_expr CollectAll expr
|
|
(*dprintf "abstractModulInfoByHiding, #fvs.FreeLocals = %d, #fvs.FreeRecdFields = %d\n" (List.length (Zset.elements fvs.FreeLocals)) (List.length (Zset.elements fvs.FreeRecdFields)); *)
|
|
(isAssemblyBoundary && not (freevars_all_public fvs)) ||
|
|
Zset.exists hiddenVal fvs.FreeLocals ||
|
|
Zset.exists hiddenTycon fvs.FreeTyvars.FreeTycons ||
|
|
Zset.exists hiddenTyconRepr fvs.FreeLocalTyconReprs ||
|
|
Zset.exists hiddenRfield fvs.FreeRecdFields ||
|
|
Zset.exists hiddenUconstr fvs.FreeUnionCases ) ->
|
|
UnknownValue
|
|
(* Check for escape in constant *)
|
|
| ConstValue(_,ty) when
|
|
(let ftyvs = free_in_type CollectAll ty
|
|
(isAssemblyBoundary && not (free_tyvars_all_public ftyvs)) ||
|
|
Zset.exists hiddenTycon ftyvs.FreeTycons) ->
|
|
UnknownValue
|
|
| TupleValue vinfos -> TupleValue (Array.map abstractExprInfo vinfos)
|
|
| RecdValue (tcref,vinfos) ->
|
|
if hiddenTyconRepr (deref_tycon tcref) || Array.exists (rfref_of_rfield tcref >> hiddenRfield) tcref.AllFieldsArray
|
|
then UnknownValue
|
|
else RecdValue (tcref,Array.map abstractExprInfo vinfos)
|
|
| UnionCaseValue(ucref,vinfos) ->
|
|
let tcref = ucref.TyconRef
|
|
if hiddenTyconRepr ucref.Tycon || tcref.UnionCasesArray |> Array.exists (ucref_of_ucase tcref >> hiddenUconstr)
|
|
then UnknownValue
|
|
else UnionCaseValue (ucref,Array.map abstractExprInfo vinfos)
|
|
| ModuleValue sinfo -> ModuleValue (abstractModulInfo sinfo)
|
|
| SizeValue(vdepth,vinfo) -> MakeSizedValueInfo (abstractExprInfo vinfo)
|
|
| UnknownValue
|
|
| ConstExprValue _
|
|
| CurriedLambdaValue _
|
|
| ConstValue _ -> ivalue
|
|
and abstractValInfo v = { ValExprInfo=abstractExprInfo v.ValExprInfo; ValMakesNoCriticalTailcalls=v.ValMakesNoCriticalTailcalls }
|
|
and abstractModulInfo ss =
|
|
if verboseOptimizationInfo then dprintf "abstractModulInfo\n";
|
|
{ ModuleOrNamespaceInfos = NameMap.map abstractLazyModulInfo ss.ModuleOrNamespaceInfos;
|
|
ValInfos =
|
|
ss.ValInfos
|
|
|> NameMap.filterRange (fst >> deref_val >> hiddenVal >> not)
|
|
|> NameMap.map (fun (vref,e) ->
|
|
check "its implementation uses a binding hidden by a signature" m vref (abstractValInfo e) ) }
|
|
and abstractLazyModulInfo (ss:LazyModuleInfo) =
|
|
ss.Force() |> abstractModulInfo |> notlazy
|
|
|
|
abstractLazyModulInfo
|
|
|
|
/// Hide all information except what we need for "must inline". We always save this optimization information
|
|
let AbstractLazyModulInfoToEssentials =
|
|
|
|
let rec abstractModulInfo (ss:ModuleInfo) =
|
|
{ ModuleOrNamespaceInfos = NameMap.map (Lazy.force >> abstractModulInfo >> notlazy) ss.ModuleOrNamespaceInfos;
|
|
ValInfos = ss.ValInfos |> NameMap.filterRange (fun (v,_) -> v.MustInline) }
|
|
and abstractLazyModulInfo ss = ss |> Lazy.force |> abstractModulInfo |> notlazy
|
|
|
|
abstractLazyModulInfo
|
|
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Hide information because of a "let ... in ..." or "let rec ... in ... "
|
|
//-------------------------------------------------------------------------
|
|
|
|
let AbstractExprInfoByVars m (boundVars:Val list,boundTyVars) ivalue =
|
|
// Module and member bindings can be skipped when checking abstraction, since abstraction of these values has already been done when
|
|
// we hit the end of the module and called AbstractLazyModulInfoByHiding. If we don't skip these then we end up quadtratically retraversing
|
|
// the inferred optimization data, i.e. at each binding all the way up a sequences of 'lets' in a module.
|
|
let boundVars = boundVars |> List.filter (fun v -> not v.IsMemberOrModuleBinding)
|
|
|
|
match boundVars,boundTyVars with
|
|
| [],[] -> ivalue
|
|
| _ ->
|
|
//let dump() =
|
|
// boundVars |> List.iter (fun v -> dprintf " -- bv %s @ %a\n" v.MangledName output_range v.Range);
|
|
// boundTyVars |> List.iter (fun v -> dprintf " -- btyv %s @ %a\n" v.Name output_range v.Range)
|
|
|
|
let rec abstractExprInfo ivalue =
|
|
match ivalue with
|
|
(* Check for escaping value. Revert to old info if possible *)
|
|
| ValValue (VRef_private v2,detail) when
|
|
(nonNil boundVars && List.exists (vspec_eq v2) boundVars) ||
|
|
(nonNil boundTyVars &&
|
|
let ftyvs = free_in_val CollectTypars v2
|
|
List.exists (Zset.mem_of ftyvs.FreeTypars) boundTyVars) ->
|
|
|
|
if verboseOptimizationInfo then
|
|
dprintf "hiding value '%s' when used in expression (see %a)\n" v2.MangledName output_range v2.Range;
|
|
let ftyvs = free_in_val CollectTypars v2
|
|
ftyvs.FreeTypars |> Zset.iter (fun v -> dprintf " -- ftyv %s @ %a\n" v.Name output_range v.Range);
|
|
boundVars |> List.iter (fun v -> dprintf " -- bv %s @ %a\n" v.MangledName output_range v.Range);
|
|
boundTyVars |> List.iter (fun v -> dprintf " -- btyv %s @ %a\n" v.Name output_range v.Range)
|
|
|
|
abstractExprInfo detail
|
|
| ValValue (v2,detail) ->
|
|
let detail' = abstractExprInfo detail
|
|
ValValue (v2,detail')
|
|
|
|
// Check for escape in lambda
|
|
| CurriedLambdaValue (_,_,_,expr,_) | ConstExprValue(_,expr) when
|
|
(let fvs = free_in_expr (if isNil boundTyVars then CollectLocals else CollectTyparsAndLocals) expr
|
|
(nonNil boundVars && List.exists (Zset.mem_of fvs.FreeLocals) boundVars) or
|
|
(nonNil boundTyVars && List.exists (Zset.mem_of fvs.FreeTyvars.FreeTypars) boundTyVars) or
|
|
(fvs.UsesMethodLocalConstructs )) ->
|
|
if verboseOptimizationInfo then
|
|
let fvs = free_in_expr (if isNil boundTyVars then CollectLocals else CollectTyparsAndLocals) expr
|
|
dprintf "Trimming lambda @ %a, UsesMethodLocalConstructs = %b, ExprL = %s\n" output_range (range_of_expr expr) fvs.UsesMethodLocalConstructs (showL (ExprL expr));
|
|
fvs.FreeLocals |> Zset.iter (fun v -> dprintf "fv %s @ %a\n" v.MangledName output_range v.Range);
|
|
fvs.FreeTyvars.FreeTypars |> Zset.iter (fun v -> dprintf "ftyv %s @ %a\n" v.Name output_range v.Range);
|
|
boundVars |> List.iter (fun v -> dprintf "bv %s @ %a\n" v.MangledName output_range v.Range);
|
|
boundTyVars |> List.iter (fun v -> dprintf "btyv %s @ %a\n" v.Name output_range v.Range)
|
|
|
|
UnknownValue
|
|
|
|
// Check for escape in generic constant
|
|
| ConstValue(_,ty) when
|
|
(nonNil boundTyVars &&
|
|
(let ftyvs = free_in_type CollectTypars ty
|
|
List.exists (Zset.mem_of ftyvs.FreeTypars) boundTyVars)) ->
|
|
UnknownValue
|
|
|
|
// Otherwise check all sub-values
|
|
| TupleValue vinfos -> TupleValue (Array.map (abstractExprInfo) vinfos)
|
|
| RecdValue (tcref,vinfos) -> RecdValue (tcref,Array.map (abstractExprInfo) vinfos)
|
|
| UnionCaseValue (cspec,vinfos) -> UnionCaseValue(cspec,Array.map (abstractExprInfo) vinfos)
|
|
| ModuleValue sinfo -> ModuleValue (abstractModulInfo sinfo)
|
|
| CurriedLambdaValue _
|
|
| ConstValue _
|
|
| ConstExprValue _
|
|
| UnknownValue -> ivalue
|
|
| SizeValue (vdepth,vinfo) -> MakeSizedValueInfo (abstractExprInfo vinfo)
|
|
|
|
and abstractValInfo v =
|
|
{ ValExprInfo=abstractExprInfo v.ValExprInfo;
|
|
ValMakesNoCriticalTailcalls=v.ValMakesNoCriticalTailcalls }
|
|
|
|
and abstractModulInfo ss =
|
|
{ ModuleOrNamespaceInfos = ss.ModuleOrNamespaceInfos |> NameMap.map (Lazy.force >> abstractModulInfo >> notlazy) ;
|
|
ValInfos = ss.ValInfos |> NameMap.map (fun (vref,e) ->
|
|
if verboseOptimizationInfo then dprintf "checking %s @ %a\n" vref.MangledName output_range (vref.Range);
|
|
check "its implementation uses a private binding" m vref (abstractValInfo e) ) }
|
|
|
|
abstractExprInfo ivalue
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Rewrite optimization, e.g. to use public stable references so we can pickle it
|
|
// to disk.
|
|
//-------------------------------------------------------------------------
|
|
let RemapLazyModulInfo g tmenv =
|
|
|
|
let rec remapExprInfo ivalue =
|
|
if verboseOptimizationInfo then dprintf "remapExprInfo\n";
|
|
match ivalue with
|
|
| ValValue (v,detail) -> ValValue (remap_vref tmenv v,remapExprInfo detail)
|
|
| TupleValue vinfos -> TupleValue (Array.map remapExprInfo vinfos)
|
|
| RecdValue (tcref,vinfos) -> RecdValue (remap_tcref tmenv.tcref_remap tcref, Array.map remapExprInfo vinfos)
|
|
| UnionCaseValue(cspec,vinfos) -> UnionCaseValue (remap_ucref tmenv.tcref_remap cspec,Array.map remapExprInfo vinfos)
|
|
| ModuleValue sinfo -> ModuleValue (remapModulInfo sinfo)
|
|
| SizeValue(vdepth,vinfo) -> MakeSizedValueInfo (remapExprInfo vinfo)
|
|
| UnknownValue -> UnknownValue
|
|
| CurriedLambdaValue (uniq,arity,sz,expr,typ) -> CurriedLambdaValue (uniq,arity,sz,remap_expr g CloneAll tmenv expr,remap_possible_forall_typ g tmenv typ)
|
|
| ConstValue (c,ty) -> ConstValue (c,remap_possible_forall_typ g tmenv ty)
|
|
| ConstExprValue (sz,expr) -> ConstExprValue (sz,remap_expr g CloneAll tmenv expr)
|
|
|
|
and remapValInfo v = { ValExprInfo=remapExprInfo v.ValExprInfo; ValMakesNoCriticalTailcalls=v.ValMakesNoCriticalTailcalls }
|
|
and remapModulInfo ss =
|
|
if verboseOptimizationInfo then dprintf "remapModulInfo\n";
|
|
{ ModuleOrNamespaceInfos = ss.ModuleOrNamespaceInfos |> NameMap.map RemapLazyModulInfo;
|
|
ValInfos = ss.ValInfos |> NameMap.map (fun (vref,vinfo) ->
|
|
let vref' = remap_vref tmenv vref
|
|
let vinfo = remapValInfo vinfo
|
|
// Propogate any inferred ValMakesNoCriticalTailcalls flag from implementation to signature information
|
|
if vinfo.ValMakesNoCriticalTailcalls then set_notailcall_hint_of_vflags vref'.Deref.Data true
|
|
(vref',vinfo)) }
|
|
|
|
and RemapLazyModulInfo ss =
|
|
ss |> Lazy.force |> remapModulInfo |> notlazy
|
|
|
|
RemapLazyModulInfo
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Hide information when a value is no longer visible
|
|
//-------------------------------------------------------------------------
|
|
|
|
let AbstractAndRemapModulInfo msg g m (repackage,hidden) info =
|
|
let mrpi = mk_repackage_remapping repackage
|
|
if verboseOptimizationInfo then dprintf "%s - %a - Optimization data prior to trim: \n%s\n" msg output_range m (Layout.showL (Layout.squashTo 192 (moduleInfoL info)));
|
|
let info = info |> AbstractLazyModulInfoByHiding false m hidden
|
|
if verboseOptimizationInfo then dprintf "%s - %a - Optimization data after trim:\n%s\n" msg output_range m (Layout.showL (Layout.squashTo 192 (moduleInfoL info)));
|
|
let info = info |> RemapLazyModulInfo g mrpi
|
|
if verboseOptimizationInfo then dprintf "%s - %a - Optimization data after remap:\n%s\n" msg output_range m (Layout.showL (Layout.squashTo 192 (moduleInfoL info)));
|
|
info
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Misc helerps
|
|
//-------------------------------------------------------------------------
|
|
|
|
(* Mark some variables (the ones we introduce via abstractBigTargets) as don't-eliminate *)
|
|
let suffixForVariablesThatMayNotBeEliminated = "$cont"
|
|
|
|
/// Type applications of F# "type functions" may cause side effects, e.g.
|
|
/// let x<'a> = printfn "hello"; typeof<'a>
|
|
/// In this case do not treat them as constants.
|
|
let IsTyFuncValRefExpr = function
|
|
| TExpr_val (fv,_,_) -> fv.IsTypeFunction
|
|
| _ -> false
|
|
|
|
/// Type applications of existing functions are always simple constants, with the exception of F# 'type functions'
|
|
/// REVIEW: we could also include any under-applied application here.
|
|
let rec IsSmallConstExpr x =
|
|
match x with
|
|
| TExpr_val (v,_,m) -> not v.IsMutable
|
|
| TExpr_app(fe,_,tyargs,args,_) -> isNil(args) && not (IsTyFuncValRefExpr fe) && IsSmallConstExpr fe
|
|
| _ -> false
|
|
|
|
let ValueOfExpr expr =
|
|
if IsSmallConstExpr expr then
|
|
ConstExprValue(0,expr)
|
|
else UnknownValue
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Dead binding elimination
|
|
//-------------------------------------------------------------------------
|
|
|
|
let ValueIsUsedOrHasEffect cenv m fvs (b:Binding,binfo) =
|
|
let v = b.Var
|
|
not (cenv.settings.EliminateUnusedBindings()) ||
|
|
isSome v.MemberInfo ||
|
|
binfo.HasEffect ||
|
|
Zset.mem v fvs
|
|
|
|
let rec SplitValuesByIsUsedOrHasEffect cenv m fvs x =
|
|
x |> FlatList.filter (ValueIsUsedOrHasEffect cenv m fvs) |> FlatList.unzip
|
|
|
|
//-------------------------------------------------------------------------
|
|
//
|
|
//-------------------------------------------------------------------------
|
|
|
|
let IlAssemblyCodeInstrHasEffect i =
|
|
match i with
|
|
| I_arith ( AI_nop | AI_ldc _ | AI_add | AI_sub | AI_mul | AI_xor | AI_and | AI_or
|
|
| AI_ceq | AI_cgt | AI_cgt_un | AI_clt | AI_clt_un | AI_conv _ | AI_shl
|
|
| AI_shr | AI_shr_un | AI_neg | AI_not | AI_ldnull )
|
|
| I_ldstr _ | I_ldtoken _ -> false
|
|
| _ -> true
|
|
|
|
let IlAssemblyCodeHasEffect instrs = List.exists IlAssemblyCodeInstrHasEffect instrs
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Effects
|
|
//
|
|
// note: allocating an object with observable identity (i.e. a name)
|
|
// or reading from a mutable field counts as an 'effect', i.e.
|
|
// this context 'effect' has it's usual meaning in the effect analysis literature of
|
|
// read-from-mutable
|
|
// write-to-mutable
|
|
// name-generation
|
|
// arbitrary-side-effect (e.g. 'non-termination' or 'fire the missiles')
|
|
//-------------------------------------------------------------------------
|
|
|
|
let rec ExprHasEffect g expr =
|
|
match expr with
|
|
| TExpr_val (vref,_,_) -> vref.IsTypeFunction or (vref.IsMutable)
|
|
| TExpr_quote _
|
|
| TExpr_lambda _
|
|
| TExpr_tlambda _
|
|
| TExpr_const _ -> false
|
|
/// type applications do not have effects, with the exception of type functions
|
|
| TExpr_app(f0,_,_,[],_) -> (IsTyFuncValRefExpr f0) or ExprHasEffect g f0
|
|
| TExpr_op(op,_,args,_) -> ExprsHaveEffect g args || OpHasEffect g op
|
|
| TExpr_letrec(binds,body,_,_) -> BindingsHaveEffect g binds || ExprHasEffect g body
|
|
| TExpr_let(bind,body,_,_) -> BindingHasEffect g bind || ExprHasEffect g body
|
|
// REVIEW: could add TExpr_obj on an interface type - these are similar to records of lambda expressions
|
|
| _ -> true
|
|
and ExprsHaveEffect g exprs = List.exists (ExprHasEffect g) exprs
|
|
and BindingsHaveEffect g binds = FlatList.exists (BindingHasEffect g) binds
|
|
and BindingHasEffect g bind = bind.Expr |> ExprHasEffect g
|
|
and OpHasEffect g op =
|
|
match op with
|
|
| TOp_tuple -> false
|
|
| TOp_recd (ctor,tcref) ->
|
|
match ctor with
|
|
| RecdExprIsObjInit -> true
|
|
| RecdExpr -> tcref_alloc_observable tcref
|
|
| TOp_ucase ucref -> tcref_alloc_observable ucref.TyconRef
|
|
| TOp_exnconstr ecref -> ecref_alloc_observable ecref
|
|
| TOp_bytes _ | TOp_uint16s _ | TOp_array -> true (* alloc observable *)
|
|
| TOp_ucase_tag_get _ -> false
|
|
| TOp_ucase_proof _ -> false
|
|
| TOp_ucase_field_get (ucref,n) -> ucref_rfield_mutable g ucref n
|
|
| TOp_asm(instrs,_) -> IlAssemblyCodeHasEffect instrs
|
|
| TOp_tuple_field_get(_) -> false
|
|
| TOp_exnconstr_field_get(ecref,n) -> ecref_rfield_mutable ecref n
|
|
| TOp_get_ref_lval -> false
|
|
| TOp_rfield_get rfref -> rfref.RecdField.IsMutable
|
|
| TOp_field_get_addr rfref -> true (* check *)
|
|
| TOp_ucase_field_set _
|
|
| TOp_exnconstr_field_set _
|
|
| TOp_coerce
|
|
| TOp_rethrow
|
|
| TOp_for _
|
|
| TOp_while _
|
|
| TOp_try_catch _
|
|
| TOp_try_finally _ (* note: these really go through a different path anyway *)
|
|
| TOp_trait_call _
|
|
| TOp_goto _
|
|
| TOp_label _
|
|
| TOp_return
|
|
| TOp_ilcall _ (* conservative *)
|
|
| TOp_lval_op _ (* conservative *)
|
|
| TOp_rfield_set _ -> true
|
|
|
|
|
|
let TryEliminateBinding cenv env (TBind(vspec1,e1,spBind)) e2 m =
|
|
// don't eliminate bindings if we're not optimizing AND the binding is not a compiler generated variable
|
|
if not (cenv.optimizing && cenv.settings.EliminateImmediatelyConsumedLocals()) &&
|
|
not vspec1.IsCompilerGenerated then
|
|
None
|
|
else
|
|
// Peephole on immediate consumption of single bindings, e.g. "let x = e in x" --> "e"
|
|
// REVIEW: enhance this by general elimination of bindings to
|
|
// non-side-effecting expressions that are used only once.
|
|
// But note the cases below cover some instances of side-effecting expressions as well....
|
|
let IsUniqueUse vspec2 args =
|
|
vspec_eq vspec1 vspec2
|
|
&& (not (vspec2.MangledName.Contains(suffixForVariablesThatMayNotBeEliminated)))
|
|
// REVIEW: this looks slow. Look only for one variable instead
|
|
&& (let fvs = acc_free_in_exprs CollectLocals args empty_freevars
|
|
not (Zset.mem vspec1 fvs.FreeLocals))
|
|
|
|
// Immediate consumption of value as 2nd or subsequent argument to a construction or projection operation
|
|
let rec GetImmediateUseContext rargsl argsr =
|
|
match argsr with
|
|
| (TExpr_val(VRef_private vspec2,_,_)) :: argsr2
|
|
when vspec_eq vspec1 vspec2 && IsUniqueUse vspec2 (List.rev rargsl@argsr2) -> Some(List.rev rargsl,argsr2)
|
|
| argsrh :: argsrt when not (ExprHasEffect cenv.g argsrh) -> GetImmediateUseContext (argsrh::rargsl) argsrt
|
|
| _ -> None
|
|
|
|
match strip_expr e2 with
|
|
|
|
// Immediate consumption of value as itself 'let x = e in x'
|
|
| TExpr_val(VRef_private vspec2,_,_)
|
|
when IsUniqueUse vspec2 [] ->
|
|
// if verbose then dprintf "Simplifying let x = e in x near %a\n" output_range m;
|
|
Some e1
|
|
|
|
// Immediate consumption of value by a pattern match 'let x = e in match x with ...'
|
|
| TExpr_match(spMatch,exprm,TDSwitch(TExpr_val(VRef_private vspec2,_,_),cases,dflt,_),targets,m,ty2,_)
|
|
when (vspec_eq vspec1 vspec2 &&
|
|
let fvs = acc_free_in_targets CollectLocals targets (acc_free_in_switch_cases CollectLocals cases dflt empty_freevars)
|
|
not (Zset.mem vspec1 fvs.FreeLocals)) ->
|
|
(* if verbose then dprintf "Simplifying let x = e in match x with ... near %a\n" output_range m;*)
|
|
let spMatch = spBind.Combine(spMatch)
|
|
Some (TExpr_match(spMatch,range_of_expr e1,TDSwitch(e1,cases,dflt,m),targets,m,ty2,SkipFreeVarsCache()))
|
|
|
|
// Immediate consumption of value as a function 'let f = e in f ...'
|
|
// Note functions are evaluated before args
|
|
// Note: do not include functions with a single arg of unit type, introduced by abstractBigTargets
|
|
| TExpr_app(f,f0ty,tyargs,args,m)
|
|
when not (vspec1.MangledName.Contains(suffixForVariablesThatMayNotBeEliminated)) ->
|
|
match GetImmediateUseContext [] (f::args) with
|
|
| Some([],rargs) -> Some (MakeApplicationAndBetaReduce cenv.g (e1,f0ty,[tyargs],rargs ,m))
|
|
| Some(f::largs,rargs) -> Some (MakeApplicationAndBetaReduce cenv.g (f,f0ty,[tyargs],largs @ (e1::rargs),m))
|
|
| None -> None
|
|
|
|
// Immediate consumption of value as first non-effectful argument to a construction or projection operation
|
|
// 'let x = e in op[x;....]'
|
|
| TExpr_op (c,tyargs,args,m) ->
|
|
match GetImmediateUseContext [] args with
|
|
| Some(largs,rargs) -> Some (TExpr_op (c,tyargs,(largs @ (e1:: rargs)),m))
|
|
| None -> None
|
|
|
|
| _ ->
|
|
None
|
|
|
|
let TryEliminateLet cenv env bind e2 m =
|
|
match TryEliminateBinding cenv env bind e2 m with
|
|
| Some e2' -> e2',-local_var_size (* eliminated a let, hence reduce size estimate *)
|
|
| None -> mk_let_bind m bind e2 ,0
|
|
|
|
//-------------------------------------------------------------------------
|
|
|
|
/// Detect the application of a value to an arbitrary number of arguments
|
|
let rec (|KnownValApp|_|) expr =
|
|
match strip_expr expr with
|
|
| TExpr_val(vref,_,_) -> Some(vref,[],[])
|
|
| TExpr_app(KnownValApp(vref,typeArgs1,otherArgs1),_,typeArgs2,otherArgs2,_) -> Some(vref,typeArgs1@typeArgs2,otherArgs1@otherArgs2)
|
|
| _ -> None
|
|
|
|
//-------------------------------------------------------------------------
|
|
// ExpandStructuralBinding
|
|
//
|
|
// Expand bindings to tuple expressions by factoring sub-expression out as prior bindings.
|
|
// Similarly for other structural constructions, like records...
|
|
// If the item is only projected from then the construction (allocation) can be eliminated.
|
|
// This transform encourages that by allowing projections to be simplified.
|
|
//-------------------------------------------------------------------------
|
|
|
|
let ExprIsValue = function TExpr_val _ -> true | _ -> false
|
|
let ExpandStructuralBinding cenv env expr =
|
|
match expr with
|
|
| TExpr_let (TBind(v,rhs,tgtSeqPtOpt),body,m,_)
|
|
when (is_tuple rhs &&
|
|
not v.IsCompiledAsTopLevel &&
|
|
not v.IsMember &&
|
|
not v.IsTypeFunction &&
|
|
not v.IsMutable) ->
|
|
let args = try_dest_tuple rhs
|
|
if List.forall ExprIsValue args then
|
|
expr (* avoid re-expanding when recursion hits original binding *)
|
|
else
|
|
let argTys = dest_tuple_typ cenv.g v.Type
|
|
let argBind i arg argTy =
|
|
let name = v.MangledName ^ "_" ^ string i
|
|
let v,ve = mk_compgen_local (range_of_expr arg) name argTy
|
|
ve,mk_compgen_bind v arg
|
|
|
|
let ves,binds = List.mapi2 argBind args argTys |> List.unzip
|
|
let tuple = mk_tupled cenv.g m ves argTys
|
|
mk_lets_bind m binds (mk_let tgtSeqPtOpt m v tuple body)
|
|
(* REVIEW: other cases - records, explicit lists etc. *)
|
|
| expr -> expr
|
|
|
|
//-------------------------------------------------------------------------
|
|
// The traversal
|
|
//-------------------------------------------------------------------------
|
|
|
|
let rec OptimizeExpr cenv (env:IncrementalOptimizationEnv) expr =
|
|
if verboseOptimizations then dprintf "OptimizeExpr@%a\n" output_range (range_of_expr expr);
|
|
|
|
// Eliminate subsumption coercions for functions. This must be done post-typechecking because we need
|
|
// complete inference types.
|
|
let expr = NormalizeAndAdjustPossibleSubsumptionExprs cenv.g expr
|
|
|
|
let expr = strip_expr expr
|
|
|
|
|
|
match expr with
|
|
(* treat the common linear cases to avoid stack overflows, using an explicit continutation *)
|
|
| TExpr_seq _ | TExpr_let _ -> OptimizeLinearExpr cenv env expr (fun x -> x)
|
|
|
|
| TExpr_const (c,m,ty) -> OptimizeConst cenv env expr (c,m,ty)
|
|
| TExpr_val (v,vFlags,m) -> OptimizeVal cenv env expr (v,m)
|
|
| TExpr_quote(ast,conv,m,ty) ->
|
|
TExpr_quote(ast,conv,m,ty),
|
|
{ TotalSize = 10;
|
|
FunctionSize = 1;
|
|
HasEffect = false;
|
|
MightMakeCriticalTailcall=false;
|
|
Info=UnknownValue }
|
|
| TExpr_obj (_,typ,basev,expr,overrides,iimpls,m,_) -> OptimizeObjectExpr cenv env (typ,basev,expr,overrides,iimpls,m)
|
|
| TExpr_op (c,tyargs,args,m) -> OptimizeExprOp cenv env (c,tyargs,args,m)
|
|
| TExpr_app(f,fty,tyargs,argsl,m) -> OptimizeApplication cenv env (f,fty,tyargs,argsl,m)
|
|
(* REVIEW: fold the next two cases together *)
|
|
| TExpr_lambda(lambdaId,_,argvs,body,m,rty,_) ->
|
|
let topValInfo = TopValInfo ([],[argvs |> List.map (fun _ -> TopValInfo.unnamedTopArg1)],TopValInfo.unnamedRetVal)
|
|
let ty = mk_multi_lambda_ty m argvs rty
|
|
OptimizeLambdas None cenv env topValInfo expr ty
|
|
| TExpr_tlambda(lambdaId,tps,body,m,rty,_) ->
|
|
let topValInfo = TopValInfo (TopValInfo.InferTyparInfo tps,[],TopValInfo.unnamedRetVal)
|
|
let ty = try_mk_forall_ty tps rty
|
|
OptimizeLambdas None cenv env topValInfo expr ty
|
|
| TExpr_tchoose _ -> OptimizeExpr cenv env (Typrelns.choose_typar_solutions_for_tchoose cenv.g cenv.amap expr)
|
|
| TExpr_match(spMatch,exprm,dtree,targets,m,ty,_) -> OptimizeMatch cenv env (spMatch,exprm,dtree,targets,m,ty)
|
|
| TExpr_letrec (binds,e,m,_) -> OptimizeLetRec cenv env (binds,e,m)
|
|
| TExpr_static_optimization (constraints,e2,e3,m) ->
|
|
let e2',e2info = OptimizeExpr cenv env e2
|
|
let e3',e3info = OptimizeExpr cenv env e3
|
|
TExpr_static_optimization(constraints,e2',e3',m),
|
|
{ TotalSize = min e2info.TotalSize e3info.TotalSize;
|
|
FunctionSize = min e2info.FunctionSize e3info.FunctionSize;
|
|
HasEffect = e2info.HasEffect || e3info.HasEffect;
|
|
MightMakeCriticalTailcall=e2info.MightMakeCriticalTailcall || e3info.MightMakeCriticalTailcall // seems conservative
|
|
Info= UnknownValue }
|
|
| TExpr_link eref ->
|
|
assert ("unexpected reclink" = "");
|
|
failwith "Unexpected reclink"
|
|
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze an object expression
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeObjectExpr cenv env (typ,basevopt,basecall,overrides,iimpls,m) =
|
|
if verboseOptimizations then dprintf "OptimizeObjectExpr\n";
|
|
let basecall',basecallinfo = OptimizeExpr cenv env basecall
|
|
let overrides',overrideinfos = OptimizeMethods cenv env basevopt overrides
|
|
let iimpls',iimplsinfos = OptimizeInterfaceImpls cenv env basevopt iimpls
|
|
let expr'=mk_obj_expr(typ,basevopt,basecall',overrides',iimpls',m)
|
|
expr', { TotalSize=closureTotalSize + basecallinfo.TotalSize + AddTotalSizes overrideinfos + AddTotalSizes iimplsinfos;
|
|
FunctionSize=1 (* a newobj *) ;
|
|
HasEffect=true;
|
|
MightMakeCriticalTailcall=false; // creating an object is not a useful tailcall
|
|
Info=UnknownValue}
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze the methods that make up an object expression
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeMethods cenv env basevopt l = OptimizeList (OptimizeMethod cenv env basevopt) l
|
|
and OptimizeMethod cenv env basevopt (TObjExprMethod(slotsig,tps,vs,e,m) as tmethod) =
|
|
if verboseOptimizations then dprintf "OptimizeMethod\n";
|
|
let env = {env with latestBoundId=Some tmethod.Id; functionVal = None}
|
|
let env = BindTypeVarsToUnknown tps env
|
|
let env = bind_internal_vspecs_to_unknown cenv vs env
|
|
let env = Option.fold_right (bind_internal_vspec_to_unknown cenv) basevopt env
|
|
let e',einfo = OptimizeExpr cenv env e
|
|
(* REVIEW: if we ever change this from being UnknownValue then we should call AbstractExprInfoByVars *)
|
|
TObjExprMethod(slotsig,tps,vs,e',m),
|
|
{ TotalSize = einfo.TotalSize;
|
|
FunctionSize = 0;
|
|
HasEffect = false;
|
|
MightMakeCriticalTailcall=false;
|
|
Info=UnknownValue}
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze the interface implementations that form part of an object expression
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeInterfaceImpls cenv env basevopt l = OptimizeList (OptimizeInterfaceImpl cenv env basevopt) l
|
|
and OptimizeInterfaceImpl cenv env basevopt (ty,overrides) =
|
|
if verboseOptimizations then dprintf "OptimizeInterfaceImpl\n";
|
|
let overrides',overridesinfos = OptimizeMethods cenv env basevopt overrides
|
|
(ty, overrides'),
|
|
{ TotalSize = AddTotalSizes overridesinfos;
|
|
FunctionSize = 1;
|
|
HasEffect = false;
|
|
MightMakeCriticalTailcall=false;
|
|
Info=UnknownValue}
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze an application of an intrinsic operator to arguments
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeExprOp cenv env (op,tyargs,args,m) =
|
|
|
|
if verboseOptimizations then dprintf "OptimizeExprOp\n";
|
|
(* Special cases *)
|
|
match op,tyargs,args with
|
|
| TOp_coerce,[toty;fromty],[e] ->
|
|
let e',einfo = OptimizeExpr cenv env e
|
|
if type_equiv cenv.g toty fromty then e',einfo
|
|
else
|
|
mk_coerce(e',toty,m,fromty),
|
|
{ TotalSize=einfo.TotalSize + 1;
|
|
FunctionSize=einfo.FunctionSize + 1;
|
|
HasEffect = true;
|
|
MightMakeCriticalTailcall=false;
|
|
Info=UnknownValue }
|
|
(* Handle these as special cases since mutables are allowed inside their bodies *)
|
|
| TOp_while spWhile,_,[TExpr_lambda(_,_,[_],e1,_,_,_);TExpr_lambda(_,_,[_],e2,_,_,_)] -> OptimizeWhileLoop cenv env (spWhile,e1,e2,m)
|
|
| TOp_for(spStart,dir),_,[TExpr_lambda(_,_,[_],e1,_,_,_);TExpr_lambda(_,_,[_],e2,_,_,_);TExpr_lambda(_,_,[v],e3,_,_,_)] -> OptimizeFastIntegerForLoop cenv env (spStart,v,e1,dir,e2,e3,m)
|
|
| TOp_try_finally(spTry,spFinally),[resty],[TExpr_lambda(_,_,[_],e1,_,_,_); TExpr_lambda(_,_,[_],e2,_,_,_)] -> OptimizeTryFinally cenv env (spTry,spFinally,e1,e2,m,resty)
|
|
| TOp_try_catch(spTry,spWith),[resty],[TExpr_lambda(_,_,[_],e1,_,_,_); TExpr_lambda(_,_,[vf],ef,_,_,_); TExpr_lambda(_,_,[vh],eh,_,_,_)] -> OptimizeTryCatch cenv env (e1,vf,ef,vh,eh,m,resty,spTry,spWith)
|
|
| TOp_trait_call(traitInfo),[],args -> OptimizeTraitCall cenv env (traitInfo, args, m)
|
|
|
|
// This code hooks arr.Length. The idea is to ensure loops end up in the "same shape"as the forms of loops that the .NET JIT
|
|
// guarantees to optimize.
|
|
|
|
| TOp_ilcall ((virt,protect,valu,newobj,superInit,prop,isDllImport,boxthis,mref),enclTypeArgs,methTypeArgs,tys),_,[arg]
|
|
when (mref.EnclosingTypeRef.Scope.IsAssemblyRef &&
|
|
mref.EnclosingTypeRef.Scope.AssemblyRef.Name = "mscorlib" &&
|
|
mref.EnclosingTypeRef.Name = "System.Array" &&
|
|
mref.Name = "get_Length" &&
|
|
is_il_arr1_typ cenv.g (type_of_expr cenv.g arg)) ->
|
|
OptimizeExpr cenv env (TExpr_op(TOp_asm(i_ldlen,[cenv.g.int_ty]),[],[arg],m))
|
|
|
|
|
|
// Empty IL instruction lists are used as casts in prim_types.fs. But we can get rid of them
|
|
// if the types match up.
|
|
| TOp_asm([],[ty]),_,[a] when type_equiv cenv.g (type_of_expr cenv.g a) ty -> OptimizeExpr cenv env a
|
|
|
|
| _ ->
|
|
(* Reductions *)
|
|
let args',arginfos = OptimizeExprsThenConsiderSplits cenv env args
|
|
let knownValue =
|
|
match op,arginfos with
|
|
| TOp_rfield_get (rf),[e1info] -> TryOptimizeRecordFieldGet cenv env (e1info,rf,tyargs,m)
|
|
| TOp_tuple_field_get n,[e1info] -> TryOptimizeTupleFieldGet cenv env (e1info,tyargs,n,m)
|
|
| TOp_ucase_field_get (cspec,n),[e1info] -> TryOptimizeUnionCaseGet cenv env (e1info,cspec,tyargs,n,m)
|
|
| _ -> None
|
|
match knownValue with
|
|
| Some valu ->
|
|
match TryOptimizeVal cenv env (false,valu,m) with
|
|
| Some res -> OptimizeExpr cenv env res (* discard e1 since guard ensures it has no effects *)
|
|
| None -> OptimizeExprOpFallback cenv env (op,tyargs,args',m) arginfos valu
|
|
| None -> OptimizeExprOpFallback cenv env (op,tyargs,args',m) arginfos UnknownValue
|
|
|
|
|
|
and OptimizeExprOpFallback cenv env (op,tyargs,args',m) arginfos valu =
|
|
if verboseOptimizations then dprintf "OptimizeExprOpFallback\n";
|
|
(* The generic case - we may collect information, but the construction/projection doesn't disappear *)
|
|
let args_tsize = AddTotalSizes arginfos
|
|
let args_fsize = AddFunctionSizes arginfos
|
|
let args_effect = or_effects arginfos
|
|
let args_valus = List.map (fun x -> x.Info) arginfos
|
|
let effect = OpHasEffect cenv.g op
|
|
let cost,valu =
|
|
match op with
|
|
| TOp_ucase c -> 2,MakeValueInfoForUnionCase c (Array.of_list args_valus)
|
|
| TOp_exnconstr _ -> 2,valu (* REVIEW: information collection possilbe here *)
|
|
| TOp_tuple -> 1, MakeValueInfoForTuple (Array.of_list args_valus)
|
|
| TOp_rfield_get _
|
|
| TOp_tuple_field_get _
|
|
| TOp_ucase_field_get _
|
|
| TOp_exnconstr_field_get _
|
|
| TOp_ucase_tag_get _ -> 1,valu (* REVIEW: reduction possible here, and may be very effective *)
|
|
| TOp_ucase_proof _ ->
|
|
// We count the proof as size 0
|
|
// We maintain the value of the source of the proof-cast if it is known to be a UnionCaseValue
|
|
let valu = (match args_valus.[0] with StripUnionCaseValue (uc,info) -> UnionCaseValue(uc,info) | _ -> valu)
|
|
0,valu
|
|
| TOp_asm(instrs,tys) -> min (List.length instrs) 1,
|
|
MakeAssemblyCodeValueInfo cenv.g instrs args_valus tys
|
|
| TOp_bytes bytes -> (Bytes.length bytes)/10 , valu
|
|
| TOp_uint16s bytes -> bytes.Length/10 , valu
|
|
| TOp_field_get_addr _
|
|
| TOp_array | TOp_for _ | TOp_while _ | TOp_try_catch _ | TOp_try_finally _
|
|
| TOp_ilcall _
|
|
| TOp_trait_call _
|
|
| TOp_lval_op _
|
|
| TOp_rfield_set _
|
|
| TOp_ucase_field_set _
|
|
| TOp_get_ref_lval
|
|
| TOp_coerce
|
|
| TOp_rethrow
|
|
| TOp_exnconstr_field_set _ -> 1,valu
|
|
| TOp_recd (ctorInfo,tcref) ->
|
|
let finfos = tcref.AllInstanceFieldsAsList
|
|
(* REVIEW: this seems a little conservative: allocating a record with a mutable field *)
|
|
(* is not an effect - only reading or writing the field is. *)
|
|
let valu =
|
|
match ctorInfo with
|
|
| RecdExprIsObjInit -> UnknownValue
|
|
| RecdExpr ->
|
|
if args_valus.Length <> finfos.Length then valu
|
|
else MakeValueInfoForRecord tcref tyargs (Array.of_list ((args_valus,finfos) ||> List.map2 (fun x f -> if f.IsMutable then UnknownValue else x) ))
|
|
2,valu
|
|
| TOp_goto _ | TOp_label _ | TOp_return -> assert false; error(InternalError("unexpected goto/label/return in optimization",m))
|
|
|
|
// Indirect calls to IL code are always taken as tailcalls
|
|
let mayBeCriticalTailcall =
|
|
match op with
|
|
| TOp_ilcall ((virt,_,_,newobj,_,_,_,_,_),_,_,_) -> not newobj && virt
|
|
| _ -> false
|
|
|
|
let vinfo = { TotalSize=args_tsize + cost;
|
|
FunctionSize=args_fsize + cost;
|
|
HasEffect=args_effect || effect;
|
|
MightMakeCriticalTailcall= mayBeCriticalTailcall; // discard tailcall info for args - these are not in tailcall position
|
|
Info=valu }
|
|
|
|
// Replace entire expression with known value?
|
|
match TryOptimizeValInfo cenv env m vinfo with
|
|
| Some res -> res,vinfo
|
|
| None ->
|
|
TExpr_op(op,tyargs,args',m),
|
|
{ TotalSize=args_tsize + cost;
|
|
FunctionSize=args_fsize + cost;
|
|
HasEffect=args_effect || effect;
|
|
MightMakeCriticalTailcall= mayBeCriticalTailcall; // discard tailcall info for args - these are not in tailcall position
|
|
Info=valu }
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a constant node
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeConst cenv env expr (c,m,ty) =
|
|
match TryEliminateDesugaredConstants cenv.g m c with
|
|
| Some(e) ->
|
|
OptimizeExpr cenv env e
|
|
| None ->
|
|
if verboseOptimizations then dprintf "OptimizeConst\n";
|
|
expr, { TotalSize=(match c with
|
|
| TConst_string b -> b.Length/10
|
|
| _ -> 0);
|
|
FunctionSize=0;
|
|
HasEffect=false;
|
|
MightMakeCriticalTailcall=false;
|
|
Info=MakeValueInfoForConst c ty}
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a record lookup.
|
|
//-------------------------------------------------------------------------
|
|
|
|
and TryOptimizeRecordFieldGet cenv env (e1info,r,tinst,m) =
|
|
match dest_recd_value e1info.Info with
|
|
| Some finfos when cenv.settings.EliminateRecdFieldGet() && not e1info.HasEffect ->
|
|
let n = (rfref_index r)
|
|
if n >= finfos.Length then errorR(InternalError( "TryOptimizeRecordFieldGet: term argument out of range",m));
|
|
Some finfos.[n] (* Uses INVARIANT on record ValInfos that exprs are in defn order *)
|
|
| _ -> None
|
|
|
|
and TryOptimizeTupleFieldGet cenv env (e1info,tys,n,m) =
|
|
match dest_tuple_value e1info.Info with
|
|
| Some tups when cenv.settings.EliminateTupleFieldGet() && not e1info.HasEffect ->
|
|
let len = tups.Length
|
|
if len <> tys.Length then errorR(InternalError("error: tuple lengths don't match",m));
|
|
if n >= len then errorR(InternalError("TryOptimizeTupleFieldGet: tuple index out of range",m));
|
|
Some tups.[n]
|
|
| _ -> None
|
|
|
|
and TryOptimizeUnionCaseGet cenv env (e1info,cspec,tys,n,m) =
|
|
match e1info.Info with
|
|
| StripUnionCaseValue(cspec2,args) when cenv.settings.EliminatUnionCaseFieldGet() && not e1info.HasEffect && cenv.g.ucref_eq cspec cspec2 ->
|
|
if n >= args.Length then errorR(InternalError( "TryOptimizeUnionCaseGet: term argument out of range",m));
|
|
Some args.[n]
|
|
| _ -> None
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a for-loop
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeFastIntegerForLoop cenv env (spStart,v,e1,dir,e2,e3,m) =
|
|
if verboseOptimizations then dprintf "OptimizeFastIntegerForLoop\n";
|
|
let e1',e1info = OptimizeExpr cenv env e1
|
|
let e2',e2info = OptimizeExpr cenv env e2
|
|
let env = bind_internal_vspec_to_unknown cenv v env
|
|
let e3', e3info = OptimizeExpr cenv env e3
|
|
// Try to replace F#-style loops with C# style loops that recompute their bounds but which are compiled more efficiently by the JITs, e.g.
|
|
// F# "for x = 0 to arre.Length - 1 do ..." --> C# "for (int x = 0; x < arre.Length; x++) { ... }"
|
|
// F# "for x = 0 to 10 do ..." --> C# "for (int x = 0; x < 11; x++) { ... }"
|
|
let e2', dir =
|
|
match dir, e2' with
|
|
// detect upwards for loops with bounds of the form "arr.Length - 1" and convert them to a C#-style for loop
|
|
| FSharpForLoopUp, TExpr_op(TOp_asm([ I_arith AI_sub ],_),_,[TExpr_op(TOp_asm([ I_ldlen; I_arith (AI_conv DT_I4)],_),_,[arre],_);
|
|
TExpr_const(TConst_int32 1,_,_)],_)
|
|
when not (snd(OptimizeExpr cenv env arre)).HasEffect ->
|
|
|
|
mk_ldlen cenv.g m arre, CSharpForLoopUp
|
|
|
|
// detect upwards for loops with constant bounds, but not MaxValue!
|
|
| FSharpForLoopUp, TExpr_const(TConst_int32 n,_,_)
|
|
when n < System.Int32.MaxValue ->
|
|
|
|
mk_incr cenv.g m e2', CSharpForLoopUp
|
|
|
|
| _ ->
|
|
e2', dir
|
|
|
|
let einfos = [e1info;e2info;e3info]
|
|
let eff = or_effects einfos
|
|
(* neither bounds nor body has an effect, and loops always terminate, hence eliminate the loop *)
|
|
if not eff then
|
|
mk_unit cenv.g m , { TotalSize=0; FunctionSize=0; HasEffect=false; MightMakeCriticalTailcall=false; Info=UnknownValue }
|
|
else
|
|
let expr' = mk_for cenv.g (spStart,v,e1',dir,e2',e3',m)
|
|
expr', { TotalSize=AddTotalSizes einfos + forAndWhileLoopSize;
|
|
FunctionSize=AddFunctionSizes einfos + forAndWhileLoopSize;
|
|
HasEffect=eff;
|
|
MightMakeCriticalTailcall=false;
|
|
Info=UnknownValue }
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a set of recursive bindings
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeLetRec cenv env (binds,bodyExpr,m) =
|
|
if verboseOptimizations then dprintf "OptimizeLetRec\n";
|
|
let vs = binds |> FlatList.map (fun v -> v.Var) in
|
|
let env = bind_internal_vspecs_to_unknown cenv vs env
|
|
let binds',env = OptimizeBindings cenv true env binds
|
|
let bodyExpr',einfo = OptimizeExpr cenv env bodyExpr
|
|
// REVIEW: graph analysis to determine which items are unused
|
|
// Eliminate any unused bindings, as in let case
|
|
let binds'',bindinfos =
|
|
let fvs0 = free_in_expr CollectLocals bodyExpr'
|
|
let fvsN = FlatList.map (fst >> free_in_rhs CollectLocals) binds'
|
|
let fvs = FlatList.fold union_freevars fvs0 fvsN
|
|
SplitValuesByIsUsedOrHasEffect cenv m fvs.FreeLocals binds'
|
|
// Trim out any optimization info that involves escaping values
|
|
let evalue' = AbstractExprInfoByVars m (FlatList.to_list vs,[]) einfo.Info
|
|
// REVIEW: size of constructing new closures - should probably add #freevars + #recfixups here
|
|
let bodyExpr' = TExpr_letrec(binds'',bodyExpr',m,NewFreeVarsCache())
|
|
let info = CombineValueInfos (einfo :: FlatList.to_list bindinfos) evalue'
|
|
bodyExpr', info
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a linear sequence of sequentioanl execution or 'let' bindings.
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeLinearExpr cenv env expr contf =
|
|
if verboseOptimizations then dprintf "OptimizeLinearExpr\n";
|
|
let expr = if cenv.settings.ExpandStructrualValues() then ExpandStructuralBinding cenv env expr else expr
|
|
match expr with
|
|
| TExpr_seq (e1,e2,flag,spSeq,m) ->
|
|
if verboseOptimizations then dprintf "OptimizeLinearExpr: seq\n";
|
|
let e1',e1info = OptimizeExpr cenv env e1
|
|
OptimizeLinearExpr cenv env e2 (contf << (fun (e2',e2info) ->
|
|
if flag = NormalSeq && cenv.settings.EliminateSequential () && not e1info.HasEffect then
|
|
e2', e2info
|
|
else
|
|
TExpr_seq(e1',e2',flag,spSeq,m),
|
|
{ TotalSize = e1info.TotalSize + e2info.TotalSize;
|
|
FunctionSize = e1info.FunctionSize + e2info.FunctionSize;
|
|
HasEffect = flag <> NormalSeq || e1info.HasEffect || e2info.HasEffect;
|
|
MightMakeCriticalTailcall = (if flag = NormalSeq then e2info.MightMakeCriticalTailcall else e1info.MightMakeCriticalTailcall || e2info.MightMakeCriticalTailcall)
|
|
Info = UnknownValue (* can't propagate value: must access result of computation for its effects *) }))
|
|
|
|
| TExpr_let (bind,body,m,_) ->
|
|
if verboseOptimizations then dprintf "OptimizeLinearExpr: let\n";
|
|
let (bind',bindingInfo),env = OptimizeBinding cenv false env bind
|
|
OptimizeLinearExpr cenv env body (contf << (fun (body',bodyInfo) ->
|
|
if ValueIsUsedOrHasEffect cenv m (free_in_expr CollectLocals body').FreeLocals (bind',bindingInfo) then
|
|
(* Eliminate let bindings on the way back up *)
|
|
let expr',adjust = TryEliminateLet cenv env bind' body' m
|
|
expr',
|
|
{ TotalSize = bindingInfo.TotalSize + bodyInfo.TotalSize + adjust;
|
|
FunctionSize = bindingInfo.FunctionSize + bodyInfo.FunctionSize + adjust;
|
|
HasEffect=bindingInfo.HasEffect || bodyInfo.HasEffect;
|
|
MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall; // discard tailcall info from binding - not in tailcall position
|
|
Info = UnknownValue }
|
|
else
|
|
(* On the way back up: Trim out any optimization info that involves escaping values on the way back up *)
|
|
let evalue' = AbstractExprInfoByVars bind'.Var.Range ([bind'.Var],[]) bodyInfo.Info
|
|
body',
|
|
{ TotalSize = bindingInfo.TotalSize + bodyInfo.TotalSize - local_var_size (* eliminated a local var *);
|
|
FunctionSize = bindingInfo.FunctionSize + bodyInfo.FunctionSize - local_var_size (* eliminated a local var *);
|
|
HasEffect=bindingInfo.HasEffect || bodyInfo.HasEffect;
|
|
MightMakeCriticalTailcall = bodyInfo.MightMakeCriticalTailcall; // discard tailcall info from binding - not in tailcall position
|
|
Info = evalue' } ))
|
|
|
|
| _ -> contf (OptimizeExpr cenv env expr)
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a try/finally construct.
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeTryFinally cenv env (spTry,spFinally,e1,e2,m,ty) =
|
|
if verboseOptimizations then dprintf "OptimizeTryFinally\n";
|
|
let e1',e1info = OptimizeExpr cenv env e1
|
|
let e2',e2info = OptimizeExpr cenv env e2
|
|
let info =
|
|
{ TotalSize = e1info.TotalSize + e2info.TotalSize + tryFinallySize;
|
|
FunctionSize = e1info.FunctionSize + e2info.FunctionSize + tryFinallySize;
|
|
HasEffect = e1info.HasEffect || e2info.HasEffect;
|
|
MightMakeCriticalTailcall = false; // no tailcalls from inside in try/finally
|
|
Info = UnknownValue }
|
|
(* try-finally, so no effect means no exception can be raised, so just sequence the finally *)
|
|
if cenv.settings.EliminateTryCatchAndTryFinally () && not e1info.HasEffect then
|
|
let sp =
|
|
match spTry with
|
|
| SequencePointAtTry _ -> SequencePointsAtSeq
|
|
| NoSequencePointAtTry -> SuppressSequencePointOnExprOfSequential
|
|
TExpr_seq(e1',e2',ThenDoSeq,sp,m),info
|
|
else
|
|
mk_try_finally cenv.g (e1',e2',m,ty,spTry,spFinally),
|
|
info
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a try/catch construct.
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeTryCatch cenv env (e1,vf,ef,vh,eh,m,ty,spTry,spWith) =
|
|
if verboseOptimizations then dprintf "OptimizeTryCatch\n";
|
|
let e1',e1info = OptimizeExpr cenv env e1
|
|
// try-catch, so no effect means no exception can be raised, so discard the catch
|
|
if cenv.settings.EliminateTryCatchAndTryFinally () && not e1info.HasEffect then
|
|
e1',e1info
|
|
else
|
|
let envinner = bind_internal_vspec_to_unknown cenv vf (bind_internal_vspec_to_unknown cenv vh env)
|
|
let ef',efinfo = OptimizeExpr cenv envinner ef
|
|
let eh',ehinfo = OptimizeExpr cenv envinner eh
|
|
let info =
|
|
{ TotalSize = e1info.TotalSize + efinfo.TotalSize+ ehinfo.TotalSize + tryCatchSize;
|
|
FunctionSize = e1info.FunctionSize + efinfo.FunctionSize+ ehinfo.FunctionSize + tryCatchSize;
|
|
HasEffect = e1info.HasEffect || efinfo.HasEffect || ehinfo.HasEffect;
|
|
MightMakeCriticalTailcall = false;
|
|
Info = UnknownValue }
|
|
mk_try_catch cenv.g (e1',vf,ef',vh,eh',m,ty,spTry,spWith),
|
|
info
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a while loop
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeWhileLoop cenv env (spWhile,e1,e2,m) =
|
|
if verboseOptimizations then dprintf "OptimizeWhileLoop\n";
|
|
let e1',e1info = OptimizeExpr cenv env e1
|
|
let e2',e2info = OptimizeExpr cenv env e2
|
|
mk_while cenv.g (spWhile,e1',e2',m),
|
|
{ TotalSize = e1info.TotalSize + e2info.TotalSize + forAndWhileLoopSize;
|
|
FunctionSize = e1info.FunctionSize + e2info.FunctionSize + forAndWhileLoopSize;
|
|
HasEffect = true; (* may not terminate *)
|
|
MightMakeCriticalTailcall = false;
|
|
Info = UnknownValue }
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a call to a 'member' constraint. Try to resolve the call to
|
|
// a witness (should always be possible due to compulsory inlining of any
|
|
// code that contains calls to member constraints, except when analyzing
|
|
// not-yet-inlined generic code)
|
|
//-------------------------------------------------------------------------
|
|
|
|
|
|
and OptimizeTraitCall cenv env (traitInfo, args, m) =
|
|
|
|
// Resolve the static overloading early (during the compulsory rewrite phase) so we can inline.
|
|
match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.g cenv.amap m traitInfo with
|
|
|
|
| OkResult (_,Some(minfo,minst))
|
|
// Limitation related to bug 1281: If we resolve to an instance method on a struct and we haven't yet taken the address of the object
|
|
when not (Infos.minfo_is_struct cenv.g minfo && minfo.IsInstance) ->
|
|
|
|
let expr = Infos.MakeMethInfoCall cenv.amap m minfo minst args
|
|
OptimizeExpr cenv env expr
|
|
|
|
// resolution fails when optimizing generic code
|
|
| _ ->
|
|
let args',arginfos = OptimizeExprsThenConsiderSplits cenv env args
|
|
OptimizeExprOpFallback cenv env (TOp_trait_call(traitInfo),[],args,m) arginfos UnknownValue
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Make optimization decisions once we know the optimization information
|
|
// for a value
|
|
//-------------------------------------------------------------------------
|
|
|
|
and TryOptimizeVal cenv env (mustInline,valInfoForVal,m) =
|
|
match valInfoForVal with
|
|
(* Inline constants immediately *)
|
|
| ConstValue (c,ty) -> Some (TExpr_const (c,m,ty))
|
|
| SizeValue (_,detail) -> TryOptimizeVal cenv env (mustInline,detail,m)
|
|
| ValValue (v',detail) ->
|
|
if verboseOptimizations then dprintf "TryOptimizeVal, ValValue, valInfoForVal = %s\n" (showL(exprValueInfoL valInfoForVal));
|
|
(* Inline values bound to other values immediately *)
|
|
(* if verbose then dprintf "Considering inlining value %a to value %a near %a\n" output_val_ref v output_locval_ref v' output_range m; *)
|
|
match TryOptimizeVal cenv env (mustInline,detail,m) with
|
|
(* Prefer to inline using the more specific info if possible *)
|
|
| Some e -> Some e
|
|
(* If the more specific info didn't reveal an inline then use the value *)
|
|
| None -> Some(expr_for_vref m v')
|
|
| ConstExprValue(size,expr) ->
|
|
if verboseOptimizations then dprintf "Inlining constant expression value at %a\n" output_range m;
|
|
Some (RemarkExpr m (copy_expr cenv.g CloneAllAndMarkExprValsAsCompilerGenerated expr))
|
|
| CurriedLambdaValue (_,_,_,expr,_) when mustInline ->
|
|
if verboseOptimizations then dprintf "Inlining mustinline-lambda at %a\n" output_range m;
|
|
Some (RemarkExpr m (copy_expr cenv.g CloneAllAndMarkExprValsAsCompilerGenerated expr))
|
|
| TupleValue _ | UnionCaseValue _ | RecdValue _ when mustInline -> failwith "tuple, union and record values cannot be marked 'inline'"
|
|
| UnknownValue when mustInline -> warning(Error("a value marked as 'inline' has an unexpected value",m)); None
|
|
| _ when mustInline -> warning(Error("a value marked as 'inline' could not be inlined",m)); None
|
|
| _ -> None
|
|
|
|
and TryOptimizeValInfo cenv env m vinfo =
|
|
if vinfo.HasEffect then None else TryOptimizeVal cenv env (false,vinfo.Info ,m)
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Add 'v1 = v2' information into the information stored about a value
|
|
//-------------------------------------------------------------------------
|
|
|
|
and AddValEqualityInfo g m (v:ValRef) info =
|
|
if v.IsMutable then
|
|
/// the env assumes known-values do not change
|
|
info
|
|
else
|
|
{info with Info= MakeValueInfoForValue g m v info.Info}
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a use of a value
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeVal cenv env expr (v:ValRef,m) =
|
|
let valInfoForVal = GetInfoForVal cenv env m v
|
|
|
|
match TryOptimizeVal cenv env (v.MustInline,valInfoForVal.ValExprInfo ,m) with
|
|
| Some e ->
|
|
// don't reoptimize inlined lambdas until they get applied to something
|
|
match e with
|
|
| TExpr_tlambda _
|
|
| TExpr_lambda _ ->
|
|
e, (AddValEqualityInfo cenv.g m v
|
|
{ Info=valInfoForVal.ValExprInfo;
|
|
HasEffect=false;
|
|
MightMakeCriticalTailcall = false;
|
|
FunctionSize=10;
|
|
TotalSize=10})
|
|
| _ ->
|
|
let e,einfo = OptimizeExpr cenv env e
|
|
e,AddValEqualityInfo cenv.g m v einfo
|
|
|
|
| None ->
|
|
if v.MustInline then error(Error("failed to inline the value '"^v.MangledName^"' marked 'inline', perhaps because a recursive value was marked 'inline'",m));
|
|
expr,(AddValEqualityInfo cenv.g m v
|
|
{ Info=valInfoForVal.ValExprInfo;
|
|
HasEffect=false;
|
|
MightMakeCriticalTailcall = false;
|
|
FunctionSize=1;
|
|
TotalSize=1})
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Attempt to replace an application of a value by an alternative value.
|
|
//-------------------------------------------------------------------------
|
|
|
|
and StripToNominalTyconRef cenv ty =
|
|
if is_stripped_tyapp_typ cenv.g ty then dest_stripped_tyapp_typ cenv.g ty
|
|
elif is_tuple_typ cenv.g ty then
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
compiled_tuple_tcref cenv.g tyargs, tyargs
|
|
else failwith "StripToNominalTyconRef: unreachable"
|
|
|
|
|
|
and CanDevirtualizeApplication cenv v vref ty args =
|
|
cenv.g.vref_eq v vref
|
|
&& not (is_unit_typ cenv.g ty)
|
|
&& is_stripped_tyapp_typ cenv.g ty // || (is_tuple_typ cenv.g ty && List.length (dest_tuple_typ cenv.g ty) < maxTuple))
|
|
// Exclusion: Some unions have null as representations
|
|
&& not (IsUnionTypeWithNullAsTrueValue cenv.g (deref_tycon (fst(StripToNominalTyconRef cenv ty))))
|
|
// If we de-virtualize an operation on structs then we have to take the address of the object argument
|
|
// Hence we have to actually have the object argument available to us,
|
|
&& (not (is_struct_typ cenv.g ty) || nonNil args)
|
|
|
|
and TakeAddressOfStructArgumentIfNeeded cenv (vref:ValRef) ty args m =
|
|
if vref.IsInstanceMember && is_struct_typ cenv.g ty then
|
|
match args with
|
|
| objArg::rest ->
|
|
// REVIEW: we set NeverMutates. This is valid because we only ever use DevirtualizeApplication to transform
|
|
// known calls to known generated F# code for CompareTo, Equals and GetHashCode.
|
|
// If we ever reuse DevirtualizeApplication to transform an arbitrary virtual call into a
|
|
// direct call then this assumption is not valid.
|
|
let wrap,objArgAddress = mk_expra_of_expr cenv.g true NeverMutates objArg m
|
|
wrap, (objArgAddress::rest)
|
|
| _ ->
|
|
// no wrapper, args stay the same
|
|
(fun x -> x), args
|
|
else
|
|
(fun x -> x), args
|
|
|
|
and DevirtualizeApplication cenv env (vref:ValRef) ty tyargs args m =
|
|
let wrap,args = TakeAddressOfStructArgumentIfNeeded cenv vref ty args m
|
|
let transformedExpr = wrap (MakeApplicationAndBetaReduce cenv.g (expr_for_vref m vref,vref.Type,(if isNil tyargs then [] else [tyargs]),args,m))
|
|
OptimizeExpr cenv env transformedExpr
|
|
|
|
|
|
|
|
and TryDevirtualizeApplication cenv env (f,tyargs,args,m) =
|
|
match f,tyargs,args with
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonIntrinsic when type is known
|
|
// to be augmented with a visible comparison value.
|
|
//
|
|
// e.g rewrite
|
|
// 'LanguagePrimitives.HashCompare.GenericComparisonIntrinsic (x:C) (y:C)'
|
|
// --> 'x.CompareTo(y:C)' where this is a direct call to the implementation of CompareTo, i.e.
|
|
// C::CompareTo(C)
|
|
// not C::CompareTo(obj)
|
|
//
|
|
// If C is a struct type then we have to take the address of 'c'
|
|
|
|
| TExpr_val(v,_,_),[ty],_ when CanDevirtualizeApplication cenv v cenv.g.generic_comparison_inner_vref ty args ->
|
|
|
|
let tcref,tyargs = StripToNominalTyconRef cenv ty
|
|
match tcref.TypeContents.tcaug_compare with
|
|
| Some (_,vref) -> Some (DevirtualizeApplication cenv env vref ty tyargs args m)
|
|
| _ -> None
|
|
|
|
| TExpr_val(v,_,_),[ty],_ when CanDevirtualizeApplication cenv v cenv.g.generic_comparison_withc_inner_vref ty args ->
|
|
|
|
let tcref,tyargs = StripToNominalTyconRef cenv ty
|
|
match tcref.TypeContents.tcaug_compare_withc, args with
|
|
| Some vref, [comp; x; y] ->
|
|
// the target takes a tupled argument, so we need to reorder the arg expressions in the
|
|
// arg list, and create a tuple of y & comp
|
|
// push the comparer to the end and box the argument
|
|
let args2 = [x; mk_tupled_notypes cenv.g m [mk_coerce(y,cenv.g.obj_ty,m,ty) ; comp]]
|
|
Some (DevirtualizeApplication cenv env vref ty tyargs args2 m)
|
|
| _ -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityIntrinsic when type is known
|
|
// to be augmented with a visible comparison value.
|
|
| TExpr_val(v,_,_),[ty],_ when CanDevirtualizeApplication cenv v cenv.g.generic_equality_inner_vref ty args ->
|
|
|
|
let tcref,tyargs = StripToNominalTyconRef cenv ty
|
|
match tcref.TypeContents.tcaug_equals with
|
|
| Some (_,vref) -> Some (DevirtualizeApplication cenv env vref ty tyargs args m)
|
|
| _ -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparerFast
|
|
| TExpr_val(v,_,_),[ty],_ when CanDevirtualizeApplication cenv v cenv.g.generic_equality_withc_inner_vref ty args ->
|
|
let tcref,tyargs = StripToNominalTyconRef cenv ty
|
|
match tcref.TypeContents.tcaug_hash_and_equals_withc, args with
|
|
| Some (_,vref), [comp; x; y] ->
|
|
// push the comparer to the end and box the argument
|
|
let args2 = [x; mk_tupled_notypes cenv.g m [mk_coerce(y,cenv.g.obj_ty,m,ty) ; comp]]
|
|
Some (DevirtualizeApplication cenv env vref ty tyargs args2 m)
|
|
| _ -> None
|
|
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashIntrinsic
|
|
| TExpr_val(v,_,_),[ty],_ when CanDevirtualizeApplication cenv v cenv.g.generic_hash_inner_vref ty args ->
|
|
let tcref,tyargs = StripToNominalTyconRef cenv ty
|
|
match tcref.TypeContents.tcaug_hash_and_equals_withc, args with
|
|
| Some (vref,_), [x] ->
|
|
let args2 = [x; mk_call_get_generic_equality_comparer cenv.g m]
|
|
Some (DevirtualizeApplication cenv env vref ty tyargs args2 m)
|
|
| _ -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic
|
|
| TExpr_val(v,_,_),[ty],_ when CanDevirtualizeApplication cenv v cenv.g.generic_hash_withc_inner_vref ty args ->
|
|
let tcref,tyargs = StripToNominalTyconRef cenv ty
|
|
match tcref.TypeContents.tcaug_hash_and_equals_withc, args with
|
|
| Some (vref,_), [comp; x] ->
|
|
let args2 = [x; comp]
|
|
Some (DevirtualizeApplication cenv env vref ty tyargs args2 m)
|
|
| _ -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonWithComparerIntrinsic for tuple types
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.generic_comparison_inner_vref && is_tuple_typ cenv.g ty ->
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
let vref =
|
|
match tyargs.Length with
|
|
| 2 -> Some cenv.g.generic_compare_withc_tuple2_vref
|
|
| 3 -> Some cenv.g.generic_compare_withc_tuple3_vref
|
|
| 4 -> Some cenv.g.generic_compare_withc_tuple4_vref
|
|
| 5 -> Some cenv.g.generic_compare_withc_tuple5_vref
|
|
| _ -> None
|
|
match vref with
|
|
| Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mk_call_get_generic_comparer cenv.g m :: args) m)
|
|
| None -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic for tuple types
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.generic_hash_inner_vref && is_tuple_typ cenv.g ty ->
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
let vref =
|
|
match tyargs.Length with
|
|
| 2 -> Some cenv.g.generic_hash_withc_tuple2_vref
|
|
| 3 -> Some cenv.g.generic_hash_withc_tuple3_vref
|
|
| 4 -> Some cenv.g.generic_hash_withc_tuple4_vref
|
|
| 5 -> Some cenv.g.generic_hash_withc_tuple5_vref
|
|
| _ -> None
|
|
match vref with
|
|
| Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mk_call_get_generic_equality_comparer cenv.g m :: args) m)
|
|
| None -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic for tuple types
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.generic_equality_inner_vref && is_tuple_typ cenv.g ty ->
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
let vref =
|
|
match tyargs.Length with
|
|
| 2 -> Some cenv.g.generic_equals_withc_tuple2_vref
|
|
| 3 -> Some cenv.g.generic_equals_withc_tuple3_vref
|
|
| 4 -> Some cenv.g.generic_equals_withc_tuple4_vref
|
|
| 5 -> Some cenv.g.generic_equals_withc_tuple5_vref
|
|
| _ -> None
|
|
match vref with
|
|
| Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mk_call_get_generic_equality_comparer cenv.g m :: args) m)
|
|
| None -> None
|
|
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonWithComparerIntrinsic for tuple types
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.generic_comparison_withc_inner_vref && is_tuple_typ cenv.g ty ->
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
let vref =
|
|
match tyargs.Length with
|
|
| 2 -> Some cenv.g.generic_compare_withc_tuple2_vref
|
|
| 3 -> Some cenv.g.generic_compare_withc_tuple3_vref
|
|
| 4 -> Some cenv.g.generic_compare_withc_tuple4_vref
|
|
| 5 -> Some cenv.g.generic_compare_withc_tuple5_vref
|
|
| _ -> None
|
|
match vref with
|
|
| Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs args m)
|
|
| None -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic for tuple types
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.generic_hash_withc_inner_vref && is_tuple_typ cenv.g ty ->
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
let vref =
|
|
match tyargs.Length with
|
|
| 2 -> Some cenv.g.generic_hash_withc_tuple2_vref
|
|
| 3 -> Some cenv.g.generic_hash_withc_tuple3_vref
|
|
| 4 -> Some cenv.g.generic_hash_withc_tuple4_vref
|
|
| 5 -> Some cenv.g.generic_hash_withc_tuple5_vref
|
|
| _ -> None
|
|
match vref with
|
|
| Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs args m)
|
|
| None -> None
|
|
|
|
// Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparerIntrinsic for tuple types
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.generic_equality_withc_inner_vref && is_tuple_typ cenv.g ty ->
|
|
let tyargs = dest_tuple_typ cenv.g ty
|
|
let vref =
|
|
match tyargs.Length with
|
|
| 2 -> Some cenv.g.generic_equals_withc_tuple2_vref
|
|
| 3 -> Some cenv.g.generic_equals_withc_tuple3_vref
|
|
| 4 -> Some cenv.g.generic_equals_withc_tuple4_vref
|
|
| 5 -> Some cenv.g.generic_equals_withc_tuple5_vref
|
|
| _ -> None
|
|
match vref with
|
|
| Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs args m)
|
|
| None -> None
|
|
|
|
|
|
// Calls to LanguagePrimitives.IntrinsicFunctions.UnboxGeneric can be optimized to calls to UnboxFast when we know that the
|
|
// target type isn't 'NullNotLiked', i.e. that the target type is not an F# union, record etc.
|
|
// Note UnboxFast is just the .NET IL 'unbox.any' instruction.
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.unbox_vref &&
|
|
can_use_unbox_fast cenv.g ty ->
|
|
|
|
Some(DevirtualizeApplication cenv env cenv.g.unbox_fast_vref ty tyargs args m)
|
|
|
|
// Calls to LanguagePrimitives.IntrinsicFunctions.TypeTestGeneric can be optimized to calls to TypeTestFast when we know that the
|
|
// target type isn't 'NullNotTrueValue', i.e. that the target type is not an F# union, record etc.
|
|
// Note TypeTestFast is just the .NET IL 'isinst' instruction followed by a non-null comparison
|
|
| TExpr_val(v,_,_),[ty],_ when cenv.g.vref_eq v cenv.g.istype_vref &&
|
|
can_use_istype_fast cenv.g ty ->
|
|
|
|
Some(DevirtualizeApplication cenv env cenv.g.istype_fast_vref ty tyargs args m)
|
|
|
|
| _ -> None
|
|
|
|
/// Attempt to inline an application of a known value at callsites
|
|
and TryInlineApplication cenv env (f0',finfo) (tyargs,args,m) =
|
|
if verboseOptimizations then dprintf "Considering inlining app near %a\n" output_range m;
|
|
match finfo.Info with
|
|
| StripLambdaValue (lambdaId,arities,size,f2,f2ty) when
|
|
|
|
(if verboseOptimizations then dprintf "Considering inlining lambda near %a, size = %d, finfo.HasEffect = %b\n" output_range m size finfo.HasEffect;
|
|
cenv.optimizing &&
|
|
cenv.settings.InlineLambdas () &&
|
|
not finfo.HasEffect &&
|
|
(* Don't inline recursively! *)
|
|
not (Zset.mem lambdaId env.dontInline) &&
|
|
(if verboseOptimizations then dprintf "Recursion ok, #tyargs = %d, #args = %d, #arities=%d\n" (List.length tyargs) (List.length args) arities;
|
|
(* Check the number of argument groups is enough to saturate the lambdas of the target. *)
|
|
(if List.filter (fun t -> match t with TType_measure _ -> false | _ -> true) tyargs = [] then 0 else 1) + List.length args >= arities &&
|
|
(if verboseOptimizations then dprintn "Enough args";
|
|
(if size > cenv.settings.lambdaInlineThreshold + List.length args then
|
|
if verboseOptimizations then dprintf "Not inlining lambda near %a because size = %d\n" output_range m size;
|
|
false
|
|
else true)))) ->
|
|
|
|
if verboseOptimizations then dprintf "Inlining lambda near %a\n" output_range m;
|
|
(* ---------- Printf.printf "Inlining lambda near %a = %s\n" output_range m (showL (ExprL f2)); (* JAMES: *) ----------*)
|
|
let f2' = RemarkExpr m (copy_expr cenv.g CloneAllAndMarkExprValsAsCompilerGenerated f2)
|
|
if verboseOptimizations then dprintf "--- TryInlineApplication, optimizing arguments\n";
|
|
|
|
// REVIEW: this is a cheapshot way of optimizing the arg expressions as well without the restriction of recursive
|
|
// inlining kicking into effect
|
|
let args' = args |> List.map (fun e -> let e',einfo = OptimizeExpr cenv env e in e')
|
|
// Beta reduce. MakeApplicationAndBetaReduce cenv.g does all the hard work.
|
|
if verboseOptimizations then dprintf "--- TryInlineApplication, beta reducing \n";
|
|
let expr' = MakeApplicationAndBetaReduce cenv.g (f2',f2ty,[tyargs],args',m)
|
|
if verboseOptimizations then dprintf "--- TryInlineApplication, reoptimizing\n";
|
|
Some (OptimizeExpr cenv {env with dontInline= Zset.add lambdaId env.dontInline} expr')
|
|
|
|
| _ -> None
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze an application of a function to type and term arguments
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeApplication cenv env (f0,f0ty,tyargs,args,m) =
|
|
if verboseOptimizations then dprintf "--> OptimizeApplication\n";
|
|
let f0',finfo = OptimizeExpr cenv env f0
|
|
if verboseOptimizations then dprintf "--- OptimizeApplication, trying to devirtualize\n";
|
|
match TryDevirtualizeApplication cenv env (f0,tyargs,args,m) with
|
|
| Some res ->
|
|
if verboseOptimizations then dprintf "<-- OptimizeApplication, devirtualized\n";
|
|
res
|
|
| None ->
|
|
|
|
match TryInlineApplication cenv env (f0',finfo) (tyargs,args,m) with
|
|
| Some res ->
|
|
if verboseOptimizations then dprintf "<-- OptimizeApplication, inlined\n";
|
|
res
|
|
| None ->
|
|
|
|
let shapes =
|
|
match f0' with
|
|
| TExpr_val(vref,_,_) when isSome vref.TopValInfo ->
|
|
let (TopValInfo(kinds,detupArgsL,_)) = the vref.TopValInfo
|
|
let nargs = (args.Length)
|
|
let nDetupArgsL = detupArgsL.Length
|
|
let nShapes = min nargs nDetupArgsL
|
|
let detupArgsShapesL =
|
|
List.take nShapes detupArgsL |> List.map (fun detupArgs ->
|
|
match detupArgs with
|
|
| [] | [_] -> UnknownValue
|
|
| _ -> TupleValue(Array.of_list (List.map (fun _ -> UnknownValue) detupArgs)))
|
|
detupArgsShapesL @ List.replicate (nargs - nShapes) UnknownValue
|
|
|
|
| _ -> args |> List.map (fun _ -> UnknownValue)
|
|
|
|
let args',arginfos = OptimizeExprsThenReshapeAndConsiderSplits cenv env (List.zip shapes args)
|
|
if verboseOptimizations then dprintf "<-- OptimizeApplication, beta reducing\n";
|
|
let expr' = MakeApplicationAndBetaReduce cenv.g (f0',f0ty, [tyargs],args',m)
|
|
|
|
match f0' with
|
|
| TExpr_lambda _ | TExpr_tlambda _ ->
|
|
(* we beta-reduced, hence reoptimize *)
|
|
if verboseOptimizations then dprintf "<-- OptimizeApplication, beta reduced\n";
|
|
OptimizeExpr cenv env expr'
|
|
| _ ->
|
|
if verboseOptimizations then dprintf "<-- OptimizeApplication, regular\n";
|
|
|
|
// Determine if this application is a critical tailcall
|
|
let mayBeCriticalTailcall =
|
|
match f0' with
|
|
| KnownValApp(vref,typeArgs,otherArgs) ->
|
|
|
|
// Check if this is a call to a function of known arity that has been inferred to not be a critical tailcall when used as a direct call
|
|
// This includes recursive calls to the function being defined (in which case we get a non-critical, closed-world tailcall).
|
|
// Note we also have to check the argument count to ensure this is a direct call (or a partial application).
|
|
let doesNotMakeCriticalTailcall =
|
|
vref.MakesNoCriticalTailcalls ||
|
|
(let valInfoForVal = GetInfoForVal cenv env m vref in valInfoForVal.ValMakesNoCriticalTailcalls) ||
|
|
(match env.functionVal with | None -> false | Some (v,_) -> vspec_eq vref.Deref v)
|
|
if doesNotMakeCriticalTailcall then
|
|
let numArgs = otherArgs.Length + args'.Length
|
|
match vref.TopValInfo with
|
|
| Some i -> numArgs > i.NumCurriedArgs
|
|
| None ->
|
|
match env.functionVal with
|
|
| Some (v,i) -> numArgs > i.NumCurriedArgs
|
|
| None -> true // over-applicaiton of a known function, which presumably returns a function. This counts as an indirect call
|
|
else
|
|
true // application of a function that may make a critical tailcall
|
|
|
|
| _ ->
|
|
// All indirect calls (calls to unknown functions) are assumed to be critical tailcalls
|
|
true
|
|
|
|
expr', { TotalSize=finfo.TotalSize + AddTotalSizes arginfos;
|
|
FunctionSize=finfo.FunctionSize + AddFunctionSizes arginfos;
|
|
HasEffect=true;
|
|
MightMakeCriticalTailcall = mayBeCriticalTailcall;
|
|
Info=ValueOfExpr expr' }
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a lambda expression
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeLambdas (vspec: Val option) cenv env topValInfo e ety =
|
|
if verboseOptimizations then dprintf "OptimizeLambdas, #argsl = %d, %a\n" topValInfo.NumCurriedArgs output_range (range_of_expr e) ;
|
|
match e with
|
|
| TExpr_lambda (lambdaId,_,_,_,m,_,_)
|
|
| TExpr_tlambda(lambdaId,_,_,m,_,_) ->
|
|
let isTopLevel = isSome vspec && vspec.Value.IsCompiledAsTopLevel
|
|
let tps,basevopt,vsl,body,bodyty = IteratedAdjustArityOfLambda cenv.g cenv.amap topValInfo e
|
|
let env = { env with functionVal = (match vspec with None -> None | Some v -> Some (v,topValInfo)) }
|
|
let env = Option.fold_right (bind_internal_vspec_to_unknown cenv) basevopt env
|
|
let env = BindTypeVarsToUnknown tps env
|
|
let env = List.foldBack (bind_internal_vspecs_to_unknown cenv) vsl env
|
|
let env = bind_internal_vspecs_to_unknown cenv (Option.to_list basevopt) env
|
|
let body',bodyinfo = OptimizeExpr cenv env body
|
|
let expr' = mk_basev_multi_lambdas m tps basevopt vsl (body',bodyty)
|
|
let arities = List.length vsl
|
|
let arities = if tps = [] then arities else 1+arities
|
|
let bsize = bodyinfo.TotalSize
|
|
if verboseOptimizations then dprintf "lambda @ %a, bsize = %d\n" output_range m bsize;
|
|
|
|
|
|
/// Set the flag on the value indicating that direct calls can avoid a tailcall (which are expensive on .NET x86)
|
|
/// MightMakeCriticalTailcall is true whenever the body of the method may itself do a useful tailcall, e.g. has
|
|
/// an application in the last position.
|
|
match vspec with
|
|
| Some v ->
|
|
if not bodyinfo.MightMakeCriticalTailcall then
|
|
set_notailcall_hint_of_vflags v.Data true
|
|
|
|
// UNIT TEST HOOK: report analysis results for the first optimization phase
|
|
if cenv.settings.reportingPhase && not v.IsCompilerGenerated then
|
|
if cenv.settings.reportNoNeedToTailcall then
|
|
if bodyinfo.MightMakeCriticalTailcall then
|
|
printfn "value %s at line %d may make a critical tailcall" v.DisplayName (start_line_of_range v.Range)
|
|
else
|
|
printfn "value %s at line %d does not make a critical tailcall" v.DisplayName (start_line_of_range v.Range)
|
|
if cenv.settings.reportTotalSizes then
|
|
printfn "value %s at line %d has total size %d" v.DisplayName (start_line_of_range v.Range) bodyinfo.TotalSize
|
|
if cenv.settings.reportFunctionSizes then
|
|
printfn "value %s at line %d has method size %d" v.DisplayName (start_line_of_range v.Range) bodyinfo.FunctionSize
|
|
if cenv.settings.reportHasEffect then
|
|
if bodyinfo.HasEffect then
|
|
printfn "function %s at line %d causes side effects or may not terminate" v.DisplayName (start_line_of_range v.Range)
|
|
else
|
|
printfn "function %s at line %d causes no side effects" v.DisplayName (start_line_of_range v.Range)
|
|
| _ ->
|
|
()
|
|
|
|
// can't inline any values with semi-recursive object references to self or base
|
|
let valu =
|
|
match basevopt with
|
|
| None -> CurriedLambdaValue (lambdaId,arities,bsize,expr',ety)
|
|
| _ -> UnknownValue
|
|
|
|
expr', { TotalSize=bsize + (if isTopLevel then methodDefnTotalSize else closureTotalSize); (* estimate size of new syntactic closure - expensive, in contrast to a method *)
|
|
FunctionSize=1;
|
|
HasEffect=false;
|
|
MightMakeCriticalTailcall = false;
|
|
Info= valu; }
|
|
| _ -> OptimizeExpr cenv env e
|
|
|
|
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Recursive calls that first try to make an expression "fit" the a shape
|
|
// where it is about to be consumed.
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeExprsThenReshapeAndConsiderSplits cenv env exprs =
|
|
match exprs with
|
|
| [] -> no_exprs
|
|
| _ -> OptimizeList (OptimizeExprThenReshapeAndConsiderSplit cenv env) exprs
|
|
|
|
and OptimizeExprsThenConsiderSplits cenv env exprs =
|
|
match exprs with
|
|
| [] -> no_exprs
|
|
| _ -> OptimizeList (OptimizeExprThenConsiderSplit cenv env) exprs
|
|
|
|
and OptimizeFlatExprsThenConsiderSplits cenv env (exprs:FlatExprs) =
|
|
if FlatList.isEmpty exprs then no_FlatExprs
|
|
else OptimizeFlatList (OptimizeExprThenConsiderSplit cenv env) exprs
|
|
|
|
and OptimizeExprThenReshapeAndConsiderSplit cenv env (shape,e) =
|
|
OptimizeExprThenConsiderSplit cenv env (ReshapeExpr cenv (shape,e))
|
|
|
|
and OptimizeDecisionTreeTargets cenv env m ty targets =
|
|
OptimizeList (OptimizeDecisionTreeTarget cenv env m ty) (Array.to_list targets)
|
|
|
|
and ReshapeExpr cenv (shape,e) =
|
|
match shape,e with
|
|
| TupleValue(subshapes), TExpr_val(vref,vFlags,m) ->
|
|
let tinst = dest_tuple_typ cenv.g (type_of_expr cenv.g e)
|
|
mk_tupled cenv.g m (List.mapi (fun i subshape -> ReshapeExpr cenv (subshape,mk_tuple_field_get(e,tinst,i,m))) (Array.to_list subshapes)) tinst
|
|
| _ ->
|
|
e
|
|
|
|
and OptimizeExprThenConsiderSplit cenv env e =
|
|
let e',einfo = OptimizeExpr cenv env e
|
|
(* ALWAYS consider splits for enormous sub terms here - otherwise we will create invalid .NET programs *)
|
|
ConsiderSplitToMethod true cenv.settings.veryBigExprSize cenv env (e',einfo)
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Decide whether to List.unzip a sub-expression into a new method
|
|
//-------------------------------------------------------------------------
|
|
|
|
and ComputeSplitToMethodCondition flag threshold cenv env (e,einfo) =
|
|
flag &&
|
|
// don't mess with taking guaranteed tailcalls if used with --no-tailcalls!
|
|
!Msilxlib.tailcall_implementation <> Ilxsettings.NoTailcalls &&
|
|
einfo.FunctionSize >= threshold &&
|
|
(let fvs = free_in_expr CollectLocals e
|
|
not fvs.UsesUnboundRethrow &&
|
|
// We can only split an expression out as a method if certain conditions are met.
|
|
// It can't use any protected or base calls
|
|
not fvs.UsesMethodLocalConstructs &&
|
|
fvs.FreeLocals |> Zset.for_all (fun v ->
|
|
// no direct-self-recursive refrences
|
|
not (vspec_map_mem v env.dontSplitVars) &&
|
|
(v.TopValInfo.IsSome ||
|
|
// All the free variables (apart from things with an arity, i.e. compiled as methods) should be normal, i.e. not base/this etc.
|
|
(v.BaseOrThisInfo = NormalVal &&
|
|
// None of them should be byrefs
|
|
not (is_byref_typ cenv.g v.Type) &&
|
|
// None of them should be local polymorphic constrained values
|
|
not (IsGenericValWithGenericContraints cenv.g v) &&
|
|
// None of them should be mutable
|
|
not v.IsMutable))))
|
|
|
|
and ConsiderSplitToMethod flag threshold cenv env (e,einfo) =
|
|
if ComputeSplitToMethodCondition flag threshold cenv env (e,einfo) then
|
|
let m = (range_of_expr e)
|
|
let uv,ue = mk_compgen_local m "unitVar" cenv.g.unit_ty
|
|
let ty = type_of_expr cenv.g e
|
|
let fv,fe = mk_compgen_local m (match env.latestBoundId with Some id -> id.idText^suffixForVariablesThatMayNotBeEliminated | None -> suffixForVariablesThatMayNotBeEliminated) (cenv.g.unit_ty --> ty)
|
|
mk_invisible_let m fv (mk_lambda m uv (e,ty))
|
|
(prim_mk_app (fe,(cenv.g.unit_ty --> ty)) [] [mk_unit cenv.g m] m),
|
|
{einfo with FunctionSize=callSize }
|
|
else
|
|
e,einfo
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a pattern matching expression
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeMatch cenv env (spMatch,exprm,dtree,targets,m, ty) =
|
|
if verboseOptimizations then dprintf "OptimizeMatch\n";
|
|
// REVIEW: consider collecting, merging and using information flowing through each line of the decision tree to each target
|
|
let dtree',dinfo = OptimizeDecisionTree cenv env m dtree
|
|
let targets',tinfos = OptimizeDecisionTreeTargets cenv env m ty targets
|
|
let tinfo = CombineValueInfosUnknown tinfos
|
|
let expr' = mk_and_optimize_match spMatch exprm m ty dtree' targets'
|
|
let einfo =
|
|
{ TotalSize = dinfo.TotalSize + tinfo.TotalSize;
|
|
FunctionSize = dinfo.FunctionSize + tinfo.FunctionSize;
|
|
HasEffect = dinfo.HasEffect || tinfo.HasEffect;
|
|
MightMakeCriticalTailcall=tinfo.MightMakeCriticalTailcall; // discard tailcall info from decision tree since it's not in tailcall position
|
|
Info= UnknownValue }
|
|
expr', einfo
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a target of a decision tree
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeDecisionTreeTarget cenv env m ty (TTarget(vs,e,spTarget)) =
|
|
if verboseOptimizations then dprintf "OptimizeDecisionTreeTarget\n";
|
|
(* REVIEW: this is where we should be using information collected for each target *)
|
|
let env = bind_internal_vspecs_to_unknown cenv vs env
|
|
let e',einfo = OptimizeExpr cenv env e
|
|
let e',einfo = ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (e',einfo)
|
|
let evalue' = AbstractExprInfoByVars m (FlatList.to_list vs,[]) einfo.Info
|
|
TTarget(vs,e',spTarget),
|
|
{ TotalSize=einfo.TotalSize;
|
|
FunctionSize=einfo.FunctionSize;
|
|
HasEffect=einfo.HasEffect;
|
|
MightMakeCriticalTailcall = einfo.MightMakeCriticalTailcall;
|
|
Info=evalue' }
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Optimize/analyze a decision tree
|
|
//-------------------------------------------------------------------------
|
|
|
|
and OptimizeDecisionTree cenv env m x =
|
|
match x with
|
|
| TDSuccess (es,n) ->
|
|
let es', einfos = OptimizeFlatExprsThenConsiderSplits cenv env es
|
|
TDSuccess(es',n),CombineFlatValueInfosUnknown einfos
|
|
| TDBind(bind,rest) ->
|
|
let (bind,binfo),envinner = OptimizeBinding cenv false env bind
|
|
let rest,rinfo = OptimizeDecisionTree cenv envinner m rest
|
|
|
|
if ValueIsUsedOrHasEffect cenv m (acc_free_in_dtree CollectLocals rest empty_freevars).FreeLocals (bind,binfo) then
|
|
|
|
let info = CombineValueInfosUnknown [rinfo;binfo]
|
|
// try to fold the let-binding into a single result expression
|
|
match rest with
|
|
| TDSuccess([e],n) ->
|
|
let e,adjust = TryEliminateLet cenv env bind e m
|
|
TDSuccess([e],n),info
|
|
| _ ->
|
|
TDBind(bind,rest),info
|
|
|
|
else
|
|
rest,rinfo
|
|
|
|
| TDSwitch (e,cases,dflt,m) ->
|
|
OptimizeSwitch cenv env (e,cases,dflt,m)
|
|
|
|
and TryOptimizeDecisionTreeTest cenv test vinfo =
|
|
match test,vinfo with
|
|
| TTest_unionconstr (c1,_), StripUnionCaseValue(c2,_) -> Some(cenv.g.ucref_eq c1 c2)
|
|
| TTest_array_length (n1,_), _ -> None
|
|
| TTest_const c1,StripConstValue(c2) -> if c1 = TConst_zero or c2 = TConst_zero then None else Some(c1=c2)
|
|
| TTest_isnull,StripConstValue(c2) -> Some(c2=TConst_zero)
|
|
| TTest_isinst (srcty1,tgty1), _ -> None
|
|
// These should not occur in optimization
|
|
| TTest_query (_,_,vrefOpt1,n1,apinfo1),_ -> None
|
|
| _ -> None
|
|
|
|
/// Optimize/analyze a switch construct from pattern matching
|
|
and OptimizeSwitch cenv env (e,cases,dflt,m) =
|
|
if verboseOptimizations then dprintf "OptimizeSwitch\n";
|
|
let e', einfo = OptimizeExpr cenv env e
|
|
|
|
let cases,dflt =
|
|
if cenv.settings.EliminateSwitch() && not einfo.HasEffect then
|
|
// Attempt to find a definite success, i.e. the first case where there is definite success
|
|
match (List.tryfind (function (TCase(d2,_)) when TryOptimizeDecisionTreeTest cenv d2 einfo.Info = Some(true) -> true | _ -> false) cases) with
|
|
| Some(TCase(_,case)) -> [],Some(case)
|
|
| _ ->
|
|
// Filter definite failures
|
|
cases |> List.filter (function (TCase(d2,_)) when TryOptimizeDecisionTreeTest cenv d2 einfo.Info = Some(false) -> false | _ -> true),
|
|
dflt
|
|
else
|
|
cases,dflt
|
|
// OK, see what we're left with and continue
|
|
match cases,dflt with
|
|
| [],Some case -> OptimizeDecisionTree cenv env m case
|
|
| _ -> OptimizeSwitchFallback cenv env (e', einfo, cases,dflt,m)
|
|
|
|
and OptimizeSwitchFallback cenv env (e', einfo, cases,dflt,m) =
|
|
let cases',cinfos = List.unzip (List.map (fun (TCase(discrim,e)) -> let e',einfo = OptimizeDecisionTree cenv env m e in TCase(discrim,e'),einfo) cases)
|
|
let dflt',dinfos = match dflt with None -> None,[] | Some df -> let df',einfo = OptimizeDecisionTree cenv env m df in Some df',[einfo]
|
|
let size = (List.length dinfos + List.length cinfos) * 2
|
|
let info = CombineValueInfosUnknown (einfo :: cinfos @ dinfos)
|
|
let info = { info with TotalSize = info.TotalSize + size; FunctionSize = info.FunctionSize + size; }
|
|
TDSwitch (e',cases',dflt',m),info
|
|
|
|
and OptimizeBinding cenv isRec env (TBind(v,e,spBind) as bind) =
|
|
try
|
|
if verboseOptimizations then dprintf "OptimizeBinding\n";
|
|
|
|
// The aim here is to stop method splitting for direct-self-tailcalls. We do more than that: if an expression
|
|
// occurs in the body of recursively defined values RVS, then we refuse to split
|
|
// any expression that contains a reference to any value in RVS.
|
|
// This doesn't prevent splitting for mutually recursive references. See FSharp 1.0 bug 2892.
|
|
let env =
|
|
if isRec then { env with dontSplitVars = vspec_map_add v () env.dontSplitVars }
|
|
else env
|
|
|
|
let repr',einfo =
|
|
let env = if v.IsCompilerGenerated && isSome env.latestBoundId then env else {env with latestBoundId=Some v.Id}
|
|
let cenv = if v.InlineInfo = PseudoValue then { cenv with optimizing=false} else cenv
|
|
if verboseOptimizations then dprintf "OptimizeBinding --> OptimizeLambdas\n";
|
|
let e',einfo = OptimizeLambdas (Some v) cenv env (InferArityOfExprBinding cenv.g v e) e v.Type
|
|
let size = local_var_size
|
|
e',{einfo with FunctionSize=einfo.FunctionSize+size; TotalSize = einfo.TotalSize+size}
|
|
|
|
// Trim out optimization information for large lambdas we'll never inline
|
|
// Trim out optimization information for expressions that call protected members
|
|
let rec cut ivalue =
|
|
match ivalue with
|
|
| CurriedLambdaValue (_, arities, size, body,_) ->
|
|
if size > (cenv.settings.lambdaInlineThreshold + arities + 2) then
|
|
if verboseOptimizations then dprintf "Discarding lambda for binding %s, size = %d, m = %a\n" v.MangledName size output_range (range_of_expr body);
|
|
UnknownValue (* trim large *)
|
|
else
|
|
let fvs = free_in_expr CollectLocals body
|
|
if fvs.UsesMethodLocalConstructs then
|
|
if verboseOptimizations then dprintf "Discarding lambda for binding %s because uses protected members, m = %a\n" v.MangledName output_range (range_of_expr body);
|
|
UnknownValue (* trim protected *)
|
|
else
|
|
ivalue
|
|
|
|
| ValValue(v,x) -> ValValue(v,cut x)
|
|
| ModuleValue _ -> UnknownValue
|
|
| TupleValue a -> TupleValue(Array.map cut a)
|
|
| RecdValue (tcref,a) -> RecdValue(tcref,Array.map cut a)
|
|
| UnionCaseValue (a,b) -> UnionCaseValue (a,Array.map cut b)
|
|
| UnknownValue | ConstValue _ | ConstExprValue _ -> ivalue
|
|
| SizeValue(_,a) -> MakeSizedValueInfo (cut a)
|
|
let einfo = if v.MustInline then einfo else {einfo with Info = cut einfo.Info }
|
|
let einfo =
|
|
if (not(v.MustInline ) && not (cenv.settings.KeepOptimizationValues())) ||
|
|
(v.InlineInfo = NeverInline) ||
|
|
// MarshalByRef methods may not be inlined
|
|
(match v.ActualParent with
|
|
| Parent tcref ->
|
|
// Check we can deref system_MarshalByRefObject_tcref. When compiling against the Silverlight mscorlib we can't
|
|
cenv.g.system_MarshalByRefObject_tcref.TryDeref.IsSome &&
|
|
// Check if this is a subtype of MarshalByRefObject
|
|
ExistsSameHeadTypeInHierarchy cenv.g cenv.amap v.Range (snd(generalize_tcref tcref)) cenv.g.system_MarshalByRefObject_typ
|
|
| ParentNone -> false) ||
|
|
|
|
// These values are given a special going-over by the optimizer and
|
|
// ilxgen.ml, hence treat them as if no-inline
|
|
(let nvref = mk_local_vref v
|
|
cenv.g.vref_eq nvref cenv.g.seq_vref ||
|
|
cenv.g.vref_eq nvref cenv.g.poly_eq_inner_vref ||
|
|
cenv.g.vref_eq nvref cenv.g.generic_comparison_inner_vref ||
|
|
cenv.g.vref_eq nvref cenv.g.generic_comparison_withc_inner_vref ||
|
|
cenv.g.vref_eq nvref cenv.g.generic_equality_inner_vref ||
|
|
cenv.g.vref_eq nvref cenv.g.generic_equality_withc_inner_vref ||
|
|
cenv.g.vref_eq nvref cenv.g.generic_hash_inner_vref)
|
|
then {einfo with Info=UnknownValue}
|
|
else einfo
|
|
if v.MustInline && IsPartialExprVal einfo.Info then
|
|
errorR(InternalError("the mustinline value '"^v.MangledName^"' was not inferred to have a known value",v.Range));
|
|
if verboseOptimizations then dprintf "val %s gets opt info %s\n" (showL(valL v)) (showL(exprValueInfoL einfo.Info));
|
|
|
|
let env = bind_internal_local_vspec cenv v (MkValInfo einfo v) env
|
|
(TBind(v,repr',spBind), einfo), env
|
|
with exn ->
|
|
errorRecovery exn v.Range;
|
|
raise ReportedError
|
|
|
|
and OptimizeBindings cenv isRec env xs = FlatList.mapfold (OptimizeBinding cenv isRec) env xs
|
|
|
|
and OptimizeModuleExpr cenv env x =
|
|
match x with
|
|
| TMTyped(mty,def,m) ->
|
|
// Optimize the module implementation
|
|
let (def,info),(env,bindInfosColl) = OptimizeModuleDef cenv (env,[]) def
|
|
let bindInfosColl = List.concat bindInfosColl
|
|
|
|
// Compute the elements truly hidden by the module signature.
|
|
// The hidden set here must contain NOT MORE THAN the set of values made inaccessible by
|
|
// the application of the signature. If it contains extra elements we'll accidentally eliminate
|
|
// bindings.
|
|
|
|
let (renaming, hidden) as rpi = mk_mdef_to_mtyp_remapping def mty
|
|
let def =
|
|
if not (cenv.settings.localOpt()) then def else
|
|
|
|
let fvs = free_in_mdef CollectLocals def
|
|
let dead =
|
|
bindInfosColl |> List.filter (fun (bind,binfo) ->
|
|
|
|
// Check the expression has no side effect, e.g. is a lambda expression (a function definition)
|
|
not (ValueIsUsedOrHasEffect cenv m fvs.FreeLocals (bind,binfo)) &&
|
|
|
|
// Check the thing is hidden by the signature (if any)
|
|
hidden.mhiVals.Contains(bind.Var) &&
|
|
|
|
// Check the thing is not compiled as a static field
|
|
not (IsCompiledAsStaticValue cenv.g bind.Var))
|
|
if verboseOptimizations then dead |> List.iter (fun (bind,_) -> dprintf "dead, hidden, buried, gone: %s\n" (showL (vspecAtBindL bind.Var)));
|
|
let deadSet = Zset.addList (dead |> List.map (fun (bind,_) -> bind.Var)) (Zset.empty val_spec_order)
|
|
|
|
// Eliminate dead private bindings from a module type by mutation. Note that the optimizer doesn't
|
|
// actually copy the entire term - it copies the expression portions of the term and leaves the
|
|
// value_spec and entity_specs in place. However this means that the value_specs and entity specs
|
|
// need to be updated when a change is made that affects them, e.g. when a binding is eliminated.
|
|
// We'd have to do similar tricks if the type of variable is changed (as happens in TLR, which also
|
|
// uses mutation), or if we eliminated a type constructor.
|
|
//
|
|
// It may be wise to move to a non-mutating implementation at some point here. Copying expressions is
|
|
// probably more costly than copying specs anyway.
|
|
let rec elim_mtyp (mtyp:ModuleOrNamespaceType) =
|
|
let mty =
|
|
new ModuleOrNamespaceType(kind=mtyp.ModuleOrNamespaceKind,
|
|
vals= (mtyp.AllValuesAndMembers |> NameMap.filterRange (Zset.mem_of deadSet >> not)),
|
|
entities= mtyp.AllEntities)
|
|
mtyp.ModuleAndNamespaceDefinitions |> List.iter (fun mspec -> elim_mspec mspec)
|
|
mty;
|
|
and elim_mspec (mspec:ModuleOrNamespace) =
|
|
let mtyp = elim_mtyp mspec.ModuleOrNamespaceType
|
|
mspec.Data.entity_modul_contents <- notlazy mtyp
|
|
|
|
let rec elim_mdef x =
|
|
match x with
|
|
| TMDefRec(tycons,vbinds,mbinds,m) ->
|
|
let vbinds = vbinds |> FlatList.filter (var_of_bind >> Zset.mem_of deadSet >> not)
|
|
let mbinds = mbinds |> List.map elim_mbind
|
|
TMDefRec(tycons,vbinds,mbinds,m)
|
|
| TMDefLet(bind,m) ->
|
|
if Zset.mem bind.Var deadSet then TMDefRec([],FlatList.empty,[],m) else x
|
|
| TMDefDo _ -> x
|
|
| TMDefs(defs) -> TMDefs(List.map elim_mdef defs)
|
|
| TMAbstract _ -> x
|
|
and elim_mbind (TMBind(mspec, d)) =
|
|
// Clean up the ModuleOrNamespaceType by mutation
|
|
elim_mspec mspec;
|
|
TMBind(mspec,elim_mdef d)
|
|
|
|
elim_mdef def
|
|
|
|
let info = AbstractAndRemapModulInfo "defs" cenv.g m rpi info
|
|
|
|
TMTyped(mty,def,m),info
|
|
|
|
and mk_var_bind (bind:Binding) info =
|
|
let v = bind.Var
|
|
(v.MangledName, (mk_local_vref v, info))
|
|
|
|
and OptimizeModuleDef cenv (env,bindInfosColl) x =
|
|
match x with
|
|
| TMDefRec(tycons,binds,mbinds,m) ->
|
|
let env = bind_internal_vspecs_to_unknown cenv (vars_of_Bindings binds) env
|
|
let bindInfos,env = OptimizeBindings cenv true env binds
|
|
let binds', binfos = FlatList.unzip bindInfos
|
|
let mbindInfos,(env,bindInfosColl) = OptimizeModuleBindings cenv (env,bindInfosColl) mbinds
|
|
let mbinds,minfos = List.unzip mbindInfos
|
|
|
|
(* REVIEW: Eliminate let bindings on the way back up *)
|
|
(TMDefRec(tycons,binds',mbinds,m),
|
|
notlazy { ValInfos=NameMap.of_FlatList (FlatList.map2 (fun bind binfo -> mk_var_bind bind (MkValInfo binfo bind.Var)) binds binfos);
|
|
ModuleOrNamespaceInfos = NameMap.of_list minfos}),
|
|
(env,(FlatList.to_list bindInfos :: bindInfosColl))
|
|
| TMAbstract(mexpr) ->
|
|
let mexpr,info = OptimizeModuleExpr cenv env mexpr
|
|
let env = bind_module_vspecs cenv info env
|
|
(TMAbstract(mexpr),info),(env,bindInfosColl)
|
|
| TMDefLet(bind,m) ->
|
|
let ((bind',binfo) as bindInfo),env = OptimizeBinding cenv false env bind
|
|
(* REVIEW: Eliminate unused let bindings from modules *)
|
|
(TMDefLet(bind',m),
|
|
notlazy { ValInfos=NameMap.of_list [mk_var_bind bind (MkValInfo binfo bind.Var)];
|
|
ModuleOrNamespaceInfos = NameMap.of_list []}),
|
|
(env ,([bindInfo]::bindInfosColl))
|
|
|
|
| TMDefDo(e,m) ->
|
|
let (e,einfo) = OptimizeExpr cenv env e
|
|
(TMDefDo(e,m),EmptyModuleInfo),
|
|
(env ,bindInfosColl)
|
|
| TMDefs(defs) ->
|
|
let (defs,info),(env,bindInfosColl) = OptimizeModuleDefs cenv (env,bindInfosColl) defs
|
|
(TMDefs(defs), info), (env,bindInfosColl)
|
|
|
|
and OptimizeModuleBindings cenv (env,bindInfosColl) xs = List.mapfold (OptimizeModuleBinding cenv) (env,bindInfosColl) xs
|
|
|
|
and OptimizeModuleBinding cenv (env,bindInfosColl) (TMBind(mspec, def)) =
|
|
let id = mspec.Id
|
|
let (def,info),(_,bindInfosColl) = OptimizeModuleDef cenv (env,bindInfosColl) def
|
|
let env = bind_module_vspecs cenv info env
|
|
(TMBind(mspec,def),(id.idText, info)),
|
|
(env,bindInfosColl)
|
|
|
|
and OptimizeModuleDefs cenv (env,bindInfosColl) defs =
|
|
if verboseOptimizations then dprintf "OptimizeModuleDefs\n";
|
|
let defs,(env,bindInfosColl) = List.mapfold (OptimizeModuleDef cenv) (env,bindInfosColl) defs
|
|
let defs,minfos = List.unzip defs
|
|
(defs,UnionModuleInfos minfos),(env,bindInfosColl)
|
|
|
|
and OptimizeImplFileInternal cenv env isIncrementalFragment (TImplFile(qname, pragmas, (TMTyped(mty,_,m) as mexpr))) =
|
|
let env,mexpr',minfo =
|
|
match mexpr with
|
|
// FSI: FSI compiles everything as if you're typing incrementally into one module
|
|
// This means the fragment is not truly a constrained module as later fragments will be typechecked
|
|
// against the internals of the module rather than the externals. Furthermore it would be wrong to apply
|
|
// optimizations that did lots of reorganizing stuff to the internals of a module should we ever implement that.
|
|
| TMTyped(mty,def,m) when isIncrementalFragment ->
|
|
let (def,minfo),(env,bindInfosColl) = OptimizeModuleDef cenv (env,[]) def
|
|
env, TMTyped(mty, def,m), minfo
|
|
| _ ->
|
|
let mexpr', minfo = OptimizeModuleExpr cenv env mexpr
|
|
let env = bind_module_vspecs cenv minfo env
|
|
env, mexpr', minfo
|
|
|
|
let hidden = mk_assembly_boundary_mhi mty
|
|
|
|
let minfo = AbstractLazyModulInfoByHiding true m hidden minfo
|
|
env, TImplFile(qname,pragmas,mexpr'), minfo
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Entry point
|
|
//-------------------------------------------------------------------------
|
|
|
|
let OptimizeImplFile(settings,ccu,tcGlobals,importMap,optEnv,isIncrementalFragment,mimpls) =
|
|
let cenv = mk_cenv settings ccu tcGlobals importMap
|
|
OptimizeImplFileInternal cenv optEnv isIncrementalFragment mimpls
|
|
|
|
|
|
//-------------------------------------------------------------------------
|
|
// Pickle to stable format for cross-module optimization data
|
|
//-------------------------------------------------------------------------
|
|
|
|
open Pickle
|
|
|
|
let rec p_expr_info x st =
|
|
match x with
|
|
| ConstValue (c,ty) -> p_byte 0 st; p_tup2 p_const p_typ (c,ty) st
|
|
| UnknownValue -> p_byte 1 st
|
|
| ValValue (a,b) -> p_byte 2 st; p_tup2 (p_vref "optval") p_expr_info (a,b) st
|
|
| ModuleValue a -> p_byte 3 st; p_submodul_info a st
|
|
| TupleValue a -> p_byte 4 st; (p_array p_expr_info) a st
|
|
| UnionCaseValue (a,b) -> p_byte 5 st; p_tup2 p_ucref (p_array p_expr_info) (a,b) st
|
|
| CurriedLambdaValue (_,b,c,d,e) -> p_byte 6 st; p_tup4 p_int p_int p_expr p_typ (b,c,d,e) st
|
|
| ConstExprValue (a,b) -> p_byte 7 st; p_tup2 p_int p_expr (a,b) st
|
|
| RecdValue (tcref,a) -> p_byte 10 st; p_tup2 (p_tcref "opt data") (p_array p_expr_info) (tcref,a) st
|
|
| SizeValue (adepth,a) -> p_expr_info a st
|
|
|
|
and p_val_info (v:ValInfo) st =
|
|
p_tup2 p_expr_info p_bool (v.ValExprInfo, v.ValMakesNoCriticalTailcalls) st
|
|
|
|
and p_submodul_info x st =
|
|
p_tup2 (p_namemap (p_tup2 (p_vref "opttab") p_val_info)) (p_namemap p_lazy_submodul_info) (x.ValInfos, x.ModuleOrNamespaceInfos) st
|
|
|
|
and p_lazy_submodul_info x st =
|
|
p_lazy p_submodul_info x st
|
|
|
|
let rec u_expr_info st =
|
|
let rec u_expr_info st =
|
|
let tag = u_byte st
|
|
match tag with
|
|
| 0 -> u_tup2 u_const u_typ st |> (fun (c,ty) -> ConstValue(c,ty))
|
|
| 1 -> UnknownValue
|
|
| 2 -> u_tup2 u_vref u_expr_info st |> (fun (a,b) -> ValValue (a,b))
|
|
| 3 -> u_submodul_info st |> (fun a -> ModuleValue a)
|
|
| 4 -> u_array u_expr_info st |> (fun a -> TupleValue a)
|
|
| 5 -> u_tup2 u_ucref (u_array u_expr_info) st |> (fun (a,b) -> UnionCaseValue (a,b))
|
|
| 6 -> u_tup4 u_int u_int u_expr u_typ st |> (fun (b,c,d,e) -> CurriedLambdaValue (new_uniq(),b,c,d,e))
|
|
| 7 -> u_tup2 u_int u_expr st |> (fun (a,b) -> ConstExprValue (a,b))
|
|
| 10 -> u_tup2 u_tcref (u_array u_expr_info) st |> (fun (a,b) -> RecdValue (a,b))
|
|
| _ -> failwith "u_expr_info"
|
|
MakeSizedValueInfo (u_expr_info st) (* calc size of unpicked ExprValueInfo *)
|
|
|
|
and u_val_info st =
|
|
let a,b = u_tup2 u_expr_info u_bool st
|
|
{ ValExprInfo=a; ValMakesNoCriticalTailcalls = b }
|
|
|
|
and u_submodul_info st =
|
|
let a,b = u_tup2 (u_namemap (u_tup2 u_vref u_val_info)) (u_namemap u_lazy_submodul_info) st
|
|
{ ValInfos=a; ModuleOrNamespaceInfos=b}
|
|
|
|
and u_lazy_submodul_info st = u_lazy u_submodul_info st
|
|
|
|
let p_lazy_modul_info info st = p_lazy_submodul_info info st
|
|
let u_lazy_modul_info st = u_lazy_submodul_info st
|
|
|