Skip to content

Commit

Permalink
process more large expressions more systematically (#6294)
Browse files Browse the repository at this point in the history 
* process large expressions systematically

* add test cases

* update tests

* Make .NET Desktop fsi.exe 32-bit again and make Desktop fsiAnyCpu.exe (64-bit) the default to launch in VS #6223

* make fsc.exe 32-bit for compat

* make fsc.exe 32-bit for compat

* fix build

* fix build

* ramp up max testing

* correct optimization of linear matches

* improve diagnostics

* fix tests

* tests only on .NET Framework for now

* fix determinism
  • Loading branch information
@dsyme
dsyme authored Mar 2, 2019
1 parent 09a9870 commit 166ec38
Show file tree
Hide file tree
Showing 22 changed files with 13,237 additions and 410 deletions.
32 changes: 17 additions & 15 deletions src/fsharp/DetupleArgs.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -256,42 +256,44 @@ module GlobalUsageAnalysis =
let foldLocalVal f z (vref: ValRef) =
if valRefInThisAssembly g.compilingFslib vref then f z vref.Deref
else z
let exprUsageIntercept exprF z expr =

let exprUsageIntercept exprF noInterceptF z origExpr =

let rec recognise context expr =
match expr with
| Expr.Val (v, _, _) ->
match expr with
| Expr.Val (v, _, _) ->
// YES: count free occurrence
let z = foldLocalVal (fun z v -> logUse v (context, [], []) z) z v
Some z
| TyappAndApp(f, _, tys, args, _) ->
foldLocalVal (fun z v -> logUse v (context, [], []) z) z v

| TyappAndApp(f, _, tys, args, _) ->
match f with
| Expr.Val (fOrig, _, _) ->
// app where function is val
// YES: count instance/app (app when have term args), and then
// collect from args (have intercepted this node)
let collect z f = logUse f (context, tys, args) z
let z = foldLocalVal collect z fOrig
let z = List.fold exprF z args
Some z
List.fold exprF z args
| _ ->
// NO: app but function is not val
None
noInterceptF z origExpr

| Expr.Op(TOp.TupleFieldGet (tupInfo, n), ts, [x], _) when not (evalTupInfoIsStruct tupInfo) ->
let context = TupleGet (n, ts) :: context
recognise context x

// lambdas end top-level status
| Expr.Lambda(_id, _ctorThisValOpt, _baseValOpt, _vs, body, _, _) ->
let z = foldUnderLambda exprF z body
Some z
foldUnderLambda exprF z body

| Expr.TyLambda(_id, _tps, body, _, _) ->
let z = foldUnderLambda exprF z body
Some z
foldUnderLambda exprF z body

| _ ->
None // NO: no intercept
noInterceptF z origExpr

let context = []
recognise context expr
recognise context origExpr

let targetIntercept exprF z = function TTarget(_argvs, body, _) -> Some (foldUnderLambda exprF z body)
let tmethodIntercept exprF z = function TObjExprMethod(_, _, _, _, e, _m) -> Some (foldUnderLambda exprF z e)
Expand Down
59 changes: 47 additions & 12 deletions src/fsharp/FindUnsolved.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,46 +38,65 @@ let rec accExpr (cenv:cenv) (env:env) expr =
| Expr.Sequential (e1,e2,_,_,_) ->
accExpr cenv env e1
accExpr cenv env e2

| Expr.Let (bind,body,_,_) ->
accBind cenv env bind
accExpr cenv env body

| Expr.Const (_,_,ty) ->
accTy cenv env ty

| Expr.Val (_v,_vFlags,_m) -> ()

| Expr.Quote(ast,_,_,_m,ty) ->
accExpr cenv env ast
accTy cenv env ty

| Expr.Obj (_,ty,basev,basecall,overrides,iimpls,_m) ->
accTy cenv env ty
accExpr cenv env basecall
accMethods cenv env basev overrides
accIntfImpls cenv env basev iimpls

| LinearOpExpr (_op, tyargs, argsHead, argLast, _m) ->
// Note, LinearOpExpr doesn't include any of the "special" cases for accOp
accTypeInst cenv env tyargs
accExprs cenv env argsHead
// tailcall
accExpr cenv env argLast

| Expr.Op (c,tyargs,args,m) ->
accOp cenv env (c,tyargs,args,m)

| Expr.App(f,fty,tyargs,argsl,_m) ->
accTy cenv env fty
accTypeInst cenv env tyargs
accExpr cenv env f
accExprs cenv env argsl

| Expr.Lambda(_,_ctorThisValOpt,_baseValOpt,argvs,_body,m,rty) ->
let topValInfo = ValReprInfo ([],[argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)],ValReprInfo.unnamedRetVal)
let ty = mkMultiLambdaTy m argvs rty
accLambdas cenv env topValInfo expr ty

| Expr.TyLambda(_,tps,_body,_m,rty) ->
let topValInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps,[],ValReprInfo.unnamedRetVal)
accTy cenv env rty
let ty = mkForallTyIfNeeded tps rty
accLambdas cenv env topValInfo expr ty

| Expr.TyChoose(_tps,e1,_m) ->
accExpr cenv env e1

| Expr.Match(_,_exprm,dtree,targets,m,ty) ->
accTy cenv env ty
accDTree cenv env dtree
accTargets cenv env m ty targets

| Expr.LetRec (binds,e,_m,_) ->
accBinds cenv env binds
accExpr cenv env e

| Expr.StaticOptimization (constraints,e2,e3,_m) ->
accExpr cenv env e2
accExpr cenv env e3
Expand All @@ -87,14 +106,19 @@ let rec accExpr (cenv:cenv) (env:env) expr =
accTy cenv env ty2
| TTyconIsStruct(ty1) ->
accTy cenv env ty1)

| Expr.Link _eref -> failwith "Unexpected reclink"

and accMethods cenv env baseValOpt l = List.iter (accMethod cenv env baseValOpt) l
and accMethods cenv env baseValOpt l =
List.iter (accMethod cenv env baseValOpt) l

and accMethod cenv env _baseValOpt (TObjExprMethod(_slotsig,_attribs,_tps,vs,e,_m)) =
vs |> List.iterSquared (accVal cenv env)
accExpr cenv env e

and accIntfImpls cenv env baseValOpt l = List.iter (accIntfImpl cenv env baseValOpt) l
and accIntfImpls cenv env baseValOpt l =
List.iter (accIntfImpl cenv env baseValOpt) l

and accIntfImpl cenv env baseValOpt (ty,overrides) =
accTy cenv env ty
accMethods cenv env baseValOpt overrides
Expand Down Expand Up @@ -132,11 +156,14 @@ and accLambdas cenv env topValInfo e ety =
| _ ->
accExpr cenv env e

and accExprs cenv env exprs = exprs |> List.iter (accExpr cenv env)
and accExprs cenv env exprs =
exprs |> List.iter (accExpr cenv env)

and accTargets cenv env m ty targets = Array.iter (accTarget cenv env m ty) targets
and accTargets cenv env m ty targets =
Array.iter (accTarget cenv env m ty) targets

and accTarget cenv env _m _ty (TTarget(_vs,e,_)) = accExpr cenv env e
and accTarget cenv env _m _ty (TTarget(_vs,e,_)) =
accExpr cenv env e

and accDTree cenv env x =
match x with
Expand Down Expand Up @@ -169,7 +196,8 @@ and accAttrib cenv env (Attrib(_,_k,args,props,_,_,_m)) =
accExpr cenv env expr2
accTy cenv env ty)

and accAttribs cenv env attribs = List.iter (accAttrib cenv env) attribs
and accAttribs cenv env attribs =
List.iter (accAttrib cenv env) attribs

and accValReprInfo cenv env (ValReprInfo(_,args,ret)) =
args |> List.iterSquared (accArgReprInfo cenv env)
Expand All @@ -188,7 +216,8 @@ and accBind cenv env (bind:Binding) =
let topValInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData
accLambdas cenv env topValInfo bind.Expr bind.Var.Type

and accBinds cenv env xs = xs |> List.iter (accBind cenv env)
and accBinds cenv env xs =
xs |> List.iter (accBind cenv env)

let accTyconRecdField cenv env _tycon (rfield:RecdField) =
accAttribs cenv env rfield.PropertyAttribs
Expand All @@ -203,13 +232,15 @@ let accTycon cenv env (tycon:Tycon) =
accAttribs cenv env uc.Attribs
uc.RecdFieldsArray |> Array.iter (accTyconRecdField cenv env tycon))

let accTycons cenv env tycons = List.iter (accTycon cenv env) tycons
let accTycons cenv env tycons =
List.iter (accTycon cenv env) tycons

let rec accModuleOrNamespaceExpr cenv env x =
match x with
| ModuleOrNamespaceExprWithSig(_mty, def, _m) -> accModuleOrNamespaceDef cenv env def

and accModuleOrNamespaceDefs cenv env x = List.iter (accModuleOrNamespaceDef cenv env) x
and accModuleOrNamespaceDefs cenv env x =
List.iter (accModuleOrNamespaceDef cenv env) x

and accModuleOrNamespaceDef cenv env x =
match x with
Expand All @@ -221,12 +252,16 @@ and accModuleOrNamespaceDef cenv env x =
| TMAbstract(def) -> accModuleOrNamespaceExpr cenv env def
| TMDefs(defs) -> accModuleOrNamespaceDefs cenv env defs

and accModuleOrNamespaceBinds cenv env xs = List.iter (accModuleOrNamespaceBind cenv env) xs
and accModuleOrNamespaceBinds cenv env xs =
List.iter (accModuleOrNamespaceBind cenv env) xs

and accModuleOrNamespaceBind cenv env x =
match x with
| ModuleOrNamespaceBinding.Binding bind -> accBind cenv env bind
| ModuleOrNamespaceBinding.Module(mspec, rhs) -> accTycon cenv env mspec; accModuleOrNamespaceDef cenv env rhs
| ModuleOrNamespaceBinding.Binding bind ->
accBind cenv env bind
| ModuleOrNamespaceBinding.Module(mspec, rhs) ->
accTycon cenv env mspec
accModuleOrNamespaceDef cenv env rhs

let UnsolvedTyparsOfModuleDef g amap denv (mdef, extraAttribs) =
let cenv =
Expand Down
28 changes: 26 additions & 2 deletions src/fsharp/IlxGen.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -141,6 +141,8 @@ type IlxGenIntraAssemblyInfo =
/// that come from both the signature and the implementation.
StaticFieldInfo : Dictionary<ILMethodRef, ILFieldSpec> }

type FakeUnit = | Fake

//--------------------------------------------------------------------------

/// Indicates how the generated IL code is ultimately emitted
Expand Down Expand Up @@ -2044,6 +2046,13 @@ let rec GenExpr (cenv:cenv) (cgbuf:CodeGenBuffer) eenv sp expr sequel =
GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel
| Expr.Val(v,_,m) ->
GenGetVal cenv cgbuf eenv (v,m) sequel

// Most generation of linear expressions is implemented routinely using tailcalls and the correct sequels.
// This is because the element of expansion happens to be the final thing generated in most cases. However
// for large lists we have to process the linearity separately
| LinearOpExpr _ ->
GenLinearExpr cenv cgbuf eenv expr sequel id |> ignore<FakeUnit>

| Expr.Op(op,tyargs,args,m) ->
match op,args,tyargs with
| TOp.ExnConstr(c),_,_ ->
Expand Down Expand Up @@ -2346,12 +2355,27 @@ and GenAllocExn cenv cgbuf eenv (c,args,m) sequel =
(mkNormalNewobj mspec)
GenSequel cenv eenv.cloc cgbuf sequel

and GenAllocUnionCaseCore cenv cgbuf eenv (c,tyargs,n,m) =
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv c tyargs
CG.EmitInstrs cgbuf (pop n) (Push [cuspec.DeclaringType]) (EraseUnions.mkNewData cenv.g.ilg (cuspec, idx))

and GenAllocUnionCase cenv cgbuf eenv (c,tyargs,args,m) sequel =
GenExprs cenv cgbuf eenv args
let cuspec,idx = GenUnionCaseSpec cenv.amap m eenv.tyenv c tyargs
CG.EmitInstrs cgbuf (pop args.Length) (Push [cuspec.DeclaringType]) (EraseUnions.mkNewData cenv.g.ilg (cuspec, idx))
GenAllocUnionCaseCore cenv cgbuf eenv (c,tyargs,args.Length,m)
GenSequel cenv eenv.cloc cgbuf sequel

and GenLinearExpr cenv cgbuf eenv expr sequel (contf: FakeUnit -> FakeUnit) =
match expr with
| LinearOpExpr (TOp.UnionCase c, tyargs, argsFront, argLast, m) ->
GenExprs cenv cgbuf eenv argsFront
GenLinearExpr cenv cgbuf eenv argLast Continue (contf << (fun (Fake) ->
GenAllocUnionCaseCore cenv cgbuf eenv (c, tyargs, argsFront.Length + 1, m)
GenSequel cenv eenv.cloc cgbuf sequel
Fake))
| _ ->
GenExpr cenv cgbuf eenv SPSuppress expr sequel
contf Fake

and GenAllocRecd cenv cgbuf eenv ctorInfo (tcref,argtys,args,m) sequel =
let ty = GenNamedTyApp cenv.amap m eenv.tyenv tcref argtys

Expand Down
Loading

0 comments on commit 166ec38

Please sign in to comment.