Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Cleanup Optimizer #1519

Merged
merged 9 commits into from
Sep 20, 2016
Merged

Cleanup Optimizer #1519

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
b0b900a
Cleanup Optimizer
forki Sep 5, 2016
5f03312
We don't need to check the lenght here
forki Sep 5, 2016
13f8472
Don't convert list to array multiple times
forki Sep 5, 2016
e87c158
Only fold the Flatlist
forki Sep 5, 2016
f0cc652
Optimize FlatList away
forki Sep 5, 2016
12d1412
Revert code duplication
forki Sep 5, 2016
7647050
match => if
forki Sep 5, 2016
29251f4
cleanup
forki Sep 6, 2016
5f4209f
DevirtualizeApplication doesn't need optimized Expression
forki Sep 6, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions src/absil/illib.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
64 changes: 32 additions & 32 deletions src/fsharp/FlatList.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -198,38 +198,38 @@ type internal FlatList<'T> ='T list
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
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<int>) = 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<int>) = 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
Expand Down
124 changes: 66 additions & 58 deletions src/fsharp/Optimizer.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -2032,16 +2036,15 @@ 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
// REVIEW: graph analysis to determine which items are unused
// 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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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,_,_) ->
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@forki, I actually prefer the when clause on this pattern match it eliminates the duplication.

Does that make sense?

Kevin

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

yeah but then you pattern match twice

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
Expand All @@ -2633,25 +2637,25 @@ 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

| _ ->
// 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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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))
Expand All @@ -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

Expand Down Expand Up @@ -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
| _ ->
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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) ->
Expand Down