diff --git a/src/absil/illib.fs b/src/absil/illib.fs index abb1c3090ad..91b44acd2b7 100644 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -780,6 +780,7 @@ module NameMap = let exists f m = Map.foldBack (fun x y sofar -> sofar || f x y) m false let ofKeyedList f l = List.foldBack (fun x acc -> Map.add (f x) x acc) l Map.empty let ofList l : NameMap<'T> = Map.ofList l + let ofSeq l : NameMap<'T> = Map.ofSeq l let ofFlatList (l:FlatList<_>) : NameMap<'T> = FlatList.toMap l let toList (l: NameMap<'T>) = Map.toList l let layer (m1 : NameMap<'T>) m2 = Map.foldBack Map.add m1 m2 diff --git a/src/fsharp/FlatList.fs b/src/fsharp/FlatList.fs index ba9c8af6ab6..66e0f056b7c 100644 --- a/src/fsharp/FlatList.fs +++ b/src/fsharp/FlatList.fs @@ -198,38 +198,38 @@ type internal FlatList<'T> ='T list [] module internal FlatList = let empty<'T> : 'T list = [] - let collect (f: 'T -> FlatList<'T>) (x:FlatList<_>) = List.collect f x - let exists f (x:FlatList<_>) = List.exists f x - let filter f (x:FlatList<_>) = List.filter f x - let fold f acc (x:FlatList<_>) = List.fold f acc x - let fold2 f acc (x:FlatList<_>) (y:FlatList<_>) = List.fold2 f acc x y - let foldBack f (x:FlatList<_>) acc = List.foldBack f x acc - let foldBack2 f (x:FlatList<_>) (y:FlatList<_>) acc = List.foldBack2 f x y acc - let map2 f (x:FlatList<_>) (y:FlatList<_>) = List.map2 f x y - let forall f (x:FlatList<_>) = List.forall f x - let forall2 f (x1:FlatList<_>) (x2:FlatList<_>) = List.forall2 f x1 x2 - let iter2 f (x1:FlatList<_>) (x2:FlatList<_>) = List.iter2 f x1 x2 - let partition f (x:FlatList<_>) = List.partition f x - let (* inline *) sum (x:FlatList) = List.sum x - let (* inline *) sumBy (f: 'T -> int) (x:FlatList<'T>) = List.sumBy f x - let unzip (x:FlatList<_>) = List.unzip x - let physicalEquality (x:FlatList<_>) (y:FlatList<_>) = (LanguagePrimitives.PhysicalEquality x y) - let tryFind f (x:FlatList<_>) = List.tryFind f x - let concat (x:FlatList<_>) = List.concat x - let isEmpty (x:FlatList<_>) = List.isEmpty x - let one(x) = [x] - let toMap (x:FlatList<_>) = Map.ofList x - let length (x:FlatList<_>) = List.length x - let map f (x:FlatList<_>) = List.map f x - let mapi f (x:FlatList<_>) = List.mapi f x - let iter f (x:FlatList<_>) = List.iter f x - let iteri f (x:FlatList<_>) = List.iteri f x - let toList (x:FlatList<_>) = x - let ofSeq (x:seq<_>) = List.ofSeq x - let append(l1 : FlatList<'T>) (l2 : FlatList<'T>) = List.append l1 l2 - let ofList(l) = l - let init n f = List.init n f - let zip (x:FlatList<_>) (y:FlatList<_>) = List.zip x y + let inline collect (f: 'T -> FlatList<'T>) (x:FlatList<_>) = List.collect f x + let inline exists f (x:FlatList<_>) = List.exists f x + let inline filter f (x:FlatList<_>) = List.filter f x + let inline fold f acc (x:FlatList<_>) = List.fold f acc x + let inline fold2 f acc (x:FlatList<_>) (y:FlatList<_>) = List.fold2 f acc x y + let inline foldBack f (x:FlatList<_>) acc = List.foldBack f x acc + let inline foldBack2 f (x:FlatList<_>) (y:FlatList<_>) acc = List.foldBack2 f x y acc + let inline map2 f (x:FlatList<_>) (y:FlatList<_>) = List.map2 f x y + let inline forall f (x:FlatList<_>) = List.forall f x + let inline forall2 f (x1:FlatList<_>) (x2:FlatList<_>) = List.forall2 f x1 x2 + let inline iter2 f (x1:FlatList<_>) (x2:FlatList<_>) = List.iter2 f x1 x2 + let inline partition f (x:FlatList<_>) = List.partition f x + let inline sum (x:FlatList) = List.sum x + let inline sumBy (f: 'T -> int) (x:FlatList<'T>) = List.sumBy f x + let inline unzip (x:FlatList<_>) = List.unzip x + let inline physicalEquality (x:FlatList<_>) (y:FlatList<_>) = (LanguagePrimitives.PhysicalEquality x y) + let inline tryFind f (x:FlatList<_>) = List.tryFind f x + let inline concat (x:FlatList<_>) = List.concat x + let inline isEmpty (x:FlatList<_>) = List.isEmpty x + let inline one(x) = [x] + let inline toMap (x:FlatList<_>) = Map.ofList x + let inline length (x:FlatList<_>) = List.length x + let inline map f (x:FlatList<_>) = List.map f x + let inline mapi f (x:FlatList<_>) = List.mapi f x + let inline iter f (x:FlatList<_>) = List.iter f x + let inline iteri f (x:FlatList<_>) = List.iteri f x + let inline toList (x:FlatList<_>) = x + let inline ofSeq (x:seq<_>) = List.ofSeq x + let inline append(l1 : FlatList<'T>) (l2 : FlatList<'T>) = List.append l1 l2 + let inline ofList(l) = l + let inline init n f = List.init n f + let inline zip (x:FlatList<_>) (y:FlatList<_>) = List.zip x y #endif #if FLAT_LIST_AS_ARRAY diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 9bb4ba0ecde..b547523882f 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -467,18 +467,20 @@ let rec BindValsInModuleOrNamespace cenv (mval:LazyModuleInfo) env = let env = (env, mval.ValInfos.Entries) ||> Seq.fold (fun env (v:ValRef, vval) -> BindExternalLocalVal cenv v.Deref vval env) env -let BindInternalValToUnknown cenv v env = +let inline BindInternalValToUnknown cenv v env = #if CHECKED BindInternalLocalVal cenv v UnknownValue env #else - ignore (cenv,v) + ignore cenv + ignore v env #endif -let BindInternalValsToUnknown cenv vs env = +let inline BindInternalValsToUnknown cenv vs env = #if CHECKED List.foldBack (BindInternalValToUnknown cenv) vs env #else - ignore (cenv,vs) + ignore cenv + ignore vs env #endif @@ -568,9 +570,11 @@ let GetInfoForNonLocalVal cenv env (vref:ValRef) = let GetInfoForVal cenv env m (vref:ValRef) = let res = - match vref.IsLocalRef with - | true -> GetInfoForLocalValue cenv env vref.binding m - | false -> GetInfoForNonLocalVal cenv env vref + if vref.IsLocalRef then + GetInfoForLocalValue cenv env vref.binding m + else + GetInfoForNonLocalVal cenv env vref + check (* "its stored value was incomplete" m *) vref res |> ignore res @@ -2032,7 +2036,7 @@ and OptimizeFastIntegerForLoop cenv env (spStart,v,e1,dir,e2,e3,m) = //------------------------------------------------------------------------- and OptimizeLetRec cenv env (binds,bodyExpr,m) = - let vs = binds |> FlatList.map (fun v -> v.Var) in + let vs = binds |> FlatList.map (fun v -> v.Var) let env = BindInternalValsToUnknown cenv vs env let binds',env = OptimizeBindings cenv true env binds let bodyExpr',einfo = OptimizeExpr cenv env bodyExpr @@ -2040,8 +2044,7 @@ and OptimizeLetRec cenv env (binds,bodyExpr,m) = // Eliminate any unused bindings, as in let case let binds'',bindinfos = let fvs0 = freeInExpr CollectLocals bodyExpr' - let fvsN = FlatList.map (fst >> freeInBindingRhs CollectLocals) binds' - let fvs = FlatList.fold unionFreeVars fvs0 fvsN + let fvs = FlatList.fold (fun acc x -> unionFreeVars acc (fst x |> freeInBindingRhs CollectLocals)) fvs0 binds' SplitValuesByIsUsedOrHasEffect cenv (fun () -> fvs.FreeLocals) binds' // Trim out any optimization info that involves escaping values let evalue' = AbstractExprInfoByVars (FlatList.toList vs,[]) einfo.Info @@ -2206,7 +2209,7 @@ and TryOptimizeVal cenv env (mustInline,valInfoForVal,m) = | SizeValue (_,detail) -> TryOptimizeVal cenv env (mustInline,detail,m) | ValValue (v',detail) -> // Inline values bound to other values immediately - match TryOptimizeVal cenv env (mustInline,detail,m) with + 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 @@ -2300,9 +2303,9 @@ and TakeAddressOfStructArgumentIfNeeded cenv (vref:ValRef) ty args m = wrap, (objArgAddress::rest) | _ -> // no wrapper, args stay the same - (fun x -> x), args + id, args else - (fun x -> x), args + id, args and DevirtualizeApplication cenv env (vref:ValRef) ty tyargs args m = let wrap,args = TakeAddressOfStructArgumentIfNeeded cenv vref ty args m @@ -2579,50 +2582,51 @@ and TryInlineApplication cenv env (_f0',finfo) (tyargs: TType list,args: Expr li //------------------------------------------------------------------------- and OptimizeApplication cenv env (f0,f0ty,tyargs,args,m) = - let f0',finfo = OptimizeExpr cenv env f0 // trying to devirtualize match TryDevirtualizeApplication cenv env (f0,tyargs,args,m) with | Some res -> // devirtualized res | None -> - - match TryInlineApplication cenv env (f0',finfo) (tyargs,args,m) with + let newf0,finfo = OptimizeExpr cenv env f0 + match TryInlineApplication cenv env (newf0,finfo) (tyargs,args,m) with | Some res -> // inlined res | None -> let shapes = - match f0' with - | Expr.Val(vref,_,_) when Option.isSome vref.ValReprInfo -> - let (ValReprInfo(_kinds,detupArgsL,_)) = Option.get vref.ValReprInfo - 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.ofList (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) + match newf0 with + | Expr.Val(vref,_,_) -> + match vref.ValReprInfo with + | Some(ValReprInfo(_,detupArgsL,_)) -> + 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.ofList (List.map (fun _ -> UnknownValue) detupArgs))) + List.zip (detupArgsShapesL @ List.replicate (nargs - nShapes) UnknownValue) args + | _ -> args |> List.map (fun arg -> UnknownValue,arg) + | _ -> args |> List.map (fun arg -> UnknownValue,arg) + + let newArgs,arginfos = OptimizeExprsThenReshapeAndConsiderSplits cenv env shapes // beta reducing - let expr' = MakeApplicationAndBetaReduce cenv.g (f0',f0ty, [tyargs],args',m) + let newExpr = MakeApplicationAndBetaReduce cenv.g (newf0,f0ty, [tyargs],newArgs,m) - match f0', expr' with + match newf0, newExpr with | (Expr.Lambda _ | Expr.TyLambda _), Expr.Let _ -> // we beta-reduced, hence reoptimize - OptimizeExpr cenv env expr' + OptimizeExpr cenv env newExpr | _ -> // regular // Determine if this application is a critical tailcall let mayBeCriticalTailcall = - match f0' with + match newf0 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 @@ -2633,13 +2637,13 @@ and OptimizeApplication cenv env (f0,f0ty,tyargs,args,m) = (let valInfoForVal = GetInfoForVal cenv env m vref in valInfoForVal.ValMakesNoCriticalTailcalls) || (match env.functionVal with | None -> false | Some (v,_) -> valEq vref.Deref v) if doesNotMakeCriticalTailcall then - let numArgs = otherArgs.Length + args'.Length + let numArgs = otherArgs.Length + newArgs.Length match vref.ValReprInfo 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 + | None -> true // over-application 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 @@ -2647,11 +2651,11 @@ and OptimizeApplication cenv env (f0,f0ty,tyargs,args,m) = // 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' } + newExpr, { TotalSize=finfo.TotalSize + AddTotalSizes arginfos + FunctionSize=finfo.FunctionSize + AddFunctionSizes arginfos + HasEffect=true + MightMakeCriticalTailcall = mayBeCriticalTailcall + Info=ValueOfExpr newExpr } //------------------------------------------------------------------------- // Optimize/analyze a lambda expression @@ -2661,7 +2665,6 @@ and OptimizeLambdas (vspec: Val option) cenv env topValInfo e ety = match e with | Expr.Lambda (lambdaId,_,_,_,_,m,_) | Expr.TyLambda(lambdaId,_,_,m,_) -> - let isTopLevel = Option.isSome vspec && vspec.Value.IsCompiledAsTopLevel let tps,ctorThisValOpt,baseValOpt,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.foldBack (BindInternalValToUnknown cenv) ctorThisValOpt env @@ -2709,13 +2712,18 @@ and OptimizeLambdas (vspec: Val option) cenv env topValInfo e ety = | Some baseVal -> let fvs = freeInExpr CollectLocals body' if fvs.UsesMethodLocalConstructs || fvs.FreeLocals.Contains baseVal then - UnknownValue + UnknownValue else let expr2 = mkMemberLambdas m tps ctorThisValOpt None vsl (body',bodyty) CurriedLambdaValue (lambdaId,arities,bsize,expr2,ety) - expr', { TotalSize=bsize + (if isTopLevel then methodDefnTotalSize else closureTotalSize) (* estimate size of new syntactic closure - expensive, in contrast to a method *) + let estimatedSize = + match vspec with + | Some v when v.IsCompiledAsTopLevel -> methodDefnTotalSize + | _ -> closureTotalSize + + expr', { TotalSize=bsize + estimatedSize (* estimate size of new syntactic closure - expensive, in contrast to a method *) FunctionSize=1 HasEffect=false MightMakeCriticalTailcall = false @@ -2739,9 +2747,10 @@ and OptimizeExprsThenConsiderSplits cenv env exprs = | [] -> NoExprs | _ -> OptimizeList (OptimizeExprThenConsiderSplit cenv env) exprs -and OptimizeFlatExprsThenConsiderSplits cenv env (exprs:FlatExprs) = - if FlatList.isEmpty exprs then NoFlatExprs - else OptimizeFlatList (OptimizeExprThenConsiderSplit cenv env) exprs +and OptimizeFlatExprsThenConsiderSplits cenv env exprs = + match exprs with + | [] -> NoFlatExprs + | _ -> OptimizeFlatList (OptimizeExprThenConsiderSplit cenv env) exprs and OptimizeExprThenReshapeAndConsiderSplit cenv env (shape,e) = OptimizeExprThenConsiderSplit cenv env (ReshapeExpr cenv (shape,e)) @@ -2753,7 +2762,8 @@ and ReshapeExpr cenv (shape,e) = match shape,e with | TupleValue(subshapes), Expr.Val(_vref,_vFlags,m) -> let tinst = destRefTupleTy cenv.g (tyOfExpr cenv.g e) - mkRefTupled cenv.g m (List.mapi (fun i subshape -> ReshapeExpr cenv (subshape,mkTupleFieldGet cenv.g (tupInfoRef,e,tinst,i,m))) (Array.toList subshapes)) tinst + let subshapes = Array.toList subshapes + mkRefTupled cenv.g m (List.mapi (fun i subshape -> ReshapeExpr cenv (subshape,mkTupleFieldGet cenv.g (tupInfoRef,e,tinst,i,m))) subshapes) tinst | _ -> e @@ -2868,8 +2878,7 @@ and OptimizeDecisionTree cenv env m x = let info = CombineValueInfosUnknown [rinfo;binfo] // try to fold the let-binding into a single result expression match rest with - | TDSuccess(es,n) when es.Length = 1 -> - let e = es.[0] + | TDSuccess([e],n) -> let e,_adjust = TryEliminateLet cenv env bind e m TDSuccess(FlatList.one e,n),info | _ -> @@ -3072,7 +3081,7 @@ and OptimizeModuleExpr cenv env x = new ModuleOrNamespaceType(kind=mtyp.ModuleOrNamespaceKind, vals= (mtyp.AllValsAndMembers |> QueueList.filter (Zset.memberOf deadSet >> not)), entities= mtyp.AllEntities) - mtyp.ModuleAndNamespaceDefinitions |> List.iter (fun mspec -> elimModSpec mspec) + mtyp.ModuleAndNamespaceDefinitions |> List.iter elimModSpec mty and elimModSpec (mspec:ModuleOrNamespace) = let mtyp = elimModTy mspec.ModuleOrNamespaceType @@ -3116,13 +3125,12 @@ and OptimizeModuleDef cenv (env,bindInfosColl) x = let binds = minfos |> List.choose (function Choice1Of2 (x,_) -> Some x | _ -> None) let binfos = minfos |> List.choose (function Choice1Of2 (_,x) -> Some x | _ -> None) let minfos = minfos |> List.choose (function Choice2Of2 x -> Some x | _ -> None) - - (* REVIEW: Eliminate let bindings on the way back up *) + (* REVIEW: Eliminate let bindings on the way back up *) (TMDefRec(isRec,tycons,mbinds,m), - notlazy { ValInfos= ValInfos(FlatList.map2 (fun bind binfo -> mkValBind bind (mkValInfo binfo bind.Var)) binds binfos) + notlazy { ValInfos = ValInfos(FlatList.map2 (fun bind binfo -> mkValBind bind (mkValInfo binfo bind.Var)) binds binfos) ModuleOrNamespaceInfos = NameMap.ofList minfos}), - (env,bindInfosColl) + (env,bindInfosColl) | TMAbstract(mexpr) -> let mexpr,info = OptimizeModuleExpr cenv env mexpr let env = BindValsInModuleOrNamespace cenv info env @@ -3132,7 +3140,7 @@ and OptimizeModuleDef cenv (env,bindInfosColl) x = (* REVIEW: Eliminate unused let bindings from modules *) (TMDefLet(bind',m), notlazy { ValInfos=ValInfos [mkValBind bind (mkValInfo binfo bind.Var)] - ModuleOrNamespaceInfos = NameMap.ofList []}), + ModuleOrNamespaceInfos = NameMap.empty }), (env ,([bindInfo]::bindInfosColl)) | TMDefDo(e,m) ->